(c-mode . ((c-file-style . "gnu")))
(scheme-mode
. ((indent-tabs-mode . nil)
- (eval . (put 'pass-if 'scheme-indent-function 1))
- (eval . (put 'pass-if-exception 'scheme-indent-function 2))
- (eval . (put 'pass-if-equal 'scheme-indent-function 2))
- (eval . (put 'with-test-prefix 'scheme-indent-function 1))
- (eval . (put 'with-code-coverage 'scheme-indent-function 1))
- (eval . (put 'with-statprof 'scheme-indent-function 1))))
+ (eval . (put 'pass-if 'scheme-indent-function 1))
+ (eval . (put 'pass-if-exception 'scheme-indent-function 2))
+ (eval . (put 'pass-if-equal 'scheme-indent-function 2))
+ (eval . (put 'with-test-prefix 'scheme-indent-function 1))
+ (eval . (put 'with-code-coverage 'scheme-indent-function 1))
+ (eval . (put 'with-statprof 'scheme-indent-function 1))
+ (eval . (put 'let-gensyms 'scheme-indent-function 1))
+ (eval . (put 'let-fresh 'scheme-indent-function 2))
+ (eval . (put 'with-fresh-name-state 'scheme-indent-function 1))
+ (eval . (put 'with-fresh-name-state-from-dfg 'scheme-indent-function 1))
+ (eval . (put 'build-cps-term 'scheme-indent-function 0))
+ (eval . (put 'build-cps-exp 'scheme-indent-function 0))
+ (eval . (put 'build-cps-cont 'scheme-indent-function 0))
+ (eval . (put 'rewrite-cps-term 'scheme-indent-function 1))
+ (eval . (put 'rewrite-cps-cont 'scheme-indent-function 1))
+ (eval . (put 'rewrite-cps-exp 'scheme-indent-function 1))
+ (eval . (put '$letk 'scheme-indent-function 1))
+ (eval . (put '$letk* 'scheme-indent-function 1))
+ (eval . (put '$letconst 'scheme-indent-function 1))
+ (eval . (put '$continue 'scheme-indent-function 2))
+ (eval . (put '$kargs 'scheme-indent-function 2))
+ (eval . (put '$kfun 'scheme-indent-function 4))
+ (eval . (put '$letrec 'scheme-indent-function 3))
+ (eval . (put '$kclause 'scheme-indent-function 1))
+ (eval . (put '$fun 'scheme-indent-function 1))
+ (eval . (put 'syntax-parameterize 'scheme-indent-function 1))))))
(emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72))))
guile-config/guile-config
*.go
TAGS
-/meta/guile-2.0.pc
-/meta/guile-2.0-uninstalled.pc
+/meta/guile-2.2.pc
+/meta/guile-2.2-uninstalled.pc
gdb-pre-inst-guile
cscope.out
cscope.files
/test-suite/standalone/test-scm-values
/test-suite/standalone/test-scm-to-latin1-string
/test-suite/standalone/test-scm-c-bind-keyword-arguments
+/libguile/vm-operations.h
/test-suite/standalone/test-foreign-object-c
/test-suite/standalone/test-srfi-4
# Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'.
GUILE_MAJOR_VERSION=2
-GUILE_MINOR_VERSION=0
-GUILE_MICRO_VERSION=11
+GUILE_MINOR_VERSION=1
+GUILE_MICRO_VERSION=0
-GUILE_EFFECTIVE_VERSION=2.0
+GUILE_EFFECTIVE_VERSION=2.2
# 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
-# Makefile.am The only library not handled here is
-# guile-readline/libguile-readline. It is handled in
-# ./guile-readline/LIBGUILEREADLINE-VERSION.
+# Makefile.am.
# See libtool info pages for more information on how and when to
# change these.
-LIBGUILE_INTERFACE_CURRENT=29
-LIBGUILE_INTERFACE_REVISION=2
-LIBGUILE_INTERFACE_AGE=7
+LIBGUILE_INTERFACE_CURRENT=0
+LIBGUILE_INTERFACE_REVISION=0
+LIBGUILE_INTERFACE_AGE=0
LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}"
Please send Guile bug reports to bug-guile@gnu.org.
+\f
+Changes in 2.1.1 (changes since the 2.0.x series):
+
+* Notable changes
+
+** Speed
+
+The biggest change in Guile 2.2 is a complete rewrite of its virtual
+machine and compiler internals. The result is faster startup time,
+better memory usage, and faster execution of user code. See the
+"Performance improvements" section below for more details.
+
+** Better thread-safety
+
+This new release series takes the ABI-break opportunity to fix some
+interfaces that were difficult to use correctly from multiple threads.
+Notably, weak hash tables are now transparently thread-safe. Ports are
+also thread-safe; see "New interfaces" below for details on the changes
+to the C interface.
+
+** Better space-safety
+
+It used to be the case that, when calling a Scheme procedure, the
+procedure and arguments were always preserved against garbage
+collection. This is no longer the case; Guile is free to collect the
+procedure and arguments if they become unreachable, or to re-use their
+slots for other local variables. Guile still offers good-quality
+backtraces by determining the procedure being called from the
+instruction pointer instead of from the value in slot 0 of an
+application frame, and by using a live variable map that allows the
+debugger to know which locals are live at all points in a frame.
+
+** Off-main-thread finalization
+
+Following Guile 2.0.6's change to invoke finalizers via asyncs, Guile
+2.2 takes the additional step of invoking finalizers from a dedicated
+finalizer thread, if threads are enabled. This avoids concurrency
+issues between finalizers and application code, and also speeds up
+finalization. If your application's finalizers are not robust to the
+presence of threads, see "Foreign Objects" in the manual for information
+on how to disable automatic finalization and instead run finalizers
+manually.
+
+** Better locale support in Guile scripts
+
+When Guile is invoked directly, either from the command line or via a
+hash-bang line (e.g. "#!/usr/bin/guile"), it now installs the current
+locale via a call to `(setlocale LC_ALL "")'. For users with a unicode
+locale, this makes all ports unicode-capable by default, without the
+need to call `setlocale' in your program. This behavior may be
+controlled via the GUILE_INSTALL_LOCALE environment variable; see the
+manual for more.
+
+** Complete Emacs-compatible Elisp implementation
+
+Thanks to the work of BT Templeton, Guile's Elisp implementation is now
+fully Emacs-compatible, implementing all of Elisp's features and quirks
+in the same way as the editor we know and love.
+
+** Dynamically expandable stacks
+
+Instead of allocating fixed stack sizes for running Scheme code, Guile
+now starts off each thread with only one page of stack, and expands and
+shrinks it dynamically as needed. Guile will throw an exception for
+stack overflows if growing the stack fails. It is also possible to
+impose a stack limit during the extent of a function call. See "Stack
+Overflow" in the manual, for more.
+
+This change allows users to write programs that use the stack as a data
+structure for pending computations, as it was meant to be, without
+reifying that data out to the heap. Where you would previously make a
+loop that collect its results in reverse order only to re-reverse them
+at the end, now you can just recurse without worrying about stack
+overflows.
+
+** Out-of-memory improvements
+
+Instead of aborting, failures to allocate memory will now raise an
+unwind-only `out-of-memory' exception, and cause the corresponding
+`catch' expression to run garbage collection in order to free up memory.
+
+* Performance improvements
+
+** Faster programs via new virtual machine
+
+Guile's new virtual machine compiles programs to instructions for a new
+virtual machine. The new virtual machine's instructions can address
+their source and destination operands by "name" (slot). This makes
+access to named temporary values much faster, and removes a lot of
+value-shuffling that the old virtual machine had to do. The end result
+is that loop-heavy code can be two or three times as fast with Guile 2.2
+as in 2.0. Your mileage may vary, of course; see "A Virtual Machine for
+Guile" in the manual for the nitties and the gritties.
+
+** Better startup time, memory usage with ELF object file format
+
+Guile now uses the standard ELF format for its compiled code. (Guile
+has its own loader and linker, so this does not imply a dependency on
+any particular platform's ELF toolchain.) The benefit is that Guile is
+now able to statically allocate more data in the object files. ELF also
+enables more sharing of data between processes, and decreases startup
+time (about 40% faster than the already fast startup of the Guile 2.0
+series). Guile also uses DWARF for some of its debugging information.
+Much of the debugging information can be stripped from the object files
+as well. See "Object File Format" in the manual, for full details.
+
+** Better optimizations via compiler rewrite
+
+Guile's compiler now uses a Continuation-Passing Style (CPS)
+intermediate language, allowing it to reason easily about temporary
+values and control flow. Examples of optimizations that this permits
+are optimal contification, optimal common subexpression elimination,
+dead code elimination, parallel moves with at most one temporary,
+allocation of stack slots using precise liveness information, and
+closure optimization. For more, see "Continuation-Passing Style" in the
+manual.
+
+** Faster interpreter
+
+Combined with a number of optimizations to the interpreter itself,
+simply compiling `eval.scm' with the new compiler yields an interpreter
+that is consistently two or three times faster than the one in Guile
+2.0.
+
+** Allocation-free dynamic stack
+
+Guile now implements the dynamic stack with an actual stack instead of a
+list of heap objects, avoiding most allocation. This speeds up prompts,
+the `scm_dynwind_*' family of functions, fluids, and `dynamic-wind'.
+
+** Optimized UTF-8 and Latin-1 ports, symbols, and strings
+
+Guile 2.2 is faster at reading and writing UTF-8 and Latin-1 strings
+from ports, and at converting symbols and strings to and from these
+encodings.
+
+** Optimized hash functions
+
+Guile 2.2 now uses Bob Jenkins' `hashword2' (from his `lookup3.c') for
+its string hash, and Thomas Wang's integer hash function for `hashq' and
+`hashv'. These functions produce much better hash values across all
+available fixnum bits.
+
+** Optimized generic array facility
+
+Thanks to work by Daniel Llorens, the generic array facility is much
+faster now, as it is internally better able to dispatch on the type of
+the underlying backing store.
+
+* New interfaces
+
+** New `cond-expand' feature: `guile-2.2'
+
+Use this feature if you need to check for Guile 2.2 from Scheme code.
+
+** New predicate: `nil?'
+
+See "Nil" in the manual.
+
+** New compiler modules
+
+Since the compiler was rewritten, there are new modules for the back-end
+of the compiler and the low-level loader and introspection interfaces.
+See the "Guile Implementation" chapter in the manual for all details.
+
+** New functions: `scm_to_intptr_t', `scm_from_intptr_t'
+** New functions: `scm_to_uintptr_t', `scm_from_uintptr_t'
+
+See "Integers" in the manual, for more.
+
+** New thread-safe port API
+
+For details on `scm_c_make_port', `scm_c_make_port_with_encoding',
+`scm_c_lock_port', `scm_c_try_lock_port', `scm_c_unlock_port',
+`scm_c_port_type_ref', `scm_c_port_type_add_x', `SCM_PORT_DESCRIPTOR',
+and `scm_dynwind_lock_port', see XXX.
+
+There is now a routine to atomically adjust port "revealed counts". See
+XXX for more on `scm_adjust_port_revealed_x' and
+`adjust-port-revealed!',
+
+All other port API now takes the lock on the port if needed. There are
+some C interfaces if you know that you don't need to take a lock; see
+XXX for details on `scm_get_byte_or_eof_unlocked',
+`scm_peek_byte_or_eof_unlocked' `scm_c_read_unlocked',
+`scm_getc_unlocked' `scm_unget_byte_unlocked', `scm_ungetc_unlocked',
+`scm_ungets_unlocked', `scm_fill_input_unlocked' `scm_putc_unlocked',
+`scm_puts_unlocked', and `scm_lfwrite_unlocked'.
+
+** New inline functions: `scm_new_smob', `scm_new_double_smob'
+
+These can replace many uses of SCM_NEWSMOB, SCM_RETURN_NEWSMOB2, and the
+like. See XXX in the manual, for more.
+
+** New low-level type accessors
+
+For more on `SCM_HAS_TYP7', `SCM_HAS_TYP7S', `SCM_HAS_TYP16', see XXX.
+
+`SCM_HEAP_OBJECT_P' is now an alias for the inscrutable `SCM_NIMP'.
+
+`SCM_UNPACK_POINTER' and `SCM_PACK_POINTER' are better-named versions of
+the old `SCM2PTR' and `PTR2SCM'. Also, `SCM_UNPACK_POINTER' yields a
+void*.
+
+** <standard-vtable>, standard-vtable-fields
+
+See "Structures" in the manual for more on these
+
+** Convenience utilities for ports and strings.
+
+See XXX for more on `scm_from_port_string', `scm_from_port_stringn',
+`scm_to_port_string', and `scm_to_port_stringn'.
+
+** New expressive PEG parser
+
+See "PEG Parsing" in the manual for more. Thanks to Michael Lucy for
+originally writing these, and to Noah Lavine for integration work.
+
+* Incompatible changes
+
+** ASCII is not ISO-8859-1
+
+In Guile 2.0, if a user set "ASCII" or "ANSI_X3.4-1968" as the encoding
+of a port, Guile would treat it as ISO-8859-1. While these encodings
+are the same for codepoints 0 to 127, ASCII does not extend past that
+range, whereas ISO-8859-1 goes up to 255. Guile 2.2 no longer treats
+ASCII as ISO-8859-1. This is likely to be a problem only if the user's
+locale is set to ASCII, and the user or a program writes non-ASCII
+codepoints to a port.
+
+** String ports default to UTF-8
+
+Guile 2.0 would use the `%default-port-encoding' when creating string
+ports. This resulted in ports that could only accept a subset of valid
+characters, which was surprising to users. Now string ports default to
+the UTF-8 encoding. Sneaky users can still play encoding conversion
+games with string ports by explicitly setting the encoding of a port
+after it is open. See "Ports" in the manual for more.
+
+** `scm_from_stringn' and `scm_to_stringn' encoding arguments are never NULL
+
+These functions now require a valid `encoding' argument, and will abort
+if given `NULL'.
+
+** All r6rs ports are both textual and binary
+
+Because R6RS ports are a thin layer on top of Guile's ports, and Guile's
+ports are both textual and binary, Guile's R6RS ports are also both
+textual and binary, and thus both kinds have port transcoders. This is
+an incompatibility with respect to R6RS.
+
+** Vtable hierarchy changes
+
+In an attempt to make Guile's structure and record types integrate
+better with GOOPS by unifying the vtable hierarchy, `make-vtable-vtable'
+is now deprecated. Instead, users should just use `make-vtable' with
+appropriate arguments. See "Structures" in the manual for all of the
+details. As such, `record-type-vtable' and `%condition-type-vtable' now
+have a parent vtable and are no longer roots of the vtable hierarchy.
+
+** Syntax parameters are a distinct type
+
+Guile 2.0's transitional implementation of `syntax-parameterize' was
+based on the `fluid-let-syntax' interface inherited from the psyntax
+expander. This interface allowed any binding to be dynamically rebound
+-- even bindings like `lambda'. This is no longer the case in Guile
+2.2. Syntax parameters must be defined via `define-syntax-parameter',
+and only such bindings may be parameterized. See "Syntax Parameters" in
+the manual for more.
+
+** Defined identifiers scoped in the current module
+
+Sometimes Guile's expander would attach incorrect module scoping
+information for top-level bindings made by an expansion. For example,
+given the following R6RS library:
+
+ (library (defconst)
+ (export defconst)
+ (import (guile))
+ (define-syntax-rule (defconst name val)
+ (begin
+ (define t val)
+ (define-syntax-rule (name) t))))
+
+Attempting to use it would produce an error:
+
+ (import (defconst))
+ (defconst foo 42)
+ (foo)
+ =| Unbound variable: t
+
+It wasn't clear that we could fix this in Guile 2.0 without breaking
+someone's delicate macros, so the fix is only coming out now.
+
+** Pseudo-hygienically rename macro-introduced bindings
+
+Bindings introduced by macros, like `t' in the `defconst' example above,
+are now given pseudo-fresh names. This allows
+
+ (defconst foo 42)
+ (defconst bar 37)
+
+to introduce different bindings for `t'. These pseudo-fresh names are
+made in such a way that if the macro is expanded again, for example as
+part of a simple recompilation, the introduced identifiers get the same
+pseudo-fresh names. See "Hygiene and the Top-Level" in the manual, for
+details.
+
+** Fix literal matching for module-bound literals
+
+`syntax-rules' and `syntax-case' macros can take a set of "literals":
+bound or unbound keywords that the syntax matcher treats specially.
+Before, literals were always matched symbolically (by name). Now they
+are matched by binding. This allows literals to be reliably bound to
+values, renamed by imports or exports, et cetera. See "Syntax-rules
+Macros" in the manual for more on literals.
+
+** `dynamic-wind' doesn't check that guards are thunks
+
+Checking that the dynamic-wind out-guard procedure was actually a thunk
+before doing the wind was slow, unreliable, and not strictly needed.
+
+** All deprecated code removed
+
+All code deprecated in Guile 2.0 has been removed. See older NEWS, and
+check that your programs can compile without linker warnings and run
+without runtime warnings. See "Deprecation" in the manual.
+
+** Remove miscellaneous unused interfaces
+
+We have removed accidentally public, undocumented interfaces that we
+think are not used, and not useful. This includes `scm_markstream',
+`SCM_FLUSH_REGISTER_WINDOWS', `SCM_THREAD_SWITCHING_CODE', `SCM_FENCE',
+`scm_call_generic_0', `scm_call_generic_1', `scm_call_generic_2'
+`scm_call_generic_3', `scm_apply_generic', and `scm_program_source'.
+`scm_async_click' was renamed to `scm_async_tick', and `SCM_ASYNC_TICK'
+was made private (use `SCM_TICK' instead).
+
+** Many internal compiler / VM changes
+
+As the compiler and virtual machine were re-written, there are many
+changes in the back-end of Guile to interfaces that were introduced in
+Guile 2.0. These changes are only only of interest if you wrote a
+language on Guile 2.0 or a tool using Guile 2.0 internals. If this is
+the case, drop by the IRC channel to discuss the changes.
+
+** Defining a SMOB or port type no longer mucks exports of `(oop goops)'
+
+It used to be that defining a SMOB or port type added an export to
+GOOPS, for the wrapper class of the smob type. This violated
+modularity, though, so we have removed this behavior.
+
+** Bytecode replaces objcode as a target language
+
+One way in which people may have used details of Guile's runtime in
+Guile 2.0 is in compiling code to thunks for later invocation. Instead
+of compiling to objcode and then calling `make-program', now the way to
+do it is to compile to `bytecode' and then call `load-thunk-from-memory'
+from `(system vm loader)'.
+
+** Weak pairs removed
+
+Weak pairs were not safe to access with `car' and `cdr', and so were
+removed.
+
+** Weak alist vectors removed
+
+Use weak hash tables instead.
+
+** Weak vectors may no longer be accessed via `vector-ref' et al
+
+Weak vectors may no longer be accessed with the vector interface. This
+was a source of bugs in the 2.0 Guile implementation, and a limitation
+on using vectors as building blocks for other abstractions. Vectors in
+Guile are now a concrete type; for an abstract interface, use the
+generic array facility (`array-ref' et al).
+
+** scm_t_array_implementation removed
+
+This interface was introduced in 2.0 but never documented. It was a
+failed attempt to layer the array implementation that actually
+introduced too many layers, as it prevented the "vref" and "vset"
+members of scm_t_array_handle (called "ref" and "set" in 1.8, not
+present in 2.0) from specializing on array backing stores.
+
+Notably, the definition of scm_t_array_handle has now changed, to not
+include the (undocumented) "impl" member. We are sorry for any
+inconvenience this may cause.
+
+* New deprecations
+
+** SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1, SCM_WTA_DISPATCH_2, SCM_WTA_DISPATCH_N
+** SCM_GASSERT0, SCM_GASSERT1, SCM_GASSERT2, SCM_GASSERTn
+** SCM_WTA_DISPATCH_1_SUBR
+
+These macros were used in dispatching primitive generics. They can be
+replaced by using C functions (the same name but in lower case), if
+needed, but this is a hairy part of Guile that perhaps you shouldn't be
+using.
+
+* Changes to the distribution
+
+** New minor version
+
+The "effective version" of Guile is now 2.2, which allows parallel
+installation with other effective versions (for example, the older Guile
+2.0). See "Parallel Installations" in the manual for full details.
+Notably, the `pkg-config' file is now `guile-2.2'.
+
+** Bump required libgc version to 7.2, released March 2012.
+
+** The readline extension is now installed in the extensionsdir
+
+The shared library that implements Guile's readline extension is no
+longer installed to the libdir. This change should be transparent to
+users, but packagers may be interested.
+
+
+\f
Changes in 2.0.11 (since 2.0.10):
This release fixes an embarrassing regression introduced in the C
dnl -*- Autoconf -*-
dnl Copyright (C) 1997, 1999, 2000, 2001, 2002, 2004, 2006,
-dnl 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+dnl 2007, 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
dnl
dnl This file is part of GUILE
dnl
AC_CHECK_FUNCS([strdup])
AC_SUBST([READLINE_LIBS])
-
- . $srcdir/guile-readline/LIBGUILEREADLINE-VERSION
- AC_SUBST(LIBGUILEREADLINE_MAJOR)
- AC_SUBST(LIBGUILEREADLINE_INTERFACE_CURRENT)
- AC_SUBST(LIBGUILEREADLINE_INTERFACE_REVISION)
- AC_SUBST(LIBGUILEREADLINE_INTERFACE_AGE)
- AC_SUBST(LIBGUILEREADLINE_INTERFACE)
])
dnl GUILE_LIBUNISTRING_WITH_ICONV_SUPPORT
# -*- makefile -*-
-GOBJECTS = $(SOURCES:%.scm=%.go)
+GOBJECTS = $(SOURCES:%.scm=%.go) $(ELISP_SOURCES:%.el=%.go)
GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat
moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath)
-nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
+nobase_mod_DATA = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES)
ccachedir = $(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache/$(modpath)
nobase_ccache_DATA = $(GOBJECTS)
-EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
-ETAGS_ARGS = $(SOURCES) $(NOCOMP_SOURCES)
+EXTRA_DIST = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES)
+ETAGS_ARGS = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES)
CLEANFILES = $(GOBJECTS)
AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY))
AM_V_GUILEC_0 = @echo " GUILEC" $@;
-SUFFIXES = .scm .go
+SUFFIXES = .scm .el .go
+
.scm.go:
- $(AM_V_GUILEC)GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \
+ $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/uninstalled-env \
guild compile --target="$(host)" $(GUILE_WARNINGS) \
-L "$(abs_srcdir)" -L "$(abs_builddir)" \
-L "$(abs_top_srcdir)/guile-readline" \
-o "$@" "$<"
+
+.el.go:
+ $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
+ $(top_builddir)/meta/uninstalled-env \
+ guild compile --target="$(host)" $(GUILE_WARNINGS) \
+ -L "$(abs_srcdir)" -L "$(abs_builddir)" \
+ -L "$(abs_top_srcdir)/guile-readline" \
+ --from=elisp -o "$@" "$<"
;;; ports.bm --- Port I/O. -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2010-2014 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
(string-concatenate (make-list (* iteration-factor 10000) s)))
(define %latin1-port
- (with-fluids ((%default-port-encoding #f))
- (open-input-string (large-string "hello, world"))))
+ (let ((p (open-input-string (large-string "hello, world"))))
+ (set-port-encoding! p "ISO-8859-1")
+ p))
(define %utf8/ascii-port
- (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string (large-string "hello, world"))))
+ (open-input-string (large-string "hello, world")))
(define %utf8/wide-port
- (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string (large-string "안녕하세요"))))
+ (open-input-string (large-string "안녕하세요")))
\f
(with-benchmark-prefix "peek-char"
(let ((str (string-concatenate (make-list 1000 "one line\n"))))
(benchmark "read-line" 1000
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string str))))
+ (let ((port (open-input-string str)))
(sequence (read-line port) 1000))))
(let ((str (large-string "Hello, world.\n")))
(benchmark "read-string" 200
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string str))))
+ (let ((port (open-input-string str)))
(read-string port)))))
define(GUILE_CONFIGURE_COPYRIGHT,[[
Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
- 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+ 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
This file is part of GUILE
AC_PREREQ(2.61)
AC_INIT([GNU Guile],
- m4_esyscmd([build-aux/git-version-gen --match v2.0.\* .tarball-version]),
+ m4_esyscmd([build-aux/git-version-gen --match v2.\[12\].\* .tarball-version]),
[bug-guile@gnu.org])
AC_CONFIG_AUX_DIR([build-aux])
AC_CONFIG_MACRO_DIR([m4])
# Boehm's GC library
#
#--------------------------------------------------------------------
-PKG_CHECK_MODULES([BDW_GC], [bdw-gc])
+PKG_CHECK_MODULES([BDW_GC], [bdw-gc >= 7.2])
save_LIBS="$LIBS"
LIBS="$BDW_GC_LIBS $LIBS"
CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
-AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit \
- GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask \
- GC_set_start_callback GC_get_heap_usage_safe \
- GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes \
- GC_set_finalizer_notifier GC_set_finalize_on_demand \
- GC_set_all_interior_pointers GC_get_gc_no GC_set_java_finalization])
-
-# Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not
-# declared, and has a different type (returning void instead of
-# void*).
-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>])
+# Functions that might not be defined, depending on configuration.
+AC_CHECK_FUNCS([GC_pthread_exit GC_pthread_cancel GC_pthread_sigmask])
-# `GC_stack_base' is not available in GC 7.1 and earlier.
-AC_CHECK_TYPE([struct GC_stack_base],
- [AC_DEFINE([HAVE_GC_STACK_BASE], [1],
- [Define this if the `GC_stack_base' type is available.])],
- [],
- [#include <gc/gc.h>])
+# Functions from GC 7.3.
+AC_CHECK_FUNCS([GC_move_disappearing_link])
LIBS="$save_LIBS"
.\" groff -man -Tascii foo.1
.\"
.\" title section date source manual
-.TH GUILE 1 "2011-03-04" GNU "GNU Guile 2.0"
+.TH GUILE 1 "2011-03-04" GNU "GNU Guile 2.2"
.
.SH NAME
guile \- The GNU Project Extension Language
api-foreign.texi \
api-regex.texi \
api-lalr.texi \
+ api-peg.texi \
api-languages.texi \
api-evaluation.texi \
api-memory.texi \
libguile-autoconf.texi: autoconf-macros.texi
autoconf-macros.texi: $(top_srcdir)/meta/guile.m4
- GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \
- $(top_builddir)/meta/uninstalled-env guild \
+ GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guild \
snarf-guile-m4-docs $(top_srcdir)/meta/guile.m4 \
> $(srcdir)/$@
@end deffn
@deffn {Scheme Procedure} make-prompt-tag [stem]
-Make a new prompt tag. Currently prompt tags are generated symbols.
-This may change in some future Guile version.
+Make a new prompt tag. A prompt tag is simply a unique object.
+Currently, a prompt tag is a fresh pair. This may change in some future
+Guile version.
@end deffn
@deffn {Scheme Procedure} default-prompt-tag
Return the default prompt tag. Having a distinguished default prompt
tag allows some useful prompt and abort idioms, discussed in the next
-section.
+section. Note that @code{default-prompt-tag} is actually a parameter,
+and so may be dynamically rebound using @code{parameterize}.
+@xref{Parameters}.
@end deffn
@deffn {Scheme Procedure} abort-to-prompt tag val1 val2 @dots{}
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2010 Free Software Foundation, Inc.
+@c Copyright (C) 2010, 2013 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
coverage)} module provides tools to gather code coverage data and to present
them, as detailed below.
-@deffn {Scheme Procedure} with-code-coverage vm thunk
-Run @var{thunk}, a zero-argument procedure, using @var{vm}; instrument @var{vm}
-to collect code coverage data. Return code coverage data and the values
-returned by @var{thunk}.
+@deffn {Scheme Procedure} with-code-coverage thunk
+Run @var{thunk}, a zero-argument procedure, while instrumenting Guile's
+virtual machine to collect code coverage data. Return code coverage
+data and the values returned by @var{thunk}.
@end deffn
@deffn {Scheme Procedure} coverage-data? obj
(system vm vm))
(call-with-values (lambda ()
- (with-code-coverage (the-vm)
+ (with-code-coverage
(lambda ()
(do-something-tricky))))
(lambda (data result)
@deftypefnx {C Function} scm_t_uint64 scm_to_uint64 (SCM x)
@deftypefnx {C Function} scm_t_intmax scm_to_intmax (SCM x)
@deftypefnx {C Function} scm_t_uintmax scm_to_uintmax (SCM x)
+@deftypefnx {C Function} scm_t_intptr scm_to_intptr_t (SCM x)
+@deftypefnx {C Function} scm_t_uintptr scm_to_uintptr_t (SCM x)
When @var{x} represents an exact integer that fits into the indicated
C type, return that integer. Else signal an error, either a
`wrong-type' error when @var{x} is not an exact integer, or an
@deftypefnx {C Function} SCM scm_from_uint64 (scm_t_uint64 x)
@deftypefnx {C Function} SCM scm_from_intmax (scm_t_intmax x)
@deftypefnx {C Function} SCM scm_from_uintmax (scm_t_uintmax x)
+@deftypefnx {C Function} SCM scm_from_intptr_t (scm_t_intptr x)
+@deftypefnx {C Function} SCM scm_from_uintptr_t (scm_t_uintptr x)
Return the @code{SCM} value that represents the integer @var{x}.
These functions will always succeed and will always return an exact
number.
for @code{scm_to_utf32_stringn}.
@end deftypefn
+It is not often the case, but sometimes when you are dealing with the
+implementation details of a port, you need to encode and decode strings
+according to the encoding and conversion strategy of the port. There
+are some convenience functions for that purpose as well.
+
+@deftypefn {C Function} SCM scm_from_port_string (const char *str, SCM port)
+@deftypefnx {C Function} SCM scm_from_port_stringn (const char *str, size_t len, SCM port)
+@deftypefnx {C Function} char* scm_to_port_string (SCM str, SCM port)
+@deftypefnx {C Function} char* scm_to_port_stringn (SCM str, size_t *lenp, SCM port)
+Like @code{scm_from_stringn} and friends, except they take their
+encoding and conversion strategy from a given port object.
+@end deftypefn
+
@node String Internals
@subsubsection String Internals
otherwise the frames are taken from @var{obj} (which must be
a continuation or a frame object).
-@var{arg} @dots{} can be any combination of integer, procedure, prompt
-tag and @code{#t} values.
-
-These values specify various ways of cutting away uninteresting
-stack frames from the top and bottom of the stack that
-@code{make-stack} returns. They come in pairs like this:
-@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}
-@var{outer_cut_2} @dots{})}.
-
-Each @var{inner_cut_i} can be @code{#t}, an integer, a prompt
-tag, or a procedure. @code{#t} means to cut away all frames up
-to but excluding the first user module frame. An integer means
-to cut away exactly that number of frames. A prompt tag means
-to cut away all frames that are inside a prompt with the given
-tag. A procedure means to cut away all frames up to but
-excluding the application frame whose procedure matches the
-specified one.
-
-Each @var{outer_cut_i} can be an integer, a prompt tag, or a
-procedure. An integer means to cut away that number of frames.
-A prompt tag means to cut away all frames that are outside a
-prompt with the given tag. A procedure means to cut away
-frames down to but excluding the application frame whose
-procedure matches the specified one.
-
-If the @var{outer_cut_i} of the last pair is missing, it is
-taken as 0.
+@var{arg} @dots{} can be any combination of integer, procedure, address
+range, and prompt tag values.
+
+These values specify various ways of cutting away uninteresting stack
+frames from the top and bottom of the stack that @code{make-stack}
+returns. They come in pairs like this: @code{(@var{inner_cut_1}
+@var{outer_cut_1} @var{inner_cut_2} @var{outer_cut_2} @dots{})}.
+
+Each @var{inner_cut_i} can be an integer, a procedure, an address range,
+or a prompt tag. An integer means to cut away exactly that number of
+frames. A procedure means to cut away all frames up to but excluding
+the frame whose procedure matches the specified one. An address range
+is a pair of integers indicating the low and high addresses of a
+procedure's code, and is the same as cutting away to a procedure (though
+with less work). Anything else is interpreted as a prompt tag which
+cuts away all frames that are inside a prompt with the given tag.
+
+Each @var{outer_cut_i} can likewise be an integer, a procedure, an
+address range, or a prompt tag. An integer means to cut away that
+number of frames. A procedure means to cut away frames down to but
+excluding the frame whose procedure matches the specified one. An
+address range is the same, but with the procedure's code specified as an
+address range. Anything else is taken to be a prompt tag, which cuts
+away all frames that are outside a prompt with the given tag.
+
+
+If the @var{outer_cut_i} of the last pair is missing, it is taken as 0.
@end deffn
@deffn {Scheme Syntax} start-stack id exp
* Catching Exceptions:: Handling errors after the stack is unwound.
* Capturing Stacks:: Capturing the stack at the time of error.
* Pre-Unwind Debugging:: Debugging before the exception is thrown.
+* Stack Overflow:: Detecting and handling runaway recursion.
* Debug Options:: A historical interface to debugging.
@end menu
@deffn {Scheme Procedure} call-with-error-handling thunk @
[#:on-error on-error='debug] [#:post-error post-error='catch] @
- [#:pass-keys pass-keys='(quit)] [#:trap-handler trap-handler='debug]
+ [#:pass-keys pass-keys='(quit)] @
+ [#:report-keys report-keys='(stack-overflow)] @
+ [#:trap-handler trap-handler='debug]
Call a thunk in a context in which errors are handled.
-There are four keyword arguments:
+There are five keyword arguments:
@table @var
@item on-error
@item pass-keys
A set of keys to ignore, as a list.
+
+@item report-keys
+A set of keys to always report even if the post-error handler is
+@code{catch}, as a list.
@end table
@end deffn
+@node Stack Overflow
+@subsubsection Stack Overflow
+
+@cindex overflow, stack
+@cindex stack overflow
+Every time a Scheme program makes a call that is not in tail position,
+it pushes a new frame onto the stack. Returning a value from a function
+pops the top frame off the stack. Stack frames take up memory, and as
+nobody has an infinite amount of memory, deep recursion could cause
+Guile to run out of memory. Running out of stack memory is called
+@dfn{stack overflow}.
+
+@subsubheading Stack Limits
+
+Most languages have a terrible stack overflow story. For example, in C,
+if you use too much stack, your program will exhibit ``undefined
+behavior'', which if you are lucky means that it will crash. It's
+especially bad in C, as you neither know ahead of time how much stack
+your functions use, nor the stack limit imposed by the user's system,
+and the stack limit is often quite small relative to the total memory
+size.
+
+Managed languages like Python have a better error story, as they are
+defined to raise an exception on stack overflow -- but like C, Python
+and most dynamic languages still have a fixed stack size limit that is
+usually much smaller than the heap.
+
+Arbitrary stack limits would have an unfortunate effect on Guile
+programs. For example, the following implementation of the inner loop
+of @code{map} is clean and elegant:
+
+@example
+(define (map f l)
+ (if (pair? l)
+ (cons (f (car l))
+ (map f (cdr l)))
+ '()))
+@end example
+
+However, if there were a stack limit, that would limit the size of lists
+that can be processed with this @code{map}. Eventually, you would have
+to rewrite it to use iteration with an accumulator:
+
+@example
+(define (map f l)
+ (let lp ((l l) (out '()))
+ (if (pair? l)
+ (lp (cdr l) (cons (f (car l)) out))
+ (reverse out))))
+@end example
+
+This second version is sadly not as clear, and it also allocates more
+heap memory (once to build the list in reverse, and then again to
+reverse the list). You would be tempted to use the destructive
+@code{reverse!} to save memory and time, but then your code would not be
+continuation-safe -- if @var{f} returned again after the map had
+finished, it would see an @var{out} list that had already been
+reversed. The recursive @code{map} has none of these problems.
+
+Guile has no stack limit for Scheme code. When a thread makes its first
+Guile call, a small stack is allocated -- just one page of memory.
+Whenever that memory limit would be reached, Guile arranges to grow the
+stack by a factor of two. When garbage collection happens, Guile
+arranges to return the unused part of the stack to the operating system,
+but without causing the stack to shrink. In this way, the stack can
+grow to consume up to all memory available to the Guile process, and
+when the recursive computation eventually finishes, that stack memory is
+returned to the system.
+
+@subsubheading Exceptional Situations
+
+Of course, it's still possible to run out of stack memory. The most
+common cause of this is program bugs that cause unbounded recursion, as
+in:
+
+@example
+(define (faulty-map f l)
+ (if (pair? l)
+ (cons (f (car l)) (faulty-map f l))
+ '()))
+@end example
+
+Did you spot the bug? The recursive call to @code{faulty-map} recursed
+on @var{l}, not @code{(cdr @var{l})}. Running this program would cause
+Guile to use up all memory in your system, and eventually Guile would
+fail to grow the stack. At that point you have a problem: Guile needs
+to raise an exception to unwind the stack and return memory to the
+system, but the user might have throw handlers in place (@pxref{Throw
+Handlers}) that want to run before the stack is unwound, and we don't
+have any stack in which to run them.
+
+Therefore in this case, Guile throws an unwind-only exception that does
+not run pre-unwind handlers. Because this is such an odd case, Guile
+prints out a message on the console, in case the user was expecting to
+be able to get a backtrace from any pre-unwind handler.
+
+@subsubheading Runaway Recursion
+
+Still, this failure mode is not so nice. If you are running an
+environment in which you are interactively building a program while it
+is running, such as at a REPL, you might want to impose an artificial
+stack limit on the part of your program that you are building to detect
+accidental runaway recursion. For that purpose, there is
+@code{call-with-stack-overflow-handler}, from @code{(system vm vm)}.
+
+@example
+(use-module (system vm vm))
+@end example
+
+@deffn {Scheme Procedure} call-with-stack-overflow-handler limit thunk handler
+Call @var{thunk} in an environment in which the stack limit has been
+reduced to @var{limit} additional words. If the limit is reached,
+@var{handler} (a thunk) will be invoked in the dynamic environment of
+the error. For the extent of the call to @var{handler}, the stack limit
+and handler are restored to the values that were in place when
+@code{call-with-stack-overflow-handler} was called.
+
+Usually, @var{handler} should raise an exception or abort to an outer
+prompt. However if @var{handler} does return, it should return a number
+of additional words of stack space to allow to the inner environment.
+@end deffn
+
+A stack overflow handler may only ever ``credit'' the inner thunk with
+stack space that was available when the handler was instated. When
+Guile first starts, there is no stack limit in place, so the outer
+handler may allow the inner thunk an arbitrary amount of space, but any
+nested stack overflow handler will not be able to consume more than its
+limit.
+
+Unlike the unwind-only exception that is thrown if Guile is unable to
+grow its stack, any exception thrown by a stack overflow handler might
+invoke pre-unwind handlers. Indeed, the stack overflow handler is
+itself a pre-unwind handler of sorts. If the code imposing the stack
+limit wants to protect itself against malicious pre-unwind handlers from
+the inner thunk, it should abort to a prompt of its own making instead
+of throwing an exception that might be caught by the inner thunk.
+
+@subsubheading C Stack Usage
+
+It is also possible for Guile to run out of space on the C stack. If
+you call a primitive procedure which then calls a Scheme procedure in a
+loop, you will consume C stack space. Guile tries to detect excessive
+consumption of C stack space, throwing an error when you have hit 80% of
+the process' available stack (as allocated by the operating system), or
+160 kilowords in the absence of a strict limit.
+
+For example, looping through @code{call-with-vm}, a primitive that calls
+a thunk, gives us the following:
+
+@lisp
+scheme@@(guile-user)> (use-modules (system vm vm))
+scheme@@(guile-user)> (let lp () (call-with-vm lp))
+ERROR: Stack overflow
+@end lisp
+
+Unfortunately, that's all the information we get. Overrunning the C
+stack will throw an unwind-only exception, because it's not safe to
+do very much when you are close to the C stack limit.
+
+If you get an error like this, you can either try rewriting your code to
+use less stack space, or increase the maximum stack size. To increase
+the maximum stack size, use @code{debug-set!}, for example:
+
+@lisp
+(debug-set! stack 200000)
+@end lisp
+
+The next section describes @code{debug-set!} more thoroughly. Of course
+the best thing is to have your code operate without so much resource
+consumption by avoiding loops through C trampolines.
+
+
@node Debug Options
@subsubsection Debug options
@end smallexample
The boolean options may be toggled with @code{debug-enable} and
-@code{debug-disable}. The non-boolean @code{keywords} option must be set
-using @code{debug-set!}.
+@code{debug-disable}. The non-boolean options must be set using
+@code{debug-set!}.
@deffn {Scheme Procedure} debug-enable option-name
@deffnx {Scheme Procedure} debug-disable option-name
name.
@end deffn
-@subsubheading Stack overflow
-
-@cindex overflow, stack
-@cindex stack overflow
-Stack overflow errors are caused by a computation trying to use more
-stack space than has been enabled by the @code{stack} option. There are
-actually two kinds of stack that can overflow, the C stack and the
-Scheme stack.
-
-Scheme stack overflows can occur if Scheme procedures recurse too far
-deeply. An example would be the following recursive loop:
-
-@lisp
-scheme@@(guile-user)> (let lp () (+ 1 (lp)))
-<unnamed port>:8:17: In procedure vm-run:
-<unnamed port>:8:17: VM: Stack overflow
-@end lisp
-
-The default stack size should allow for about 10000 frames or so, so one
-usually doesn't hit this level of recursion. Unfortunately there is no
-way currently to make a VM with a bigger stack. If you are in this
-unfortunate situation, please file a bug, and in the meantime, rewrite
-your code to be tail-recursive (@pxref{Tail Calls}).
-
-The other limit you might hit would be C stack overflows. If you call a
-primitive procedure which then calls a Scheme procedure in a loop, you
-will consume C stack space. Guile tries to detect excessive consumption
-of C stack space, throwing an error when you have hit 80% of the
-process' available stack (as allocated by the operating system), or 160
-kilowords in the absence of a strict limit.
-
-For example, looping through @code{call-with-vm}, a primitive that calls
-a thunk, gives us the following:
-
-@lisp
-scheme@@(guile-user)> (use-modules (system vm vm))
-scheme@@(guile-user)> (debug-set! stack 10000)
-scheme@@(guile-user)> (let lp () (call-with-vm (the-vm) lp))
-ERROR: In procedure call-with-vm:
-ERROR: Stack overflow
-@end lisp
-
-If you get an error like this, you can either try rewriting your code to
-use less stack space, or increase the maximum stack size. To increase
-the maximum stack size, use @code{debug-set!}, for example:
-
-@lisp
-(debug-set! stack 200000)
-@end lisp
-
-But of course it's better to have your code operate without so much
-resource consumption, avoiding loops through C trampolines.
-
@node Traps
@subsection Traps
fired at different times, which may be accessed with the following
procedures.
-All hooks are called with one argument, the frame in
-question. @xref{Frames}. Since these hooks may be fired very
-frequently, Guile does a terrible thing: it allocates the frames on the
-C stack instead of the garbage-collected heap.
+The first argument of calls to these hooks is the frame in question.
+@xref{Frames}. Some hooks may call their procedures with more
+arguments. Since these hooks may be fired very frequently, Guile does a
+terrible thing: it allocates the frames on the C stack instead of the
+garbage-collected heap.
The upshot here is that the frames are only valid within the dynamic
extent of the call to the hook. If a hook procedure keeps a reference to
@end example
@noindent
-The result of calling @code{the-vm} is usually passed as the @var{vm}
-argument to all of these procedures.
+All of these functions implicitly act on the VM for the current thread
+only.
-@deffn {Scheme Procedure} vm-next-hook vm
+@deffn {Scheme Procedure} vm-next-hook
The hook that will be fired before an instruction is retired (and
executed).
@end deffn
-@deffn {Scheme Procedure} vm-push-continuation-hook vm
+@deffn {Scheme Procedure} vm-push-continuation-hook
The hook that will be fired after preparing a new frame. Fires just
before applying a procedure in a non-tail context, just before the
corresponding apply-hook.
@end deffn
-@deffn {Scheme Procedure} vm-pop-continuation-hook vm
+@deffn {Scheme Procedure} vm-pop-continuation-hook
The hook that will be fired before returning from a frame.
-This hook is a bit trickier than the rest, in that there is a particular
-interpretation of the values on the stack. Specifically, the top value
-on the stack is the number of values being returned, and the next
-@var{n} values are the actual values being returned, with the last value
-highest on the stack.
+This hook fires with a variable number of arguments, corresponding to
+the values that the frame returns to its continuation.
@end deffn
-@deffn {Scheme Procedure} vm-apply-hook vm
+@deffn {Scheme Procedure} vm-apply-hook
The hook that will be fired before a procedure is applied. The frame's
procedure will have already been set to the new procedure.
hook.
@end deffn
-@deffn {Scheme Procedure} vm-abort-continuation-hook vm
+@deffn {Scheme Procedure} vm-abort-continuation-hook
The hook that will be called after aborting to a
-prompt. @xref{Prompts}. The stack will be in the same state as for
-@code{vm-pop-continuation-hook}.
+prompt. @xref{Prompts}.
+
+Like the pop-continuation hook, this hook fires with a variable number
+of arguments, corresponding to the values that returned to the
+continuation.
@end deffn
-@deffn {Scheme Procedure} vm-restore-continuation-hook vm
+@deffn {Scheme Procedure} vm-restore-continuation-hook
The hook that will be called after restoring an undelimited
continuation. Unfortunately it's not currently possible to introspect on
the values that were given to the continuation.
handling a hook. The trace level is restored to whatever it was once the hook
procedure finishes.
-@deffn {Scheme Procedure} vm-trace-level vm
+@deffn {Scheme Procedure} vm-trace-level
Retrieve the ``trace level'' of the VM. If positive, the trace hooks
associated with @var{vm} will be run. The initial trace level is 0.
@end deffn
-@deffn {Scheme Procedure} set-vm-trace-level! vm level
+@deffn {Scheme Procedure} set-vm-trace-level! level
Set the ``trace level'' of the VM.
@end deffn
@deffn {Scheme Procedure} call-with-trace thunk [#:calls?=#t] @
[#:instructions?=#f] @
- [#:width=80] [#:vm=(the-vm)]
+ [#:width=80]
Call @var{thunk}, tracing all execution within its dynamic extent.
If @var{calls?} is true, Guile will print a brief report at each
@var{nargs}, as a @code{size_t}.
@end deffn
-@deffn {Scheme Procedure} apply:nconc2last lst
-@deffnx {C Function} scm_nconc2last (lst)
-@var{lst} should be a list (@var{arg1} @dots{} @var{argN}
-@var{arglst}), with @var{arglst} being a list. This function returns
-a list comprising @var{arg1} to @var{argN} plus the elements of
-@var{arglst}. @var{lst} is modified to form the return. @var{arglst}
-is not modified, though the return does share structure with it.
-
-This operation collects up the arguments from a list which is
-@code{apply} style parameters.
-@end deffn
-
@deffn {Scheme Procedure} primitive-eval exp
@deffnx {C Function} scm_primitive_eval (exp)
Evaluate @var{exp} in the top-level environment specified by
@item -t @var{lang}
@itemx --to=@var{lang}
Use @var{lang} as the target language of @var{file}. If this option is omitted,
-@code{objcode} is assumed.
+@code{rtl} is assumed.
@item -T @var{target}
@itemx --target=@var{target}
-Produce bytecode for @var{target} instead of @var{%host-type}
-(@pxref{Build Config, %host-type}). Target must be a valid GNU triplet,
-such as @code{armv5tel-unknown-linux-gnueabi} (@pxref{Specifying Target
+Produce code for @var{target} instead of @var{%host-type} (@pxref{Build
+Config, %host-type}). Target must be a valid GNU triplet, such as
+@code{armv5tel-unknown-linux-gnueabi} (@pxref{Specifying Target
Triplets,,, autoconf, GNU Autoconf Manual}).
@end table
@end deffn
@deffn {Scheme Procedure} compile-file file [#:output-file=#f] @
- [#:from=(current-language)] [#:to='objcode] @
+ [#:from=(current-language)] [#:to='rtl] @
[#:env=(default-environment from)] @
[#:opts='()] @
[#:canonicalization='relative]
for a corresponding compiled file for a relative path it does so by
appending @code{.go} to the relative path. For example, searching for
@code{ice-9/popen} could find
-@code{/usr/lib/guile/2.0/ccache/ice-9/popen.go}, and use it instead of
-@code{/usr/share/guile/2.0/ice-9/popen.scm}.
+@code{/usr/lib/guile/2.2/ccache/ice-9/popen.go}, and use it instead of
+@code{/usr/share/guile/2.2/ice-9/popen.scm}.
If @code{primitive-load-path} does not find a corresponding @code{.go}
file in the @code{%load-compiled-path}, or the @code{.go} file is out of
within a @code{begin}.
If @var{file-name} is a relative path, it is searched for relative to
-the path that contains the file that the @code{include} for appears in.
+the path that contains the file that the @code{include} form appears in.
@end deffn
If you are a C programmer, if @code{load} in Scheme is like
Calls the one-argument procedure @var{proc} with a newly created output
port. When the function returns, the string composed of the characters
written into the port is returned. @var{proc} should not close the port.
-
-Note that which characters can be written to a string port depend on the port's
-encoding. The default encoding of string ports is specified by the
-@code{%default-port-encoding} fluid (@pxref{Ports,
-@code{%default-port-encoding}}). For instance, it is an error to write Greek
-letter alpha to an ISO-8859-1-encoded string port since this character cannot be
-represented with ISO-8859-1:
-
-@example
-(define alpha (integer->char #x03b1)) ; GREEK SMALL LETTER ALPHA
-
-(with-fluids ((%default-port-encoding "ISO-8859-1"))
- (call-with-output-string
- (lambda (p)
- (display alpha p))))
-
-@result{}
-Throw to key `encoding-error'
-@end example
-
-Changing the string port's encoding to a Unicode-capable encoding such as UTF-8
-solves the problem.
@end deffn
@deffn {Scheme Procedure} call-with-input-string string proc
Calls the zero-argument procedure @var{thunk} with the current output
port set temporarily to a new string port. It returns a string
composed of the characters written to the current output.
-
-See @code{call-with-output-string} above for character encoding considerations.
@end deffn
@deffn {Scheme Procedure} with-input-from-string string thunk
* Identifier Macros:: Identifier macros.
* Syntax Parameters:: Syntax Parameters.
* Eval When:: Affecting the expand-time environment.
+* Macro Expansion:: Procedurally expanding macros.
+* Hygiene and the Top-Level:: A hack you might want to know about.
* Internal Macros:: Macros as first-class values.
@end menu
@var{id}.
@end deffn
-@deffn {Scheme Procedure} syntax-local-binding id
+@deffn {Scheme Procedure} syntax-local-binding id [#:resolve-syntax-parameters?=#t]
Resolve the identifer @var{id}, a syntax object, within the current
lexical environment, and return two values, the binding type and a
binding value. The binding type is a symbol, which may be one of the
@item macro
A syntax transformer, either local or global. The value is the
transformer procedure.
+@item syntax-parameter
+A syntax parameter (@pxref{Syntax Parameters}). By default,
+@code{syntax-local-binding} will resolve syntax parameters, so that this
+value will not be returned. Pass @code{#:resolve-syntax-parameters? #f}
+to indicate that you are interested in syntax parameters. The value is
+the default transformer procedure, as in @code{macro}.
@item pattern-variable
A pattern variable, bound via @code{syntax-case}. The value is an
opaque object, internal to the expander.
warranty or poison your cat.
@end deffn
+@node Macro Expansion
+@subsection Macro Expansion
+
+Usually, macros are expanded on behalf of the user as needed. Macro
+expansion is an integral part of @code{eval} and @code{compile}. Users
+can also expand macros at the REPL prompt via the @code{expand} REPL
+command; @xref{Compile Commands}.
+
+Macros can also be expanded programmatically, via @code{macroexpand},
+but the details get a bit hairy for two reasons.
+
+The first complication is that the result of macro-expansion isn't
+Scheme: it's Tree-IL, Guile's high-level intermediate language.
+@xref{Tree-IL}. As ``hygienic macros'' can produce identifiers that are
+distinct but have the same name, the output format needs to be able to
+represent distinctions between variable identities and names. Again,
+@xref{Tree-IL}, for all the details. The easiest thing is to just run
+@code{tree-il->scheme} on the result of macro-expansion:
+
+@lisp
+(macroexpand '(+ 1 2))
+@result{}
+#<tree-il (call (toplevel +) (const 1) (const 2))>
+
+(use-modules (language tree-il))
+(tree-il->scheme (macroexpand '(+ 1 2)))
+@result{}
+(+ 1 2)
+@end lisp
+
+The second complication involves @code{eval-when}. As an example, what
+would it mean to macro-expand the definition of a macro?
+
+@lisp
+(macroexpand '(define-syntax qux (identifier-syntax 'bar)))
+@result{}
+?
+@end lisp
+
+The answer is that it depends who is macro-expanding, and why. Do you
+define the macro in the current environment? Residualize a macro
+definition? Both? Neither? The default is to expand in ``eval'' mode,
+which means an @code{eval-when} clauses will only proceed when
+@code{eval} (or @code{expand}) is in its condition set. Top-level
+macros will be @code{eval}'d in the top-level environment.
+
+In this way @code{(macroexpand @var{foo})} is equivalent to
+@code{(macroexpand @var{foo} 'e '(eval))}. The second argument is the
+mode (@code{'e} for ``eval'') and the second is the
+eval-syntax-expanders-when parameter (only @code{eval} in this default
+setting).
+
+But if you are compiling the macro definition, probably you want to
+reify the macro definition itself. In that case you pass @code{'c} as
+the second argument to @code{macroexpand}. But probably you want the
+macro definition to be present at compile time as well, so you pass
+@code{'(compile load eval)} as the @var{esew} parameter. In fact
+@code{(compile @var{foo} #:to 'tree-il)} is entirely equivalent to
+@code{(macroexpand @var{foo} 'c '(compile load eval))}; @xref{The Scheme
+Compiler}.
+
+It's a terrible interface; we know. The macroexpander is somewhat
+tricksy regarding modes, so unless you are building a macro-expanding
+tool, we suggest to avoid invoking it directly.
+
+
+@node Hygiene and the Top-Level
+@subsection Hygiene and the Top-Level
+
+Consider the following macro.
+
+@lisp
+(define-syntax-rule (defconst name val)
+ (begin
+ (define t val)
+ (define-syntax-rule (name) t)))
+@end lisp
+
+If we use it to make a couple of bindings:
+
+@lisp
+(defconst foo 42)
+(defconst bar 37)
+@end lisp
+
+The expansion would look something like this:
+
+@lisp
+(begin
+ (define t 42)
+ (define-syntax-rule (foo) t))
+(begin
+ (define t 37)
+ (define-syntax-rule (bar) t))
+@end lisp
+
+As the two @code{t} bindings were introduced by the macro, they should
+be introduced hygienically -- and indeed they are, inside a lexical
+contour (a @code{let} or some other lexical scope). The @code{t}
+reference in @code{foo} is distinct to the reference in @code{bar}.
+
+At the top-level things are more complicated. Before Guile 2.2, a use
+of @code{defconst} at the top-level would not introduce a fresh binding
+for @code{t}. This was consistent with a weaselly interpretation of the
+Scheme standard, in which all possible bindings may be assumed to exist,
+at the top-level, and in which we merely take advantage of toplevel
+@code{define} of an existing binding being equivalent to @code{set!}.
+But it's not a good reason.
+
+The solution is to create fresh names for all bindings introduced by
+macros -- not just bindings in lexical contours, but also bindings
+introduced at the top-level.
+
+However, the obvious strategy of just giving random names to introduced
+toplevel identifiers poses a problem for separate compilation. Consider
+without loss of generality a @code{defconst} of @code{foo} in module
+@code{a} that introduces the fresh top-level name @code{t-1}. If we
+then compile a module @code{b} that uses @code{foo}, there is now a
+reference to @code{t-1} in module @code{b}. If module @code{a} is then
+expanded again, for whatever reason, for example in a simple
+recompilation, the introduced @code{t} gets a fresh name; say,
+@code{t-2}. Now module @code{b} has broken because module @code{a} no
+longer has a binding for @code{t-1}.
+
+If introduced top-level identifiers ``escape'' a module, in whatever
+way, they then form part of the binary interface (ABI) of a module. It
+is unacceptable from an engineering point of view to allow the ABI to
+change randomly. (It also poses practical problems in meeting the
+recompilation conditions of the Lesser GPL license, for such modules.)
+For this reason many people prefer to never use identifier-introducing
+macros at the top-level, instead making those macros receive the names
+for their introduced identifiers as part of their arguments, or to
+construct them programmatically and use @code{datum->syntax}. But this
+approach requires omniscience as to the implementation of all macros one
+might use, and also limits the expressive power of Scheme macros.
+
+There is no perfect solution to this issue. Guile does a terrible thing
+here. When it goes to introduce a top-level identifier, Guile gives the
+identifier a pseudo-fresh name: a name that depends on the hash of the
+source expression in which the name occurs. The result in this case is
+that the introduced definitions expand as:
+
+@lisp
+(begin
+ (define t-1dc5e42de7c1050c 42)
+ (define-syntax-rule (foo) t-1dc5e42de7c1050c))
+(begin
+ (define t-10cb8ce9fdddd6e9 37)
+ (define-syntax-rule (bar) t-10cb8ce9fdddd6e9))
+@end lisp
+
+However, note that as the hash depends solely on the expression
+introducing the definition, we also have:
+
+@lisp
+(defconst baz 42)
+@result{} (begin
+ (define t-1dc5e42de7c1050c 42)
+ (define-syntax-rule (baz) t-1dc5e42de7c1050c))
+@end lisp
+
+Note that the introduced binding has the same name! This is because the
+source expression, @code{(define t 42)}, was the same. Probably you
+will never see an error in this area, but it is important to understand
+the components of the interface of a module, and that interface may
+include macro-introduced identifiers.
+
+
@node Internal Macros
@subsection Internal Macros
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2012, 2014
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2012, 2013, 2014
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
should remain unchanged during a stable series. Currently that means
that it omits the micro version. The effective version should be used
for items like the versioned share directory name
-i.e.@: @file{/usr/share/guile/2.0/}
+i.e.@: @file{/usr/share/guile/2.2/}
@lisp
-(version) @result{} "2.0.4"
-(effective-version) @result{} "2.0"
+(version) @result{} "2.2.0"
+(effective-version) @result{} "2.2"
(major-version) @result{} "2"
-(minor-version) @result{} "0"
-(micro-version) @result{} "4"
+(minor-version) @result{} "2"
+(micro-version) @result{} "0"
@end lisp
@end deffn
@file{/usr/share/guile/@var{GUILE_EFFECTIVE_VERSION}};
@noindent
-for example @file{/usr/local/share/guile/2.0}.
+for example @file{/usr/local/share/guile/2.2}.
@end deffn
@deffn {Scheme Procedure} %site-dir
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 2006, 2010, 2011
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node PEG Parsing
+@section PEG Parsing
+
+Parsing Expression Grammars (PEGs) are a way of specifying formal
+languages for text processing. They can be used either for matching
+(like regular expressions) or for building recursive descent parsers
+(like lex/yacc). Guile uses a superset of PEG syntax that allows more
+control over what information is preserved during parsing.
+
+Wikipedia has a clear and concise introduction to PEGs if you want to
+familiarize yourself with the syntax:
+@url{http://en.wikipedia.org/wiki/Parsing_expression_grammar}.
+
+The module works by compiling PEGs down to lambda expressions. These
+can either be stored in variables at compile-time by the define macros
+(@code{define-peg-pattern} and @code{define-peg-string-patterns}) or calculated
+explicitly at runtime with the compile functions
+(@code{compile-peg-pattern} and @code{peg-string-compile}).
+
+They can then be used for either parsing (@code{match-pattern}) or searching
+(@code{search-for-pattern}). For convenience, @code{search-for-pattern}
+also takes pattern literals in case you want to inline a simple search
+(people often use regular expressions this way).
+
+The rest of this documentation consists of a syntax reference, an API
+reference, and a tutorial.
+
+@menu
+* PEG Syntax Reference::
+* PEG API Reference::
+* PEG Tutorial::
+* PEG Internals::
+@end menu
+
+@node PEG Syntax Reference
+@subsection PEG Syntax Reference
+
+@subsubheading Normal PEG Syntax:
+
+@deftp {PEG Pattern} sequence a b
+Parses @var{a}. If this succeeds, continues to parse @var{b} from the
+end of the text parsed as @var{a}. Succeeds if both @var{a} and
+@var{b} succeed.
+
+@code{"a b"}
+
+@code{(and a b)}
+@end deftp
+
+@deftp {PEG Pattern} {ordered choice} a b
+Parses @var{a}. If this fails, backtracks and parses @var{b}.
+Succeeds if either @var{a} or @var{b} succeeds.
+
+@code{"a/b"}
+
+@code{(or a b)}
+@end deftp
+
+@deftp {PEG Pattern} {zero or more} a
+Parses @var{a} as many times in a row as it can, starting each @var{a}
+at the end of the text parsed by the previous @var{a}. Always
+succeeds.
+
+@code{"a*"}
+
+@code{(* a)}
+@end deftp
+
+@deftp {PEG Pattern} {one or more} a
+Parses @var{a} as many times in a row as it can, starting each @var{a}
+at the end of the text parsed by the previous @var{a}. Succeeds if at
+least one @var{a} was parsed.
+
+@code{"a+"}
+
+@code{(+ a)}
+@end deftp
+
+@deftp {PEG Pattern} optional a
+Tries to parse @var{a}. Succeeds if @var{a} succeeds.
+
+@code{"a?"}
+
+@code{(? a)}
+@end deftp
+
+@deftp {PEG Pattern} {followed by} a
+Makes sure it is possible to parse @var{a}, but does not actually parse
+it. Succeeds if @var{a} would succeed.
+
+@code{"&a"}
+
+@code{(followed-by a)}
+@end deftp
+
+@deftp {PEG Pattern} {not followed by} a
+Makes sure it is impossible to parse @var{a}, but does not actually
+parse it. Succeeds if @var{a} would fail.
+
+@code{"!a"}
+
+@code{(not-followed-by a)}
+@end deftp
+
+@deftp {PEG Pattern} {string literal} ``abc''
+Parses the string @var{"abc"}. Succeeds if that parsing succeeds.
+
+@code{"'abc'"}
+
+@code{"abc"}
+@end deftp
+
+@deftp {PEG Pattern} {any character}
+Parses any single character. Succeeds unless there is no more text to
+be parsed.
+
+@code{"."}
+
+@code{peg-any}
+@end deftp
+
+@deftp {PEG Pattern} {character class} a b
+Alternative syntax for ``Ordered Choice @var{a} @var{b}'' if @var{a} and
+@var{b} are characters.
+
+@code{"[ab]"}
+
+@code{(or "a" "b")}
+@end deftp
+
+@deftp {PEG Pattern} {range of characters} a z
+Parses any character falling between @var{a} and @var{z}.
+
+@code{"[a-z]"}
+
+@code{(range #\a #\z)}
+@end deftp
+
+Example:
+
+@example
+"(a !b / c &d*) 'e'+"
+@end example
+
+Would be:
+
+@lisp
+(and
+ (or
+ (and a (not-followed-by b))
+ (and c (followed-by (* d))))
+ (+ "e"))
+@end lisp
+
+@subsubheading Extended Syntax
+
+There is some extra syntax for S-expressions.
+
+@deftp {PEG Pattern} ignore a
+Ignore the text matching @var{a}
+@end deftp
+
+@deftp {PEG Pattern} capture a
+Capture the text matching @var{a}.
+@end deftp
+
+@deftp {PEG Pattern} peg a
+Embed the PEG pattern @var{a} using string syntax.
+@end deftp
+
+Example:
+
+@example
+"!a / 'b'"
+@end example
+
+Is equivalent to
+
+@lisp
+(or (peg "!a") "b")
+@end lisp
+
+and
+
+@lisp
+(or (not-followed-by a) "b")
+@end lisp
+
+@node PEG API Reference
+@subsection PEG API Reference
+
+@subsubheading Define Macros
+
+The most straightforward way to define a PEG is by using one of the
+define macros (both of these macroexpand into @code{define}
+expressions). These macros bind parsing functions to variables. These
+parsing functions may be invoked by @code{match-pattern} or
+@code{search-for-pattern}, which return a PEG match record. Raw data can be
+retrieved from this record with the PEG match deconstructor functions.
+More complicated (and perhaps enlightening) examples can be found in the
+tutorial.
+
+@deffn {Scheme Macro} define-peg-string-patterns peg-string
+Defines all the nonterminals in the PEG @var{peg-string}. More
+precisely, @code{define-peg-string-patterns} takes a superset of PEGs. A normal PEG
+has a @code{<-} between the nonterminal and the pattern.
+@code{define-peg-string-patterns} uses this symbol to determine what information it
+should propagate up the parse tree. The normal @code{<-} propagates the
+matched text up the parse tree, @code{<--} propagates the matched text
+up the parse tree tagged with the name of the nonterminal, and @code{<}
+discards that matched text and propagates nothing up the parse tree.
+Also, nonterminals may consist of any alphanumeric character or a ``-''
+character (in normal PEGs nonterminals can only be alphabetic).
+
+For example, if we:
+@lisp
+(define-peg-string-patterns
+ "as <- 'a'+
+bs <- 'b'+
+as-or-bs <- as/bs")
+(define-peg-string-patterns
+ "as-tag <-- 'a'+
+bs-tag <-- 'b'+
+as-or-bs-tag <-- as-tag/bs-tag")
+@end lisp
+Then:
+@lisp
+(match-pattern as-or-bs "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+(match-pattern as-or-bs-tag "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: (as-or-bs-tag (as-tag aa))>
+@end lisp
+
+Note that in doing this, we have bound 6 variables at the toplevel
+(@var{as}, @var{bs}, @var{as-or-bs}, @var{as-tag}, @var{bs-tag}, and
+@var{as-or-bs-tag}).
+@end deffn
+
+@deffn {Scheme Macro} define-peg-pattern name capture-type peg-sexp
+Defines a single nonterminal @var{name}. @var{capture-type} determines
+how much information is passed up the parse tree. @var{peg-sexp} is a
+PEG in S-expression form.
+
+Possible values for capture-type:
+
+@table @code
+@item all
+passes the matched text up the parse tree tagged with the name of the
+nonterminal.
+@item body
+passes the matched text up the parse tree.
+@item none
+passes nothing up the parse tree.
+@end table
+
+For Example, if we:
+@lisp
+(define-peg-pattern as body (+ "a"))
+(define-peg-pattern bs body (+ "b"))
+(define-peg-pattern as-or-bs body (or as bs))
+(define-peg-pattern as-tag all (+ "a"))
+(define-peg-pattern bs-tag all (+ "b"))
+(define-peg-pattern as-or-bs-tag all (or as-tag bs-tag))
+@end lisp
+Then:
+@lisp
+(match-pattern as-or-bs "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+(match-pattern as-or-bs-tag "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: (as-or-bs-tag (as-tag aa))>
+@end lisp
+
+Note that in doing this, we have bound 6 variables at the toplevel
+(@var{as}, @var{bs}, @var{as-or-bs}, @var{as-tag}, @var{bs-tag}, and
+@var{as-or-bs-tag}).
+@end deffn
+
+@subsubheading Compile Functions
+It is sometimes useful to be able to compile anonymous PEG patterns at
+runtime. These functions let you do that using either syntax.
+
+@deffn {Scheme Procedure} peg-string-compile peg-string capture-type
+Compiles the PEG pattern in @var{peg-string} propagating according to
+@var{capture-type} (capture-type can be any of the values from
+@code{define-peg-pattern}).
+@end deffn
+
+
+@deffn {Scheme Procedure} compile-peg-pattern peg-sexp capture-type
+Compiles the PEG pattern in @var{peg-sexp} propagating according to
+@var{capture-type} (capture-type can be any of the values from
+@code{define-peg-pattern}).
+@end deffn
+
+The functions return syntax objects, which can be useful if you want to
+use them in macros. If all you want is to define a new nonterminal, you
+can do the following:
+
+@lisp
+(define exp '(+ "a"))
+(define as (compile (compile-peg-pattern exp 'body)))
+@end lisp
+
+You can use this nonterminal with all of the regular PEG functions:
+
+@lisp
+(match-pattern as "aaaaa") @result{}
+#<peg start: 0 end: 5 string: bbbbb tree: bbbbb>
+@end lisp
+
+@subsubheading Parsing & Matching Functions
+
+For our purposes, ``parsing'' means parsing a string into a tree
+starting from the first character, while ``matching'' means searching
+through the string for a substring. In practice, the only difference
+between the two functions is that @code{match-pattern} gives up if it can't
+find a valid substring starting at index 0 and @code{search-for-pattern} keeps
+looking. They are both equally capable of ``parsing'' and ``matching''
+given those constraints.
+
+@deffn {Scheme Procedure} match-pattern nonterm string
+Parses @var{string} using the PEG stored in @var{nonterm}. If no match
+was found, @code{match-pattern} returns false. If a match was found, a PEG
+match record is returned.
+
+The @code{capture-type} argument to @code{define-peg-pattern} allows you to
+choose what information to hold on to while parsing. The options are:
+
+@table @code
+@item all
+tag the matched text with the nonterminal
+@item body
+just the matched text
+@item none
+nothing
+@end table
+
+@lisp
+(define-peg-pattern as all (+ "a"))
+(match-pattern as "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: (as aa)>
+
+(define-peg-pattern as body (+ "a"))
+(match-pattern as "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+
+(define-peg-pattern as none (+ "a"))
+(match-pattern as "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: ()>
+
+(define-peg-pattern bs body (+ "b"))
+(match-pattern bs "aabbcc") @result{}
+#f
+@end lisp
+@end deffn
+
+@deffn {Scheme Macro} search-for-pattern nonterm-or-peg string
+Searches through @var{string} looking for a matching subexpression.
+@var{nonterm-or-peg} can either be a nonterminal or a literal PEG
+pattern. When a literal PEG pattern is provided, @code{search-for-pattern} works
+very similarly to the regular expression searches many hackers are used
+to. If no match was found, @code{search-for-pattern} returns false. If a match
+was found, a PEG match record is returned.
+
+@lisp
+(define-peg-pattern as body (+ "a"))
+(search-for-pattern as "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+(search-for-pattern (+ "a") "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+(search-for-pattern "'a'+" "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: aa>
+
+(define-peg-pattern as all (+ "a"))
+(search-for-pattern as "aabbcc") @result{}
+#<peg start: 0 end: 2 string: aabbcc tree: (as aa)>
+
+(define-peg-pattern bs body (+ "b"))
+(search-for-pattern bs "aabbcc") @result{}
+#<peg start: 2 end: 4 string: aabbcc tree: bb>
+(search-for-pattern (+ "b") "aabbcc") @result{}
+#<peg start: 2 end: 4 string: aabbcc tree: bb>
+(search-for-pattern "'b'+" "aabbcc") @result{}
+#<peg start: 2 end: 4 string: aabbcc tree: bb>
+
+(define-peg-pattern zs body (+ "z"))
+(search-for-pattern zs "aabbcc") @result{}
+#f
+(search-for-pattern (+ "z") "aabbcc") @result{}
+#f
+(search-for-pattern "'z'+" "aabbcc") @result{}
+#f
+@end lisp
+@end deffn
+
+@subsubheading PEG Match Records
+The @code{match-pattern} and @code{search-for-pattern} functions both return PEG
+match records. Actual information can be extracted from these with the
+following functions.
+
+@deffn {Scheme Procedure} peg:string match-record
+Returns the original string that was parsed in the creation of
+@code{match-record}.
+@end deffn
+
+@deffn {Scheme Procedure} peg:start match-record
+Returns the index of the first parsed character in the original string
+(from @code{peg:string}). If this is the same as @code{peg:end},
+nothing was parsed.
+@end deffn
+
+@deffn {Scheme Procedure} peg:end match-record
+Returns one more than the index of the last parsed character in the
+original string (from @code{peg:string}). If this is the same as
+@code{peg:start}, nothing was parsed.
+@end deffn
+
+@deffn {Scheme Procedure} peg:substring match-record
+Returns the substring parsed by @code{match-record}. This is equivalent to
+@code{(substring (peg:string match-record) (peg:start match-record) (peg:end
+match-record))}.
+@end deffn
+
+@deffn {Scheme Procedure} peg:tree match-record
+Returns the tree parsed by @code{match-record}.
+@end deffn
+
+@deffn {Scheme Procedure} peg-record? match-record
+Returns true if @code{match-record} is a PEG match record, or false
+otherwise.
+@end deffn
+
+Example:
+@lisp
+(define-peg-pattern bs all (peg "'b'+"))
+
+(search-for-pattern bs "aabbcc") @result{}
+#<peg start: 2 end: 4 string: aabbcc tree: (bs bb)>
+
+(let ((pm (search-for-pattern bs "aabbcc")))
+ `((string ,(peg:string pm))
+ (start ,(peg:start pm))
+ (end ,(peg:end pm))
+ (substring ,(peg:substring pm))
+ (tree ,(peg:tree pm))
+ (record? ,(peg-record? pm)))) @result{}
+((string "aabbcc")
+ (start 2)
+ (end 4)
+ (substring "bb")
+ (tree (bs "bb"))
+ (record? #t))
+@end lisp
+
+@subsubheading Miscellaneous
+
+@deffn {Scheme Procedure} context-flatten tst lst
+Takes a predicate @var{tst} and a list @var{lst}. Flattens @var{lst}
+until all elements are either atoms or satisfy @var{tst}. If @var{lst}
+itself satisfies @var{tst}, @code{(list lst)} is returned (this is a
+flat list whose only element satisfies @var{tst}).
+
+@lisp
+(context-flatten (lambda (x) (and (number? (car x)) (= (car x) 1))) '(2 2 (1 1 (2 2)) (2 2 (1 1)))) @result{}
+(2 2 (1 1 (2 2)) 2 2 (1 1))
+(context-flatten (lambda (x) (and (number? (car x)) (= (car x) 1))) '(1 1 (1 1 (2 2)) (2 2 (1 1)))) @result{}
+((1 1 (1 1 (2 2)) (2 2 (1 1))))
+@end lisp
+
+If you're wondering why this is here, take a look at the tutorial.
+@end deffn
+
+@deffn {Scheme Procedure} keyword-flatten terms lst
+A less general form of @code{context-flatten}. Takes a list of terminal
+atoms @code{terms} and flattens @var{lst} until all elements are either
+atoms, or lists which have an atom from @code{terms} as their first
+element.
+@lisp
+(keyword-flatten '(a b) '(c a b (a c) (b c) (c (b a) (c a)))) @result{}
+(c a b (a c) (b c) c (b a) c a)
+@end lisp
+
+If you're wondering why this is here, take a look at the tutorial.
+@end deffn
+
+@node PEG Tutorial
+@subsection PEG Tutorial
+
+@subsubheading Parsing /etc/passwd
+This example will show how to parse /etc/passwd using PEGs.
+
+First we define an example /etc/passwd file:
+
+@lisp
+(define *etc-passwd*
+ "root:x:0:0:root:/root:/bin/bash
+daemon:x:1:1:daemon:/usr/sbin:/bin/sh
+bin:x:2:2:bin:/bin:/bin/sh
+sys:x:3:3:sys:/dev:/bin/sh
+nobody:x:65534:65534:nobody:/nonexistent:/bin/sh
+messagebus:x:103:107::/var/run/dbus:/bin/false
+")
+@end lisp
+
+As a first pass at this, we might want to have all the entries in
+/etc/passwd in a list.
+
+Doing this with string-based PEG syntax would look like this:
+@lisp
+(define-peg-string-patterns
+ "passwd <- entry* !.
+entry <-- (! NL .)* NL*
+NL < '\n'")
+@end lisp
+
+A @code{passwd} file is 0 or more entries (@code{entry*}) until the end
+of the file (@code{!.} (@code{.} is any character, so @code{!.} means
+``not anything'')). We want to capture the data in the nonterminal
+@code{passwd}, but not tag it with the name, so we use @code{<-}.
+
+An entry is a series of 0 or more characters that aren't newlines
+(@code{(! NL .)*}) followed by 0 or more newlines (@code{NL*}). We want
+to tag all the entries with @code{entry}, so we use @code{<--}.
+
+A newline is just a literal newline (@code{'\n'}). We don't want a
+bunch of newlines cluttering up the output, so we use @code{<} to throw
+away the captured data.
+
+Here is the same PEG defined using S-expressions:
+@lisp
+(define-peg-pattern passwd body (and (* entry) (not-followed-by peg-any)))
+(define-peg-pattern entry all (and (* (and (not-followed-by NL) peg-any))
+ (* NL)))
+(define-peg-pattern NL none "\n")
+@end lisp
+
+Obviously this is much more verbose. On the other hand, it's more
+explicit, and thus easier to build automatically. However, there are
+some tricks that make S-expressions easier to use in some cases. One is
+the @code{ignore} keyword; the string syntax has no way to say ``throw
+away this text'' except breaking it out into a separate nonterminal.
+For instance, to throw away the newlines we had to define @code{NL}. In
+the S-expression syntax, we could have simply written @code{(ignore
+"\n")}. Also, for the cases where string syntax is really much cleaner,
+the @code{peg} keyword can be used to embed string syntax in
+S-expression syntax. For instance, we could have written:
+
+@lisp
+(define-peg-pattern passwd body (peg "entry* !."))
+@end lisp
+
+However we define it, parsing @code{*etc-passwd*} with the @code{passwd}
+nonterminal yields the same results:
+
+@lisp
+(peg:tree (match-pattern passwd *etc-passwd*)) @result{}
+((entry "root:x:0:0:root:/root:/bin/bash")
+ (entry "daemon:x:1:1:daemon:/usr/sbin:/bin/sh")
+ (entry "bin:x:2:2:bin:/bin:/bin/sh")
+ (entry "sys:x:3:3:sys:/dev:/bin/sh")
+ (entry "nobody:x:65534:65534:nobody:/nonexistent:/bin/sh")
+ (entry "messagebus:x:103:107::/var/run/dbus:/bin/false"))
+@end lisp
+
+However, here is something to be wary of:
+
+@lisp
+(peg:tree (match-pattern passwd "one entry")) @result{}
+(entry "one entry")
+@end lisp
+
+By default, the parse trees generated by PEGs are compressed as much as
+possible without losing information. It may not look like this is what
+you want at first, but uncompressed parse trees are an enormous headache
+(there's no easy way to predict how deep particular lists will nest,
+there are empty lists littered everywhere, etc. etc.). One side-effect
+of this, however, is that sometimes the compressor is too aggressive.
+No information is discarded when @code{((entry "one entry"))} is
+compressed to @code{(entry "one entry")}, but in this particular case it
+probably isn't what we want.
+
+There are two functions for easily dealing with this:
+@code{keyword-flatten} and @code{context-flatten}. The
+@code{keyword-flatten} function takes a list of keywords and a list to
+flatten, then tries to coerce the list such that the first element of
+all sublists is one of the keywords. The @code{context-flatten}
+function is similar, but instead of a list of keywords it takes a
+predicate that should indicate whether a given sublist is good enough
+(refer to the API reference for more details).
+
+What we want here is @code{keyword-flatten}.
+@lisp
+(keyword-flatten '(entry) (peg:tree (match-pattern passwd *etc-passwd*))) @result{}
+((entry "root:x:0:0:root:/root:/bin/bash")
+ (entry "daemon:x:1:1:daemon:/usr/sbin:/bin/sh")
+ (entry "bin:x:2:2:bin:/bin:/bin/sh")
+ (entry "sys:x:3:3:sys:/dev:/bin/sh")
+ (entry "nobody:x:65534:65534:nobody:/nonexistent:/bin/sh")
+ (entry "messagebus:x:103:107::/var/run/dbus:/bin/false"))
+(keyword-flatten '(entry) (peg:tree (match-pattern passwd "one entry"))) @result{}
+((entry "one entry"))
+@end lisp
+
+Of course, this is a somewhat contrived example. In practice we would
+probably just tag the @code{passwd} nonterminal to remove the ambiguity
+(using either the @code{all} keyword for S-expressions or the @code{<--}
+symbol for strings)..
+
+@lisp
+(define-peg-pattern tag-passwd all (peg "entry* !."))
+(peg:tree (match-pattern tag-passwd *etc-passwd*)) @result{}
+(tag-passwd
+ (entry "root:x:0:0:root:/root:/bin/bash")
+ (entry "daemon:x:1:1:daemon:/usr/sbin:/bin/sh")
+ (entry "bin:x:2:2:bin:/bin:/bin/sh")
+ (entry "sys:x:3:3:sys:/dev:/bin/sh")
+ (entry "nobody:x:65534:65534:nobody:/nonexistent:/bin/sh")
+ (entry "messagebus:x:103:107::/var/run/dbus:/bin/false"))
+(peg:tree (match-pattern tag-passwd "one entry"))
+(tag-passwd
+ (entry "one entry"))
+@end lisp
+
+If you're ever uncertain about the potential results of parsing
+something, remember the two absolute rules:
+@enumerate
+@item
+No parsing information will ever be discarded.
+@item
+There will never be any lists with fewer than 2 elements.
+@end enumerate
+
+For the purposes of (1), "parsing information" means things tagged with
+the @code{any} keyword or the @code{<--} symbol. Plain strings will be
+concatenated.
+
+Let's extend this example a bit more and actually pull some useful
+information out of the passwd file:
+
+@lisp
+(define-peg-string-patterns
+ "passwd <-- entry* !.
+entry <-- login C pass C uid C gid C nameORcomment C homedir C shell NL*
+login <-- text
+pass <-- text
+uid <-- [0-9]*
+gid <-- [0-9]*
+nameORcomment <-- text
+homedir <-- path
+shell <-- path
+path <-- (SLASH pathELEMENT)*
+pathELEMENT <-- (!NL !C !'/' .)*
+text <- (!NL !C .)*
+C < ':'
+NL < '\n'
+SLASH < '/'")
+@end lisp
+
+This produces rather pretty parse trees:
+@lisp
+(passwd
+ (entry (login "root")
+ (pass "x")
+ (uid "0")
+ (gid "0")
+ (nameORcomment "root")
+ (homedir (path (pathELEMENT "root")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "bash"))))
+ (entry (login "daemon")
+ (pass "x")
+ (uid "1")
+ (gid "1")
+ (nameORcomment "daemon")
+ (homedir
+ (path (pathELEMENT "usr") (pathELEMENT "sbin")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "sh"))))
+ (entry (login "bin")
+ (pass "x")
+ (uid "2")
+ (gid "2")
+ (nameORcomment "bin")
+ (homedir (path (pathELEMENT "bin")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "sh"))))
+ (entry (login "sys")
+ (pass "x")
+ (uid "3")
+ (gid "3")
+ (nameORcomment "sys")
+ (homedir (path (pathELEMENT "dev")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "sh"))))
+ (entry (login "nobody")
+ (pass "x")
+ (uid "65534")
+ (gid "65534")
+ (nameORcomment "nobody")
+ (homedir (path (pathELEMENT "nonexistent")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "sh"))))
+ (entry (login "messagebus")
+ (pass "x")
+ (uid "103")
+ (gid "107")
+ nameORcomment
+ (homedir
+ (path (pathELEMENT "var")
+ (pathELEMENT "run")
+ (pathELEMENT "dbus")))
+ (shell (path (pathELEMENT "bin") (pathELEMENT "false")))))
+@end lisp
+
+Notice that when there's no entry in a field (e.g. @code{nameORcomment}
+for messagebus) the symbol is inserted. This is the ``don't throw away
+any information'' rule---we succesfully matched a @code{nameORcomment}
+of 0 characters (since we used @code{*} when defining it). This is
+usually what you want, because it allows you to e.g. use @code{list-ref}
+to pull out elements (since they all have known offsets).
+
+If you'd prefer not to have symbols for empty matches, you can replace
+the @code{*} with a @code{+} and add a @code{?} after the
+@code{nameORcomment} in @code{entry}. Then it will try to parse 1 or
+more characters, fail (inserting nothing into the parse tree), but
+continue because it didn't have to match the nameORcomment to continue.
+
+
+@subsubheading Embedding Arithmetic Expressions
+
+We can parse simple mathematical expressions with the following PEG:
+
+@lisp
+(define-peg-string-patterns
+ "expr <- sum
+sum <-- (product ('+' / '-') sum) / product
+product <-- (value ('*' / '/') product) / value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+@end lisp
+
+Then:
+@lisp
+(peg:tree (match-pattern expr "1+1/2*3+(1+1)/2")) @result{}
+(sum (product (value (number "1")))
+ "+"
+ (sum (product
+ (value (number "1"))
+ "/"
+ (product
+ (value (number "2"))
+ "*"
+ (product (value (number "3")))))
+ "+"
+ (sum (product
+ (value "("
+ (sum (product (value (number "1")))
+ "+"
+ (sum (product (value (number "1")))))
+ ")")
+ "/"
+ (product (value (number "2")))))))
+@end lisp
+
+There is very little wasted effort in this PEG. The @code{number}
+nonterminal has to be tagged because otherwise the numbers might run
+together with the arithmetic expressions during the string concatenation
+stage of parse-tree compression (the parser will see ``1'' followed by
+``/'' and decide to call it ``1/''). When in doubt, tag.
+
+It is very easy to turn these parse trees into lisp expressions:
+
+@lisp
+(define (parse-sum sum left . rest)
+ (if (null? rest)
+ (apply parse-product left)
+ (list (string->symbol (car rest))
+ (apply parse-product left)
+ (apply parse-sum (cadr rest)))))
+
+(define (parse-product product left . rest)
+ (if (null? rest)
+ (apply parse-value left)
+ (list (string->symbol (car rest))
+ (apply parse-value left)
+ (apply parse-product (cadr rest)))))
+
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+
+(define parse-expr parse-sum)
+@end lisp
+
+(Notice all these functions look very similar; for a more complicated
+PEG, it would be worth abstracting.)
+
+Then:
+@lisp
+(apply parse-expr (peg:tree (match-pattern expr "1+1/2*3+(1+1)/2"))) @result{}
+(+ 1 (+ (/ 1 (* 2 3)) (/ (+ 1 1) 2)))
+@end lisp
+
+But wait! The associativity is wrong! Where it says @code{(/ 1 (* 2
+3))}, it should say @code{(* (/ 1 2) 3)}.
+
+It's tempting to try replacing e.g. @code{"sum <-- (product ('+' / '-')
+sum) / product"} with @code{"sum <-- (sum ('+' / '-') product) /
+product"}, but this is a Bad Idea. PEGs don't support left recursion.
+To see why, imagine what the parser will do here. When it tries to
+parse @code{sum}, it first has to try and parse @code{sum}. But to do
+that, it first has to try and parse @code{sum}. This will continue
+until the stack gets blown off.
+
+So how does one parse left-associative binary operators with PEGs?
+Honestly, this is one of their major shortcomings. There's no
+general-purpose way of doing this, but here the repetition operators are
+a good choice:
+
+@lisp
+(use-modules (srfi srfi-1))
+
+(define-peg-string-patterns
+ "expr <- sum
+sum <-- (product ('+' / '-'))* product
+product <-- (value ('*' / '/'))* value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+
+;; take a deep breath...
+(define (make-left-parser next-func)
+ (lambda (sum first . rest) ;; general form, comments below assume
+ ;; that we're dealing with a sum expression
+ (if (null? rest) ;; form (sum (product ...))
+ (apply next-func first)
+ (if (string? (cadr first));; form (sum ((product ...) "+") (product ...))
+ (list (string->symbol (cadr first))
+ (apply next-func (car first))
+ (apply next-func (car rest)))
+ ;; form (sum (((product ...) "+") ((product ...) "+")) (product ...))
+ (car
+ (reduce ;; walk through the list and build a left-associative tree
+ (lambda (l r)
+ (list (list (cadr r) (car r) (apply next-func (car l)))
+ (string->symbol (cadr l))))
+ 'ignore
+ (append ;; make a list of all the products
+ ;; the first one should be pre-parsed
+ (list (list (apply next-func (caar first))
+ (string->symbol (cadar first))))
+ (cdr first)
+ ;; the last one has to be added in
+ (list (append rest '("done"))))))))))
+
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+(define parse-product (make-left-parser parse-value))
+(define parse-sum (make-left-parser parse-product))
+(define parse-expr parse-sum)
+@end lisp
+
+Then:
+@lisp
+(apply parse-expr (peg:tree (match-pattern expr "1+1/2*3+(1+1)/2"))) @result{}
+(+ (+ 1 (* (/ 1 2) 3)) (/ (+ 1 1) 2))
+@end lisp
+
+As you can see, this is much uglier (it could be made prettier by using
+@code{context-flatten}, but the way it's written above makes it clear
+how we deal with the three ways the zero-or-more @code{*} expression can
+parse). Fortunately, most of the time we can get away with only using
+right-associativity.
+
+@subsubheading Simplified Functions
+
+For a more tantalizing example, consider the following grammar that
+parses (highly) simplified C functions:
+
+@lisp
+(define-peg-string-patterns
+ "cfunc <-- cSP ctype cSP cname cSP cargs cLB cSP cbody cRB
+ctype <-- cidentifier
+cname <-- cidentifier
+cargs <-- cLP (! (cSP cRP) carg cSP (cCOMMA / cRP) cSP)* cSP
+carg <-- cSP ctype cSP cname
+cbody <-- cstatement *
+cidentifier <- [a-zA-z][a-zA-Z0-9_]*
+cstatement <-- (!';'.)*cSC cSP
+cSC < ';'
+cCOMMA < ','
+cLP < '('
+cRP < ')'
+cLB < '@{'
+cRB < '@}'
+cSP < [ \t\n]*")
+@end lisp
+
+Then:
+@lisp
+(match-pattern cfunc "int square(int a) @{ return a*a;@}") @result{}
+(32
+ (cfunc (ctype "int")
+ (cname "square")
+ (cargs (carg (ctype "int") (cname "a")))
+ (cbody (cstatement "return a*a"))))
+@end lisp
+
+And:
+@lisp
+(match-pattern cfunc "int mod(int a, int b) @{ int c = a/b;return a-b*c; @}") @result{}
+(52
+ (cfunc (ctype "int")
+ (cname "mod")
+ (cargs (carg (ctype "int") (cname "a"))
+ (carg (ctype "int") (cname "b")))
+ (cbody (cstatement "int c = a/b")
+ (cstatement "return a- b*c"))))
+@end lisp
+
+By wrapping all the @code{carg} nonterminals in a @code{cargs}
+nonterminal, we were able to remove any ambiguity in the parsing
+structure and avoid having to call @code{context-flatten} on the output
+of @code{match-pattern}. We used the same trick with the @code{cstatement}
+nonterminals, wrapping them in a @code{cbody} nonterminal.
+
+The whitespace nonterminal @code{cSP} used here is a (very) useful
+instantiation of a common pattern for matching syntactically irrelevant
+information. Since it's tagged with @code{<} and ends with @code{*} it
+won't clutter up the parse trees (all the empty lists will be discarded
+during the compression step) and it will never cause parsing to fail.
+
+@node PEG Internals
+@subsection PEG Internals
+
+A PEG parser takes a string as input and attempts to parse it as a given
+nonterminal. The key idea of the PEG implementation is that every
+nonterminal is just a function that takes a string as an argument and
+attempts to parse that string as its nonterminal. The functions always
+start from the beginning, but a parse is considered successful if there
+is material left over at the end.
+
+This makes it easy to model different PEG parsing operations. For
+instance, consider the PEG grammar @code{"ab"}, which could also be
+written @code{(and "a" "b")}. It matches the string ``ab''. Here's how
+that might be implemented in the PEG style:
+
+@lisp
+(define (match-and-a-b str)
+ (match-a str)
+ (match-b str))
+@end lisp
+
+As you can see, the use of functions provides an easy way to model
+sequencing. In a similar way, one could model @code{(or a b)} with
+something like the following:
+
+@lisp
+(define (match-or-a-b str)
+ (or (match-a str) (match-b str)))
+@end lisp
+
+Here the semantics of a PEG @code{or} expression map naturally onto
+Scheme's @code{or} operator. This function will attempt to run
+@code{(match-a str)}, and return its result if it succeeds. Otherwise it
+will run @code{(match-b str)}.
+
+Of course, the code above wouldn't quite work. We need some way for the
+parsing functions to communicate. The actual interface used is below.
+
+@subsubheading Parsing Function Interface
+
+A parsing function takes three arguments - a string, the length of that
+string, and the position in that string it should start parsing at. In
+effect, the parsing functions pass around substrings in pieces - the
+first argument is a buffer of characters, and the second two give a
+range within that buffer that the parsing function should look at.
+
+Parsing functions return either #f, if they failed to match their
+nonterminal, or a list whose first element must be an integer
+representing the final position in the string they matched and whose cdr
+can be any other data the function wishes to return, or '() if it
+doesn't have any more data.
+
+The one caveat is that if the extra data it returns is a list, any
+adjacent strings in that list will be appended by @code{match-pattern}. For
+instance, if a parsing function returns @code{(13 ("a" "b" "c"))},
+@code{match-pattern} will take @code{(13 ("abc"))} as its value.
+
+For example, here is a function to match ``ab'' using the actual
+interface.
+
+@lisp
+(define (match-a-b str len pos)
+ (and (<= (+ pos 2) len)
+ (string= str "ab" pos (+ pos 2))
+ (list (+ pos 2) '()))) ; we return no extra information
+@end lisp
+
+The above function can be used to match a string by running
+@code{(match-pattern match-a-b "ab")}.
+
+@subsubheading Code Generators and Extensible Syntax
+
+PEG expressions, such as those in a @code{define-peg-pattern} form, are
+interpreted internally in two steps.
+
+First, any string PEG is expanded into an s-expression PEG by the code
+in the @code{(ice-9 peg string-peg)} module.
+
+Then, then s-expression PEG that results is compiled into a parsing
+function by the @code{(ice-9 peg codegen)} module. In particular, the
+function @code{compile-peg-pattern} is called on the s-expression. It then
+decides what to do based on the form it is passed.
+
+The PEG syntax can be expanded by providing @code{compile-peg-pattern} more
+options for what to do with its forms. The extended syntax will be
+associated with a symbol, for instance @code{my-parsing-form}, and will
+be called on all PEG expressions of the form
+@lisp
+(my-parsing-form ...)
+@end lisp
+
+The parsing function should take two arguments. The first will be a
+syntax object containing a list with all of the arguments to the form
+(but not the form's name), and the second will be the
+@code{capture-type} argument that is passed to @code{define-peg-pattern}.
+
+New functions can be registered by calling @code{(add-peg-compiler!
+symbol function)}, where @code{symbol} is the symbol that will indicate
+a form of this type and @code{function} is the code generating function
+described above. The function @code{add-peg-compiler!} is exported from
+the @code{(ice-9 peg codegen)} module.
otherwise.
@end deffn
-@deffn {Scheme Procedure} program-objcode program
-@deffnx {C Function} scm_program_objcode (program)
-Returns the object code associated with this program. @xref{Bytecode
-and Objcode}, for more information.
+@deffn {Scheme Procedure} program-code program
+@deffnx {C Function} scm_program_code (program)
+Returns the address of the program's entry, as an integer. This address
+is mostly useful to procedures in @code{(system vm debug)}.
@end deffn
-@deffn {Scheme Procedure} program-objects program
-@deffnx {C Function} scm_program_objects (program)
-Returns the ``object table'' associated with this program, as a
-vector. @xref{VM Programs}, for more information.
+@deffn {Scheme Procedure} program-num-free-variable program
+@deffnx {C Function} scm_program_num_free_variables (program)
+Return the number of free variables captured by this program.
@end deffn
-@deffn {Scheme Procedure} program-module program
-@deffnx {C Function} scm_program_module (program)
-Returns the module that was current when this program was created. Can
-return @code{#f} if the compiler could determine that this information
-was unnecessary.
-@end deffn
-
-@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.
+@deffn {Scheme Procedure} program-free-variable-ref program n
+@deffnx {C Function} scm_program_free_variable-ref (program, n)
+@deffnx {Scheme Procedure} program-free-variable-set! program n val
+@deffnx {C Function} scm_program_free_variable_set_x (program, n, val)
+Accessors for a program's 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-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{arities} . @var{properties})}. The format
-of each of these elements is discussed below.
-@end deffn
+@c FIXME
@deffn {Scheme Procedure} program-bindings program
@deffnx {Scheme Procedure} make-binding name boxed? index start end
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2008, 2009, 2010, 2013
+@c Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Compiling to the Virtual Machine
@section Compiling to the Virtual Machine
-Compilers have a mystique about them that is attractive and
-off-putting at the same time. They are attractive because they are
-magical -- they transform inert text into live results, like throwing
-the switch on Frankenstein's monster. However, this magic is perceived
-by many to be impenetrable.
-
-This section aims to pay attention to the small man behind the
-curtain.
+Compilers! The word itself inspires excitement and awe, even among
+experienced practitioners. But a compiler is just a program: an
+eminently hackable thing. This section aims to to describe Guile's
+compiler in such a way that interested Scheme hackers can feel
+comfortable reading and extending it.
@xref{Read/Load/Eval/Compile}, if you're lost and you just wanted to
know how to compile your @code{.scm} file.
* Compiler Tower::
* The Scheme Compiler::
* Tree-IL::
-* GLIL::
-* Assembly::
-* Bytecode and Objcode::
+* Continuation-Passing Style::
+* Bytecode::
* Writing New High-Level Languages::
* Extending the Compiler::
@end menu
@node Compiler Tower
@subsection Compiler Tower
-Guile's compiler is quite simple, actually -- its @emph{compilers}, to
-put it more accurately. Guile defines a tower of languages, starting
-at Scheme and progressively simplifying down to languages that
-resemble the VM instruction set (@pxref{Instruction Set}).
+Guile's compiler is quite simple -- its @emph{compilers}, to put it more
+accurately. Guile defines a tower of languages, starting at Scheme and
+progressively simplifying down to languages that resemble the VM
+instruction set (@pxref{Instruction Set}).
Each language knows how to compile to the next, so each step is simple
-and understandable. Furthermore, this set of languages is not
-hardcoded into Guile, so it is possible for the user to add new
-high-level languages, new passes, or even different compilation
-targets.
+and understandable. Furthermore, this set of languages is not hardcoded
+into Guile, so it is possible for the user to add new high-level
+languages, new passes, or even different compilation targets.
Languages are registered in the module, @code{(system base language)}:
[#:make-default-environment=make-fresh-user-module]
Define a language.
-This syntax defines a @code{#<language>} object, bound to @var{name}
-in the current environment. In addition, the language will be added to
-the global language set. For example, this is the language definition
-for Scheme:
+This syntax defines a @code{<language>} object, bound to @var{name} in
+the current environment. In addition, the language will be added to the
+global language set. For example, this is the language definition for
+Scheme:
@example
(define-language scheme
@end deffn
The interesting thing about having languages defined this way is that
-they present a uniform interface to the read-eval-print loop. This
+they present a uniform interface to the read-eval-print loop. This
allows the user to change the current language of the REPL:
@example
There is a notion of a ``current language'', which is maintained in the
@code{current-language} parameter, defined in the core @code{(guile)}
-module. This language is normally Scheme, and may be rebound by the
-user. The run-time compilation interfaces
+module. This language is normally Scheme, and may be rebound by the
+user. The run-time compilation interfaces
(@pxref{Read/Load/Eval/Compile}) also allow you to choose other source
and target languages.
@itemize
@item Scheme
@item Tree Intermediate Language (Tree-IL)
-@item Guile Lowlevel Intermediate Language (GLIL)
-@item Assembly
+@item Continuation-Passing Style (CPS)
@item Bytecode
-@item Objcode
@end itemize
-Object code may be serialized to disk directly, though it has a cookie
-and version prepended to the front. But when compiling Scheme at run
-time, you want a Scheme value: for example, a compiled procedure. For
-this reason, so as not to break the abstraction, Guile defines a fake
-language at the bottom of the tower:
+As discussed before (@pxref{Object File Format}), bytecode is in ELF
+format, ready to be serialized to disk. But when compiling Scheme at
+run time, you want a Scheme value: for example, a compiled procedure.
+For this reason, so as not to break the abstraction, Guile defines a
+fake language at the bottom of the tower:
@itemize
@item Value
@end itemize
-Compiling to @code{value} loads the object code into a procedure, and
-wakes the sleeping giant.
+Compiling to @code{value} loads the bytecode into a procedure, turning
+cold bytes into warm code.
Perhaps this strangeness can be explained by example:
-@code{compile-file} defaults to compiling to object code, because it
+@code{compile-file} defaults to compiling to bytecode, because it
produces object code that has to live in the barren world outside the
-Guile runtime; but @code{compile} defaults to compiling to
-@code{value}, as its product re-enters the Guile world.
+Guile runtime; but @code{compile} defaults to compiling to @code{value},
+as its product re-enters the Guile world.
+
+@c FIXME: This doesn't work anymore :( Should we add some kind of
+@c special GC pass, or disclaim this kind of code, or what?
Indeed, the process of compilation can circulate through these
different worlds indefinitely, as shown by the following quine:
@node The Scheme Compiler
@subsection The Scheme Compiler
-The job of the Scheme compiler is to expand all macros and all of
-Scheme to its most primitive expressions. The definition of
-``primitive'' is given by the inventory of constructs provided by
-Tree-IL, the target language of the Scheme compiler: procedure
-applications, conditionals, lexical references, etc. This is described
-more fully in the next section.
+The job of the Scheme compiler is to expand all macros and all of Scheme
+to its most primitive expressions. The definition of ``primitive
+expression'' is given by the inventory of constructs provided by
+Tree-IL, the target language of the Scheme compiler: procedure calls,
+conditionals, lexical references, and so on. This is described more
+fully in the next section.
The tricky and amusing thing about the Scheme-to-Tree-IL compiler is
-that it is completely implemented by the macro expander. Since the
+that it is completely implemented by the macro expander. Since the
macro expander has to run over all of the source code already in order
to expand macros, it might as well do the analysis at the same time,
producing Tree-IL expressions directly.
-Because this compiler is actually the macro expander, it is
-extensible. Any macro which the user writes becomes part of the
-compiler.
+Because this compiler is actually the macro expander, it is extensible.
+Any macro which the user writes becomes part of the compiler.
The Scheme-to-Tree-IL expander may be invoked using the generic
@code{compile} procedure:
@lisp
(compile '(+ 1 2) #:from 'scheme #:to 'tree-il)
@result{}
- #<<application> src: #f
- proc: #<<toplevel-ref> src: #f name: +>
- args: (#<<const> src: #f exp: 1>
- #<<const> src: #f exp: 2>)>
-@end lisp
-
-Or, since Tree-IL is so close to Scheme, it is often useful to expand
-Scheme to Tree-IL, then translate back to Scheme. For that reason the
-expander provides two interfaces. The former is equivalent to calling
-@code{(macroexpand '(+ 1 2) 'c)}, where the @code{'c} is for
-``compile''. With @code{'e} (the default), the result is translated
-back to Scheme:
-
-@lisp
-(macroexpand '(+ 1 2))
-@result{} (+ 1 2)
-(macroexpand '(let ((x 10)) (* x x)))
-@result{} (let ((x84 10)) (* x84 x84))
+#<tree-il (call (toplevel +) (const 1) (const 2))>
@end lisp
-The second example shows that as part of its job, the macro expander
-renames lexically-bound variables. The original names are preserved
-when compiling to Tree-IL, but can't be represented in Scheme: a
-lexical binding only has one name. It is for this reason that the
-@emph{native} output of the expander is @emph{not} Scheme. There's too
-much information we would lose if we translated to Scheme directly:
-lexical variable names, source locations, and module hygiene.
-
-Note however that @code{macroexpand} does not have the same signature
-as @code{compile-tree-il}. @code{compile-tree-il} is a small wrapper
-around @code{macroexpand}, to make it conform to the general form of
-compiler procedures in Guile's language tower.
+@code{(compile @var{foo} #:from 'scheme #:to 'tree-il)} is entirely
+equivalent to calling the macro expander as @code{(macroexpand @var{foo}
+'c '(compile load eval))}. @xref{Macro Expansion}.
+@code{compile-tree-il}, the procedure dispatched by @code{compile} to
+@code{'tree-il}, is a small wrapper around @code{macroexpand}, to make
+it conform to the general form of compiler procedures in Guile's
+language tower.
Compiler procedures take three arguments: an expression, an
environment, and a keyword list of options. They return three values:
@example
scheme@@(guile-user)> ,language tree-il
Happy hacking with Tree Intermediate Language! To switch back, type `,L scheme'.
-tree-il@@(guile-user)> (apply (primitive +) (const 32) (const 10))
+tree-il@@(guile-user)> (call (primitive +) (const 32) (const 10))
@result{} 42
@end example
@deftp {Scheme Variable} <void> src
@deftpx {External Representation} (void)
-An empty expression. In practice, equivalent to Scheme's @code{(if #f
+An empty expression. In practice, equivalent to Scheme's @code{(if #f
#f)}.
@end deftp
+
@deftp {Scheme Variable} <const> src exp
@deftpx {External Representation} (const @var{exp})
A constant.
@end deftp
+
@deftp {Scheme Variable} <primitive-ref> src name
@deftpx {External Representation} (primitive @var{name})
-A reference to a ``primitive''. A primitive is a procedure that, when
-compiled, may be open-coded. For example, @code{cons} is usually
+A reference to a ``primitive''. A primitive is a procedure that, when
+compiled, may be open-coded. For example, @code{cons} is usually
recognized as a primitive, so that it compiles down to a single
instruction.
Compilation of Tree-IL usually begins with a pass that resolves some
@code{<module-ref>} and @code{<toplevel-ref>} expressions to
-@code{<primitive-ref>} expressions. The actual compilation pass
-has special cases for applications of certain primitives, like
-@code{apply} or @code{cons}.
+@code{<primitive-ref>} expressions. The actual compilation pass has
+special cases for calls to certain primitives, like @code{apply} or
+@code{cons}.
@end deftp
+
@deftp {Scheme Variable} <lexical-ref> src name gensym
@deftpx {External Representation} (lexical @var{name} @var{gensym})
-A reference to a lexically-bound variable. The @var{name} is the
+A reference to a lexically-bound variable. The @var{name} is the
original name of the variable in the source program. @var{gensym} is a
unique identifier for this variable.
@end deftp
+
@deftp {Scheme Variable} <lexical-set> src name gensym exp
@deftpx {External Representation} (set! (lexical @var{name} @var{gensym}) @var{exp})
Sets a lexically-bound variable.
@end deftp
+
@deftp {Scheme Variable} <module-ref> src mod name public?
@deftpx {External Representation} (@@ @var{mod} @var{name})
@deftpx {External Representation} (@@@@ @var{mod} @var{name})
otherwise it will be looked up among the module's private bindings,
and is serialized with @code{@@@@}.
@end deftp
+
@deftp {Scheme Variable} <module-set> src mod name public? exp
@deftpx {External Representation} (set! (@@ @var{mod} @var{name}) @var{exp})
@deftpx {External Representation} (set! (@@@@ @var{mod} @var{name}) @var{exp})
Sets a variable in a specific module.
@end deftp
+
@deftp {Scheme Variable} <toplevel-ref> src name
@deftpx {External Representation} (toplevel @var{name})
References a variable from the current procedure's module.
@end deftp
+
@deftp {Scheme Variable} <toplevel-set> src name exp
@deftpx {External Representation} (set! (toplevel @var{name}) @var{exp})
Sets a variable in the current procedure's module.
@end deftp
+
@deftp {Scheme Variable} <toplevel-define> src name exp
@deftpx {External Representation} (define (toplevel @var{name}) @var{exp})
Defines a new top-level variable in the current procedure's module.
@end deftp
+
@deftp {Scheme Variable} <conditional> src test then else
@deftpx {External Representation} (if @var{test} @var{then} @var{else})
A conditional. Note that @var{else} is not optional.
@end deftp
-@deftp {Scheme Variable} <application> src proc args
-@deftpx {External Representation} (apply @var{proc} . @var{args})
+
+@deftp {Scheme Variable} <call> src proc args
+@deftpx {External Representation} (call @var{proc} . @var{args})
A procedure call.
@end deftp
-@deftp {Scheme Variable} <sequence> src exps
-@deftpx {External Representation} (begin . @var{exps})
-Like Scheme's @code{begin}.
+
+@deftp {Scheme Variable} <primcall> src name args
+@deftpx {External Representation} (primcall @var{name} . @var{args})
+A call to a primitive. Equivalent to @code{(call (primitive @var{name})
+. @var{args})}. This construct is often more convenient to generate and
+analyze than @code{<call>}.
+
+As part of the compilation process, instances of @code{(call (primitive
+@var{name}) . @var{args})} are transformed into primcalls.
+@end deftp
+
+@deftp {Scheme Variable} <seq> src head tail
+@deftpx {External Representation} (seq @var{head} @var{tail})
+A sequence. The semantics is that @var{head} is evaluated first, and
+any resulting values are ignored. Then @var{tail} is evaluated, in tail
+position.
@end deftp
+
@deftp {Scheme Variable} <lambda> src meta body
@deftpx {External Representation} (lambda @var{meta} @var{body})
-A closure. @var{meta} is an association list of properties for the
-procedure. @var{body} is a single Tree-IL expression of type
-@code{<lambda-case>}. As the @code{<lambda-case>} clause can chain to
+A closure. @var{meta} is an association list of properties for the
+procedure. @var{body} is a single Tree-IL expression of type
+@code{<lambda-case>}. As the @code{<lambda-case>} clause can chain to
an alternate clause, this makes Tree-IL's @code{<lambda>} have the
expressiveness of Scheme's @code{case-lambda}.
@end deftp
+
@deftp {Scheme Variable} <lambda-case> req opt rest kw inits gensyms body alternate
@deftpx {External Representation} @
(lambda-case ((@var{req} @var{opt} @var{rest} @var{kw} @var{inits} @var{gensyms})@
@var{body})@
[@var{alternate}])
-One clause of a @code{case-lambda}. A @code{lambda} expression in
+One clause of a @code{case-lambda}. A @code{lambda} expression in
Scheme is treated as a @code{case-lambda} with one clause.
@var{req} is a list of the procedure's required arguments, as symbols.
@var{kw} is a list of the form, @code{(@var{allow-other-keys?}
(@var{keyword} @var{name} @var{var}) ...)}, where @var{keyword} is the
keyword corresponding to the argument named @var{name}, and whose
-corresponding gensym is @var{var}. @var{inits} are tree-il expressions
-corresponding to all of the optional and keyword arguments, evaluated
-to bind variables whose value is not supplied by the procedure caller.
+corresponding gensym is @var{var}. @var{inits} are tree-il expressions
+corresponding to all of the optional and keyword arguments, evaluated to
+bind variables whose value is not supplied by the procedure caller.
Each @var{init} expression is evaluated in the lexical context of
previously bound variables, from left to right.
first all of the required arguments, then the optional arguments if
any, then the rest argument if any, then all of the keyword arguments.
-@var{body} is the body of the clause. If the procedure is called with
+@var{body} is the body of the clause. If the procedure is called with
an appropriate number of arguments, @var{body} is evaluated in tail
-position. Otherwise, if there is an @var{alternate}, it should be a
+position. Otherwise, if there is an @var{alternate}, it should be a
@code{<lambda-case>} expression, representing the next clause to try.
If there is no @var{alternate}, a wrong-number-of-arguments error is
signaled.
@end deftp
+
@deftp {Scheme Variable} <let> src names gensyms vals exp
@deftpx {External Representation} (let @var{names} @var{gensyms} @var{vals} @var{exp})
-Lexical binding, like Scheme's @code{let}. @var{names} are the
-original binding names, @var{gensyms} are gensyms corresponding to the
+Lexical binding, like Scheme's @code{let}. @var{names} are the original
+binding names, @var{gensyms} are gensyms corresponding to the
@var{names}, and @var{vals} are Tree-IL expressions for the values.
@var{exp} is a single Tree-IL expression.
@end deftp
+
@deftp {Scheme Variable} <letrec> in-order? src names gensyms vals exp
@deftpx {External Representation} (letrec @var{names} @var{gensyms} @var{vals} @var{exp})
@deftpx {External Representation} (letrec* @var{names} @var{gensyms} @var{vals} @var{exp})
A version of @code{<let>} that creates recursive bindings, like
Scheme's @code{letrec}, or @code{letrec*} if @var{in-order?} is true.
@end deftp
-@deftp {Scheme Variable} <dynlet> fluids vals body
-@deftpx {External Representation} (dynlet @var{fluids} @var{vals} @var{body})
-Dynamic binding; the equivalent of Scheme's @code{with-fluids}.
-@var{fluids} should be a list of Tree-IL expressions that will
-evaluate to fluids, and @var{vals} a corresponding list of expressions
-to bind to the fluids during the dynamic extent of the evaluation of
-@var{body}.
-@end deftp
-@deftp {Scheme Variable} <dynref> fluid
-@deftpx {External Representation} (dynref @var{fluid})
-A dynamic variable reference. @var{fluid} should be a Tree-IL
-expression evaluating to a fluid.
-@end deftp
-@deftp {Scheme Variable} <dynset> fluid exp
-@deftpx {External Representation} (dynset @var{fluid} @var{exp})
-A dynamic variable set. @var{fluid}, a Tree-IL expression evaluating
-to a fluid, will be set to the result of evaluating @var{exp}.
-@end deftp
-@deftp {Scheme Variable} <dynwind> winder body unwinder
-@deftpx {External Representation} (dynwind @var{winder} @var{body} @var{unwinder})
-A @code{dynamic-wind}. @var{winder} and @var{unwinder} should both
-evaluate to thunks. Ensure that the winder and the unwinder are called
-before entering and after leaving @var{body}. Note that @var{body} is
-an expression, without a thunk wrapper.
-@end deftp
-@deftp {Scheme Variable} <prompt> tag body handler
-@deftpx {External Representation} (prompt @var{tag} @var{body} @var{handler})
-A dynamic prompt. Instates a prompt named @var{tag}, an expression,
+
+@deftp {Scheme Variable} <prompt> escape-only? tag body handler
+@deftpx {External Representation} (prompt @var{escape-only?} @var{tag} @var{body} @var{handler})
+A dynamic prompt. Instates a prompt named @var{tag}, an expression,
during the dynamic extent of the execution of @var{body}, also an
-expression. If an abort occurs to this prompt, control will be passed
-to @var{handler}, a @code{<lambda-case>} expression with no optional
-or keyword arguments, and no alternate. The first argument to the
-@code{<lambda-case>} will be the captured continuation, and then all
-of the values passed to the abort. @xref{Prompts}, for more
-information.
+expression. If an abort occurs to this prompt, control will be passed
+to @var{handler}, also an expression, which should be a procedure. The
+first argument to the handler procedure will be the captured
+continuation, followed by all of the values passed to the abort. If
+@var{escape-only?} is true, the handler should be a @code{<lambda>} with
+a single @code{<lambda-case>} body expression with no optional or
+keyword arguments, and no alternate, and whose first argument is
+unreferenced. @xref{Prompts}, for more information.
@end deftp
+
@deftp {Scheme Variable} <abort> tag args tail
@deftpx {External Representation} (abort @var{tag} @var{args} @var{tail})
An abort to the nearest prompt with the name @var{tag}, an expression.
@var{args} should be a list of expressions to pass to the prompt's
handler, and @var{tail} should be an expression that will evaluate to
-a list of additional arguments. An abort will save the partial
+a list of additional arguments. An abort will save the partial
continuation, which may later be reinstated, resulting in the
@code{<abort>} expression evaluating to some number of values.
@end deftp
There are two Tree-IL constructs that are not normally produced by
higher-level compilers, but instead are generated during the
source-to-source optimization and analysis passes that the Tree-IL
-compiler does. Users should not generate these expressions directly,
-unless they feel very clever, as the default analysis pass will
-generate them as necessary.
+compiler does. Users should not generate these expressions directly,
+unless they feel very clever, as the default analysis pass will generate
+them as necessary.
@deftp {Scheme Variable} <let-values> src names gensyms exp body
@deftpx {External Representation} (let-values @var{names} @var{gensyms} @var{exp} @var{body})
Like Scheme's @code{receive} -- binds the values returned by
evaluating @code{exp} to the @code{lambda}-like bindings described by
-@var{gensyms}. That is to say, @var{gensyms} may be an improper list.
+@var{gensyms}. That is to say, @var{gensyms} may be an improper list.
-@code{<let-values>} is an optimization of @code{<application>} of the
+@code{<let-values>} is an optimization of a @code{<call>} to the
primitive, @code{call-with-values}.
@end deftp
+
@deftp {Scheme Variable} <fix> src names gensyms vals body
@deftpx {External Representation} (fix @var{names} @var{gensyms} @var{vals} @var{body})
Like @code{<letrec>}, but only for @var{vals} that are unset
@code{fix} is an optimization of @code{letrec} (and @code{let}).
@end deftp
-Tree-IL implements a compiler to GLIL that recursively traverses
-Tree-IL expressions, writing out GLIL expressions into a linear list.
-The compiler also keeps some state as to whether the current
-expression is in tail context, and whether its value will be used in
-future computations. This state allows the compiler not to emit code
-for constant expressions that will not be used (e.g.@: docstrings), and
-to perform tail calls when in tail position.
+Tree-IL is a convenient compilation target from source languages. It
+can be convenient as a medium for optimization, though CPS is usually
+better. The strength of Tree-IL is that it does not fix order of
+evaluation, so it makes some code motion a bit easier.
-Most optimization, such as it currently is, is performed on Tree-IL
-expressions as source-to-source transformations. There will be more
-optimizations added in the future.
+Optimization passes performed on Tree-IL currently include:
-Interested readers are encouraged to read the implementation in
-@code{(language tree-il compile-glil)} for more details.
+@itemize
+@item Open-coding (turning toplevel-refs into primitive-refs,
+and calls to primitives to primcalls)
+@item Partial evaluation (comprising inlining, copy propagation, and
+constant folding)
+@item Common subexpression elimination (CSE)
+@end itemize
+
+In the future, we will move the CSE pass to operate over the lower-level
+CPS language.
+
+@node Continuation-Passing Style
+@subsection Continuation-Passing Style
-@node GLIL
-@subsection GLIL
+@cindex CPS
+Continuation-passing style (CPS) is Guile's principal intermediate
+language, bridging the gap between languages for people and languages
+for machines. CPS gives a name to every part of a program: every
+control point, and every intermediate value. This makes it an excellent
+medium for reasoning about programs, which is the principal job of a
+compiler.
+
+@menu
+* An Introduction to CPS::
+* CPS in Guile::
+* Building CPS::
+* Compiling CPS::
+@end menu
-Guile Lowlevel Intermediate Language (GLIL) is a structured intermediate
-language whose expressions more closely approximate Guile's VM
-instruction set. Its expression types are defined in @code{(language
-glil)}.
+@node An Introduction to CPS
+@subsubsection An Introduction to CPS
-@deftp {Scheme Variable} <glil-program> meta . body
-A unit of code that at run-time will correspond to a compiled
-procedure. @var{meta} should be an alist of properties, as in
-Tree-IL's @code{<lambda>}. @var{body} is an ordered list of GLIL
+Consider the following Scheme expression:
+
+@lisp
+(begin
+ (display "The sum of 32 and 10 is: ")
+ (display 42)
+ (newline))
+@end lisp
+
+Let us identify all of the sub-expressions in this expression,
+annotating them with unique labels:
+
+@lisp
+(begin
+ (display "The sum of 32 and 10 is: ")
+ |k1 k2
+ k0
+ (display 42)
+ |k4 k5
+ k3
+ (newline))
+ |k7
+ k6
+@end lisp
+
+Each of these labels identifies a point in a program. One label may be
+the continuation of another label. For example, the continuation of
+@code{k7} is @code{k6}. This is because after evaluating the value of
+@code{newline}, performed by the expression labelled @code{k7}, we
+continue to apply it in @code{k6}.
+
+Which expression has @code{k0} as its continuation? It is either the
+expression labelled @code{k1} or the expression labelled @code{k2}.
+Scheme does not have a fixed order of evaluation of arguments, though it
+does guarantee that they are evaluated in some order. Unlike general
+Scheme, continuation-passing style makes evaluation order explicit. In
+Guile, this choice is made by the higher-level language compilers.
+
+Let us assume a left-to-right evaluation order. In that case the
+continuation of @code{k1} is @code{k2}, and the continuation of
+@code{k2} is @code{k0}.
+
+With this example established, we are ready to give an example of CPS in
+Scheme:
+
+@smalllisp
+(lambda (ktail)
+ (let ((k1 (lambda ()
+ (let ((k2 (lambda (proc)
+ (let ((k0 (lambda (arg0)
+ (proc k4 arg0))))
+ (k0 "The sum of 32 and 10 is: ")))))
+ (k2 display))))
+ (k4 (lambda _
+ (let ((k5 (lambda (proc)
+ (let ((k3 (lambda (arg0)
+ (proc k7 arg0))))
+ (k3 42)))))
+ (k5 display))))
+ (k7 (lambda _
+ (let ((k6 (lambda (proc)
+ (proc ktail))))
+ (k6 newline)))))
+ (k1))
+@end smalllisp
+
+Holy code explosion, Batman! What's with all the lambdas? Indeed, CPS
+is by nature much more verbose than ``direct-style'' intermediate
+languages like Tree-IL. At the same time, CPS is simpler than full
+Scheme, because it makes things more explicit.
+
+In the original program, the expression labelled @code{k0} is in effect
+context. Any values it returns are ignored. In Scheme, this fact is
+implicit. In CPS, we can see it explicitly by noting that its
+continuation, @code{k4}, takes any number of values and ignores them.
+Compare this to @code{k2}, which takes a single value; in this way we
+can say that @code{k1} is in a ``value'' context. Likewise @code{k6} is
+in tail context with respect to the expression as a whole, because its
+continuation is the tail continuation, @code{ktail}. CPS makes these
+details manifest, and gives them names.
+
+@node CPS in Guile
+@subsubsection CPS in Guile
+
+Guile's CPS language is composed of @dfn{terms}, @dfn{expressions},
+and @dfn{continuations}.
+
+A term can either evaluate an expression and pass the resulting values
+to some continuation, or it can declare local continuations and contain
+a sub-term in the scope of those continuations.
+
+@deftp {CPS Term} $continue k src exp
+Evaluate the expression @var{exp} and pass the resulting values (if any)
+to the continuation labelled @var{k}. The source information associated
+with the expression may be found in @var{src}, which is either an alist
+as in @code{source-properties} or is @code{#f} if there is no associated
+source.
+@end deftp
+
+@deftp {CPS Term} $letk conts body
+Bind @var{conts}, a list of continuations (@code{$cont} instances), in
+the scope of the sub-term @var{body}. The continuations are mutually
+recursive.
+@end deftp
+
+Additionally, the early stages of CPS allow for a set of mutually
+recursive functions to be declared as a term. This @code{$letrec} type
+is like Tree-IL's @code{<fix>}. The contification pass will attempt to
+transform the functions declared in a @code{$letrec} into local
+continuations. Any remaining functions are later lowered to @code{$fun}
expressions.
+
+@deftp {CPS Term} $letrec names syms funs body
+Declare the mutually recursive set of functions denoted by @var{names},
+@var{syms}, and @var{funs} within the sub-term @var{body}. @var{names}
+and @var{syms} are lists of symbols, and @var{funs} is a list of
+@code{$fun} values. @var{syms} are globally unique.
@end deftp
-@deftp {Scheme Variable} <glil-std-prelude> nreq nlocs else-label
-A prologue for a function with no optional, keyword, or rest
-arguments. @var{nreq} is the number of required arguments. @var{nlocs}
-the total number of local variables, including the arguments. If the
-procedure was not given exactly @var{nreq} arguments, control will
-jump to @var{else-label}, if given, or otherwise signal an error.
-@end deftp
-@deftp {Scheme Variable} <glil-opt-prelude> nreq nopt rest nlocs else-label
-A prologue for a function with optional or rest arguments. Like
-@code{<glil-std-prelude>}, with the addition that @var{nopt} is the
-number of optional arguments (possibly zero) and @var{rest} is an
-index of a local variable at which to bind a rest argument, or
-@code{#f} if there is no rest argument.
-@end deftp
-@deftp {Scheme Variable} <glil-kw-prelude> nreq nopt rest kw allow-other-keys? nlocs else-label
-A prologue for a function with keyword arguments. Like
-@code{<glil-opt-prelude>}, with the addition that @var{kw} is a list
-of keyword arguments, and @var{allow-other-keys?} is a flag indicating
-whether to allow unknown keys. @xref{Function Prologue Instructions,
-@code{bind-kwargs}}, for details on the format of @var{kw}.
-@end deftp
-@deftp {Scheme Variable} <glil-bind> . vars
-An advisory expression that notes a liveness extent for a set of
-variables. @var{vars} is a list of @code{(@var{name} @var{type}
-@var{index})}, where @var{type} should be either @code{argument},
-@code{local}, or @code{external}.
-
-@code{<glil-bind>} expressions end up being serialized as part of a
-program's metadata and do not form part of a program's code path.
-@end deftp
-@deftp {Scheme Variable} <glil-mv-bind> vars rest
-A multiple-value binding of the values on the stack to @var{vars}. If
-@var{rest} is true, the last element of @var{vars} will be treated as a
-rest argument.
-
-In addition to pushing a binding annotation on the stack, like
-@code{<glil-bind>}, an expression is emitted at compilation time to
-make sure that there are enough values available to bind. See the
-notes on @code{truncate-values} in @ref{Procedure Call and Return
-Instructions}, for more information.
-@end deftp
-@deftp {Scheme Variable} <glil-unbind>
-Closes the liveness extent of the most recently encountered
-@code{<glil-bind>} or @code{<glil-mv-bind>} expression. As GLIL
-expressions are compiled, a parallel stack of live bindings is
-maintained; this expression pops off the top element from that stack.
-
-Bindings are written into the program's metadata so that debuggers and
-other tools can determine the set of live local variables at a given
-offset within a VM program.
-@end deftp
-@deftp {Scheme Variable} <glil-source> loc
-Records source information for the preceding expression. @var{loc}
-should be an association list of containing @code{line} @code{column},
-and @code{filename} keys, e.g.@: as returned by
-@code{source-properties}.
-@end deftp
-@deftp {Scheme Variable} <glil-void>
-Pushes ``the unspecified value'' on the stack.
-@end deftp
-@deftp {Scheme Variable} <glil-const> obj
-Pushes a constant value onto the stack. @var{obj} must be a number,
-string, symbol, keyword, boolean, character, uniform array, the empty
-list, or a pair or vector of constants.
-@end deftp
-@deftp {Scheme Variable} <glil-lexical> local? boxed? op index
-Accesses a lexically bound variable. If the variable is not
-@var{local?} it is free. All variables may have @code{ref},
-@code{set}, and @code{bound?} as their @var{op}. Boxed variables may
-also have the @var{op}s @code{box}, @code{empty-box}, and @code{fix},
-which correspond in semantics to the VM instructions @code{box},
-@code{empty-box}, and @code{fix-closure}. @xref{Stack Layout}, for
-more information.
-@end deftp
-@deftp {Scheme Variable} <glil-toplevel> op name
-Accesses a toplevel variable. @var{op} may be @code{ref}, @code{set},
-or @code{define}.
-@end deftp
-@deftp {Scheme Variable} <glil-module> op mod name public?
-Accesses a variable within a specific module. See Tree-IL's
-@code{<module-ref>}, for more information.
-@end deftp
-@deftp {Scheme Variable} <glil-label> label
-Creates a new label. @var{label} can be any Scheme value, and should
-be unique.
-@end deftp
-@deftp {Scheme Variable} <glil-branch> inst label
-Branch to a label. @var{label} should be a @code{<ghil-label>}.
-@code{inst} is a branching instruction: @code{br-if}, @code{br}, etc.
-@end deftp
-@deftp {Scheme Variable} <glil-call> inst nargs
-This expression is probably misnamed, as it does not correspond to
-function calls. @code{<glil-call>} invokes the VM instruction named
-@var{inst}, noting that it is called with @var{nargs} stack arguments.
-The arguments should be pushed on the stack already. What happens to
-the stack afterwards depends on the instruction.
-@end deftp
-@deftp {Scheme Variable} <glil-mv-call> nargs ra
-Performs a multiple-value call. @var{ra} is a @code{<glil-label>}
-corresponding to the multiple-value return address for the call. See
-the notes on @code{mv-call} in @ref{Procedure Call and Return
-Instructions}, for more information.
-@end deftp
-@deftp {Scheme Variable} <glil-prompt> label escape-only?
-Push a dynamic prompt into the stack, with a handler at @var{label}.
-@var{escape-only?} is a flag that is propagated to the prompt,
-allowing an abort to avoid capturing a continuation in some cases.
-@xref{Prompts}, for more information.
-@end deftp
-
-Users may enter in GLIL at the REPL as well, though there is a bit
-more bookkeeping to do:
-@example
-scheme@@(guile-user)> ,language glil
-Happy hacking with Guile Lowlevel Intermediate Language (GLIL)!
-To switch back, type `,L scheme'.
-glil@@(guile-user)> (program () (std-prelude 0 0 #f)
- (const 3) (call return 1))
-@result{} 3
-@end example
+Here is an inventory of the kinds of expressions in Guile's CPS
+language. Recall that all expressions are wrapped in a @code{$continue}
+term which specifies their continuation.
-Just as in all of Guile's compilers, an environment is passed to the
-GLIL-to-object code compiler, and one is returned as well, along with
-the object code.
+@deftp {CPS Expression} $void
+Continue with the unspecified value.
+@end deftp
-@node Assembly
-@subsection Assembly
+@deftp {CPS Expression} $const val
+Continue with the constant value @var{val}.
+@end deftp
-Assembly is an S-expression-based, human-readable representation of
-the actual bytecodes that will be emitted for the VM. As such, it is a
-useful intermediate language both for compilation and for
-decompilation.
+@deftp {CPS Expression} $prim name
+Continue with the procedure that implements the primitive operation
+named by @var{name}.
+@end deftp
-Besides the fact that it is not a record-based language, assembly
-differs from GLIL in four main ways:
+@deftp {CPS Expression} $fun src meta free body
+Continue with a procedure. @var{src} identifies the source information
+for the procedure declaration, and @var{meta} is the metadata alist as
+described above in Tree-IL's @code{<lambda>}. @var{free} is a list of
+free variables accessed by the procedure. Early CPS uses an empty list
+for @var{free}; only after closure conversion is it correctly populated.
+Finally, @var{body} is the @code{$kentry} @code{$cont} of the procedure
+entry.
+@end deftp
-@itemize
-@item Labels have been resolved to byte offsets in the program.
-@item Constants inside procedures have either been expressed as inline
-instructions or cached in object arrays.
-@item Procedures with metadata (source location information, liveness
-extents, procedure names, generic properties, etc) have had their
-metadata serialized out to thunks.
-@item All expressions correspond directly to VM instructions -- i.e.,
-there is no @code{<glil-lexical>} which can be a ref or a set.
-@end itemize
+@deftp {CPS Expression} $call proc args
+@deftpx {CPS Expression} $callk label proc args
+Call @var{proc} with the arguments @var{args}, and pass all values to
+the continuation. @var{proc} and the elements of the @var{args} list
+should all be variable names. The continuation identified by the term's
+@var{k} should be a @code{$kreceive} or a @code{$ktail} instance.
+
+@code{$callk} is for the case where the call target is known to be in
+the same compilation unit. @var{label} should be some continuation
+label, though it need not be in scope. In this case the @var{proc} is
+simply an additional argument, since it is not used to determine the
+call target at run-time.
+@end deftp
-Assembly is isomorphic to the bytecode that it compiles to. You can
-compile to bytecode, then decompile back to assembly, and you have the
-same assembly code.
+@deftp {CPS Expression} $primcall name args
+Perform the primitive operation identified by @code{name}, a well-known
+symbol, passing it the arguments @var{args}, and pass all resulting
+values to the continuation. The set of available primitives includes
+all primitives known to Tree-IL and then some more; see the source code
+for details.
+@end deftp
-The general form of assembly instructions is the following:
+@deftp {CPS Expression} $values args
+Pass the values named by the list @var{args} to the continuation.
+@end deftp
-@lisp
-(@var{inst} @var{arg} ...)
-@end lisp
+@deftp {CPS Expression} $prompt escape? tag handler
+Push a prompt on the stack identified by the variable name @var{tag},
+which may be escape-only if @var{escape?} is true, and continue with
+zero values. If the body aborts to this prompt, control will proceed at
+the continuation labelled @var{handler}, which should be a
+@code{$kreceive} continuation. Prompts are later popped by
+@code{pop-prompt} primcalls.
+@end deftp
-The @var{inst} names a VM instruction, and its @var{arg}s will be
-embedded in the instruction stream. The easiest way to see assembly is
-to play around with it at the REPL, as can be seen in this annotated
-example:
+The remaining element of the CPS language in Guile is the continuation.
+In CPS, all continuations have unique labels. Since this aspect is
+common to all continuation types, all continuations are contained in a
+@code{$cont} instance:
-@example
-scheme@@(guile-user)> ,pp (compile '(+ 32 10) #:to 'assembly)
-(load-program
- ((:LCASE16 . 2)) ; Labels, unused in this case.
- 8 ; Length of the thunk that was compiled.
- (load-program ; Metadata thunk.
- ()
- 17
- #f ; No metadata thunk for the metadata thunk.
- (make-eol)
- (make-eol)
- (make-int8 2) ; Liveness extents, source info, and arities,
- (make-int8 8) ; in a format that Guile knows how to parse.
- (make-int8:0)
- (list 0 3)
- (list 0 1)
- (list 0 3)
- (return))
- (assert-nargs-ee/locals 0) ; Prologue.
- (make-int8 32) ; Actual code starts here.
- (make-int8 10)
- (add)
- (return))
-@end example
+@deftp {CPS Continuation Wrapper} $cont k cont
+Declare a continuation labelled @var{k}. All references to the
+continuation will use this label.
+@end deftp
-Of course you can switch the REPL to assembly and enter in assembly
-S-expressions directly, like with other languages, though it is more
-difficult, given that the length fields have to be correct.
+The most common kind of continuation binds some number of values, and
+then evaluates a sub-term. @code{$kargs} is this kind of simple
+@code{lambda}.
-@node Bytecode and Objcode
-@subsection Bytecode and Objcode
+@deftp {CPS Continuation} $kargs names syms body
+Bind the incoming values to the variables @var{syms}, with original
+names @var{names}, and then evaluate the sub-term @var{body}.
+@end deftp
-Finally, the raw bytes. There are actually two different ``languages''
-here, corresponding to two different ways to represent the bytes.
+Variable names (the names in the @var{syms} of a @code{$kargs}) should
+be globally unique, and also disjoint from continuation labels. To bind
+a value to a variable and then evaluate some term, you would continue
+with the value to a @code{$kargs} that declares one variable. The bound
+value would then be available for use within the body of the
+@code{$kargs}.
+
+@deftp {CPS Continuation} $kif kt kf
+Receive one value. If it is true for the purposes of Scheme, branch to
+the continuation labelled @var{kt}, passing no values; otherwise, branch
+to @var{kf}.
+@end deftp
-``Bytecode'' represents code as uniform byte vectors, useful for
-structuring and destructuring code on the Scheme level. Bytecode is
-the next step down from assembly:
+For internal reasons, only certain terms may continue to a @code{$kif}.
+Compiling @code{$kif} avoids allocating space for the test variable, so
+it needs to be preceded by expressions that can test-and-branch without
+temporary values. In practice this condition is true for
+@code{$primcall}s to @code{null?}, @code{=}, and similar primitives that
+have corresponding @code{br-if-@var{foo}} VM operations; see the source
+code for full details. When in doubt, bind the test expression to a
+variable, and continue to the @code{$kif} with a @code{$values}
+expression. The optimizer should elide the @code{$values} if it is not
+needed.
+
+Calls out to other functions need to be wrapped in a @code{$kreceive}
+continuation in order to adapt the returned values to their uses in the
+calling function, if any.
+
+@deftp {CPS Continuation} $kreceive arity k
+Receive values on the stack. Parse them according to @var{arity}, and
+then proceed with the parsed values to the @code{$kargs} continuation
+labelled @var{k}. As a limitation specific to @code{$kreceive},
+@var{arity} may only contain required and rest arguments.
+@end deftp
-@example
-scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode)
-@result{} #vu8(8 0 0 0 25 0 0 0 ; Header.
- 95 0 ; Prologue.
- 10 32 10 10 148 66 17 ; Actual code.
- 0 0 0 0 0 0 0 9 ; Metadata thunk.
- 9 10 2 10 8 11 18 0 3 18 0 1 18 0 3 66)
-@end example
+@code{$arity} is a helper data structure used by @code{$kreceive} and
+also by @code{$kclause}, described below.
-``Objcode'' is bytecode, but mapped directly to a C structure,
-@code{struct scm_objcode}:
+@deftp {CPS Data} $arity req opt rest kw allow-other-keys?
+A data type declaring an arity. @var{req} and @var{opt} are lists of
+source names of required and optional arguments, respectively.
+@var{rest} is either the source name of the rest variable, or @code{#f}
+if this arity does not accept additional values. @var{kw} is a list of
+the form @code{((@var{keyword} @var{name} @var{var}) ...)}, describing
+the keyword arguments. @var{allow-other-keys?} is true if other keyword
+arguments are allowed and false otherwise.
-@example
-struct scm_objcode @{
- scm_t_uint32 len;
- scm_t_uint32 metalen;
- scm_t_uint8 base[0];
-@};
-@end example
+Note that all of these names with the exception of the @var{var}s in the
+@var{kw} list are source names, not unique variable names.
+@end deftp
+
+Additionally, there are three specific kinds of continuations that can
+only be declared at function entries.
+
+@deftp {CPS Continuation} $kentry self tail clauses
+Declare a function entry. @var{self} is a variable bound to the
+procedure being called, and which may be used for self-references.
+@var{tail} declares the @code{$cont} wrapping the @code{$ktail} for this
+function, corresponding to the function's tail continuation.
+@var{clauses} is a list of @code{$kclause} @code{$cont} instances.
+@end deftp
+
+@deftp {CPS Continuation} $ktail
+A tail continuation.
+@end deftp
-As one might imagine, objcode imposes a minimum length on the
-bytecode. Also, the @code{len} and @code{metalen} fields are in native
-endianness, which makes objcode (and bytecode) system-dependent.
-
-Objcode also has a couple of important efficiency hacks. First,
-objcode may be mapped directly from disk, allowing compiled code to be
-loaded quickly, often from the system's disk cache, and shared among
-multiple processes. Secondly, objcode may be embedded in other
-objcode, allowing procedures to have the text of other procedures
-inlined into their bodies, without the need for separate allocation of
-the code. Of course, the objcode object itself does need to be
-allocated.
-
-Procedures related to objcode are defined in the @code{(system vm
-objcode)} module.
-
-@deffn {Scheme Procedure} objcode? obj
-@deffnx {C Function} scm_objcode_p (obj)
-Returns @code{#f} if @var{obj} is object code, @code{#f} otherwise.
+@deftp {CPS Continuation} $kclause arity cont
+A clause of a function with a given arity. Applications of a function
+with a compatible set of actual arguments will continue to @var{cont}, a
+@code{$kargs} @code{$cont} instance representing the clause body.
+@end deftp
+
+
+@node Building CPS
+@subsubsection Building CPS
+
+Unlike Tree-IL, the CPS language is built to be constructed and
+deconstructed with abstract macros instead of via procedural
+constructors or accessors, or instead of S-expression matching.
+
+Deconstruction and matching is handled adequately by the @code{match}
+form from @code{(ice-9 match)}. @xref{Pattern Matching}. Construction
+is handled by a set of mutually recursive builder macros:
+@code{build-cps-term}, @code{build-cps-cont}, and @code{build-cps-exp}.
+
+In the following interface definitions, consider variables containing
+@code{cont} to be recursively build by @code{build-cps-cont}, and
+likewise for @code{term} and @code{exp}. Consider any other name to be
+evaluated as a Scheme expression. Many of these forms recognize
+@code{unquote} in some contexts, to splice in a previously-built value;
+see the specifications below for full details.
+
+@deffn {Scheme Syntax} build-cps-term ,val
+@deffnx {Scheme Syntax} build-cps-term ($letk (cont ...) term)
+@deffnx {Scheme Syntax} build-cps-term ($letrec names syms funs term)
+@deffnx {Scheme Syntax} build-cps-term ($continue k src exp)
+@deffnx {Scheme Syntax} build-cps-exp ,val
+@deffnx {Scheme Syntax} build-cps-exp ($void)
+@deffnx {Scheme Syntax} build-cps-exp ($const val)
+@deffnx {Scheme Syntax} build-cps-exp ($prim name)
+@deffnx {Scheme Syntax} build-cps-exp ($fun src meta free body)
+@deffnx {Scheme Syntax} build-cps-exp ($call proc (arg ...))
+@deffnx {Scheme Syntax} build-cps-exp ($call proc args)
+@deffnx {Scheme Syntax} build-cps-exp ($primcall name (arg ...))
+@deffnx {Scheme Syntax} build-cps-exp ($primcall name args)
+@deffnx {Scheme Syntax} build-cps-exp ($values (arg ...))
+@deffnx {Scheme Syntax} build-cps-exp ($values args)
+@deffnx {Scheme Syntax} build-cps-exp ($prompt escape? tag handler)
+@deffnx {Scheme Syntax} build-cps-cont ,val
+@deffnx {Scheme Syntax} build-cps-cont (k ($kargs (name ...) (sym ...) term))
+@deffnx {Scheme Syntax} build-cps-cont (k ($kargs names syms term))
+@deffnx {Scheme Syntax} build-cps-cont (k ($kif kt kf))
+@deffnx {Scheme Syntax} build-cps-cont (k ($kreceive req rest kargs))
+@deffnx {Scheme Syntax} build-cps-cont (k ($kentry self tail-cont ,clauses))
+@deffnx {Scheme Syntax} build-cps-cont (k ($kentry self tail-cont (cont ...)))
+@deffnx {Scheme Syntax} build-cps-cont (k ($kclause ,arity cont))
+@deffnx {Scheme Syntax} build-cps-cont (k ($kclause (req opt rest kw aok?) cont))
+Construct a CPS term, expression, or continuation.
@end deffn
-@deffn {Scheme Procedure} bytecode->objcode bytecode
-@deffnx {C Function} scm_bytecode_to_objcode (bytecode)
-Makes a bytecode object from @var{bytecode}, which should be a
-bytevector. @xref{Bytevectors}.
+There are a few more miscellaneous interfaces as well.
+
+@deffn {Scheme Procedure} make-arity req opt rest kw allow-other-keywords?
+A procedural constructor for @code{$arity} objects.
@end deffn
-@deffn {Scheme Variable} load-objcode file
-@deffnx {C Function} scm_load_objcode (file)
-Load object code from a file named @var{file}. The file will be mapped
-into memory via @code{mmap}, so this is a very fast operation.
+@deffn {Scheme Syntax} let-gensyms (sym ...) body ...
+Bind @var{sym...} to fresh names, and evaluate @var{body...}.
+@end deffn
-On disk, object code has an sixteen-byte cookie prepended to it, to
-prevent accidental loading of arbitrary garbage.
+@deffn {Scheme Syntax} rewrite-cps-term val (pat term) ...
+@deffnx {Scheme Syntax} rewrite-cps-exp val (pat exp) ...
+@deffnx {Scheme Syntax} rewrite-cps-cont val (pat cont) ...
+Match @var{val} against the series of patterns @var{pat...}, using
+@code{match}. The body of the matching clause should be a template in
+the syntax of @code{build-cps-term}, @code{build-cps-exp}, or
+@code{build-cps-cont}, respectively.
@end deffn
-@deffn {Scheme Variable} write-objcode objcode file
-@deffnx {C Function} scm_write_objcode (objcode)
-Write object code out to a file, prepending the sixteen-byte cookie.
+@node Compiling CPS
+@subsubsection Compiling CPS
+
+Compiling CPS in Guile has three phases: conversion, optimization, and
+code generation.
+
+CPS conversion is the process of taking a higher-level language and
+compiling it to CPS. Source languages can do this directly, or they can
+convert to Tree-IL (which is probably easier) and let Tree-IL convert to
+CPS later. Going through Tree-IL has the advantage of running Tree-IL
+optimization passes, like partial evaluation. Also, the compiler from
+Tree-IL to CPS handles assignment conversion, in which assigned local
+variables (in Tree-IL, locals that are @code{<lexical-set>}) are
+converted to being boxed values on the heap. @xref{Variables and the
+VM}.
+
+After CPS conversion, Guile runs some optimization passes. The major
+optimization performed on CPS is contification, in which functions that
+are always called with the same continuation are incorporated directly
+into a function's body. This opens up space for more optimizations, and
+turns procedure calls into @code{goto}. It can also make loops out of
+recursive function nests.
+
+At the time of this writing (2014), most high-level optimization in
+Guile is done on Tree-IL. We would like to rewrite many of these passes
+to operate on CPS instead, as it is easier to reason about CPS.
+
+The rest of the optimization passes are really cleanups and
+canonicalizations. CPS spans the gap between high-level languages and
+low-level bytecodes, which allows much of the compilation process to be
+expressed as source-to-source transformations. Such is the case for
+closure conversion, in which references to variables that are free in a
+function are converted to closure references, and in which functions are
+converted to closures. There are a few more passes to ensure that the
+only primcalls left in the term are those that have a corresponding
+instruction in the virtual machine, and that their continuations expect
+the right number of values.
+
+Finally, the backend of the CPS compiler emits bytecode for each
+function, one by one. To do so, it determines the set of live variables
+at all points in the function. Using this liveness information, it
+allocates stack slots to each variable, such that a variable can live in
+one slot for the duration of its lifetime, without shuffling. (Of
+course, variables with disjoint lifetimes can share a slot.) Finally
+the backend emits code, typically just one VM instruction, for each
+continuation in the function.
+
+
+@node Bytecode
+@subsection Bytecode
+
+As mentioned before, Guile compiles all code to bytecode, and that
+bytecode is contained in ELF images. @xref{Object File Format}, for
+more on Guile's use of ELF.
+
+To produce a bytecode image, Guile provides an assembler and a linker.
+
+The assembler, defined in the @code{(system vm assembler)} module, has a
+relatively straightforward imperative interface. It provides a
+@code{make-assembler} function to instantiate an assembler and a set of
+@code{emit-@var{inst}} procedures to emit instructions of each kind.
+
+The @code{emit-@var{inst}} procedures are actually generated at
+compile-time from a machine-readable description of the VM. With a few
+exceptions for certain operand types, each operand of an emit procedure
+corresponds to an operand of the corresponding instruction.
+
+Consider @code{vector-length}, from @pxref{Miscellaneous Instructions}.
+It is documented as:
+
+@deftypefn Instruction {} vector-length u12:@var{dst} u12:@var{src}
+@end deftypefn
+
+Therefore the emit procedure has the form:
+
+@deffn {Scheme Procedure} emit-vector-length asm dst src
@end deffn
-@deffn {Scheme Variable} objcode->bytecode objcode
-@deffnx {C Function} scm_objcode_to_bytecode (objcode)
-Copy object code out to a bytevector for analysis by Scheme.
+All emit procedure take the assembler as their first argument, and
+return no useful values.
+
+The argument types depend on the operand types. @xref{Instruction Set}.
+Most are integers within a restricted range, though labels are generally
+expressed as opaque symbols.
+
+There are a few macro-instructions as well.
+
+@deffn {Scheme Procedure} emit-label asm label
+Define a label at the current program point.
+@end deffn
+
+@deffn {Scheme Procedure} emit-source asm source
+Associate @var{source} with the current program point.
+@end deffn
+
+@deffn {Scheme Procedure} emit-cache-current-module! asm module scope
+@deffnx {Scheme Procedure} emit-cached-toplevel-box asm dst scope sym bound?
+@deffnx {Scheme Procedure} emit-cached-module-box asm dst module-name sym public? bound?
+Macro-instructions to implement caching of top-level variables. The
+first takes the current module, in the slot @var{module}, and associates
+it with a cache location identified by @var{scope}. The second takes a
+@var{scope}, and resolves the variable. @xref{Top-Level Environment
+Instructions}. The last does not need a cached module, rather taking
+the module name directly.
+@end deffn
+
+@deffn {Scheme Procedure} emit-load-constant asm dst constant
+Load the Scheme datum @var{constant} into @var{dst}.
@end deffn
-The following procedure is actually in @code{(system vm program)}, but
-we'll mention it here:
+@deffn {Scheme Procedure} emit-begin-program asm label properties
+@deffnx {Scheme Procedure} emit-end-program asm
+Delimit the bounds of a procedure, with the given @var{label} and the
+metadata @var{properties}.
+@end deffn
+
+@deffn {Scheme Procedure} emit-load-static-procedure asm dst label
+Load a procedure with the given @var{label} into local @var{dst}. This
+macro-instruction should only be used with procedures without free
+variables -- procedures that are not closures.
+@end deffn
+
+@deffn {Scheme Procedure} emit-begin-standard-arity asm req nlocals alternate
+@deffnx {Scheme Procedure} emit-begin-opt-arity asm req opt rest nlocals alternate
+@deffnx {Scheme Procedure} emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? nlocals alternate
+@deffnx {Scheme Procedure} emit-end-arity asm
+Delimit a clause of a procedure.
+@end deffn
+
+@deffn {Scheme Procedure} emit-br-if-symbol asm slot invert? label
+@deffnx {Scheme Procedure} emit-br-if-variable asm slot invert? label
+@deffnx {Scheme Procedure} emit-br-if-vector asm slot invert? label
+@deffnx {Scheme Procedure} emit-br-if-string asm slot invert? label
+@deffnx {Scheme Procedure} emit-br-if-bytevector asm slot invert? label
+@deffnx {Scheme Procedure} emit-br-if-bitvector asm slot invert? label
+TC7-specific test-and-branch instructions. The TC7 is a 7-bit code that
+is part of a heap object's type. @xref{The SCM Type in Guile}. Also,
+@xref{Branch Instructions}.
+@end deffn
-@deffn {Scheme Variable} make-program objcode objtable [free-vars=#f]
-@deffnx {C Function} scm_make_program (objcode, objtable, free_vars)
-Load up object code into a Scheme program. The resulting program will
-have @var{objtable} as its object table, which should be a vector or
-@code{#f}, and will capture the free variables from @var{free-vars}.
+The linker is a complicated beast. Hackers interested in how it works
+would do well do read Ian Lance Taylor's series of articles on linkers.
+Searching the internet should find them easily. From the user's
+perspective, there is only one knob to control: whether the resulting
+image will be written out to a file or not. If the user passes
+@code{#:to-file? #t} as part of the compiler options (@pxref{The Scheme
+Compiler}), the linker will align the resulting segments on page
+boundaries, and otherwise not.
+
+@deffn {Scheme Procedure} link-assembly asm #:page-aligned?=#t
+Link an ELF image, and return the bytevector. If @var{page-aligned?} is
+true, Guile will align the segments with different permissions on
+page-sized boundaries, in order to maximize code sharing between
+different processes. Otherwise, padding is minimized, to minimize
+address space consumption.
@end deffn
-Object code from a file may be disassembled at the REPL via the
-meta-command @code{,disassemble-file}, abbreviated as @code{,xx}.
-Programs may be disassembled via @code{,disassemble}, abbreviated as
-@code{,x}.
+To write an image to disk, just use @code{put-bytevector} from
+@code{(ice-9 binary-ports)}.
Compiling object code to the fake language, @code{value}, is performed
via loading objcode into a program, then executing that thunk with
respect to the compilation environment. Normally the environment
-propagates through the compiler transparently, but users may specify
-the compilation environment manually as well, as a module.
+propagates through the compiler transparently, but users may specify the
+compilation environment manually as well, as a module. Procedures to
+load images can be found in the @code{(system vm loader)} module:
+
+@lisp
+(use-modules (system vm loader))
+@end lisp
+
+@deffn {Scheme Variable} load-thunk-from-file file
+@deffnx {C Function} scm_load_thunk_from_file (file)
+Load object code from a file named @var{file}. The file will be mapped
+into memory via @code{mmap}, so this is a very fast operation.
+@end deffn
+
+@deffn {Scheme Variable} load-thunk-from-memory bv
+@deffnx {C Function} scm_load_thunk_from_memory (bv)
+Load object code from a bytevector. The data will be copied out of the
+bytevector in order to ensure proper alignment of embedded Scheme
+values.
+@end deffn
+
+Additionally there are procedures to find the ELF image for a given
+pointer, or to list all mapped ELF images:
+
+@deffn {Scheme Variable} find-mapped-elf-image ptr
+Given the integer value @var{ptr}, find and return the ELF image that
+contains that pointer, as a bytevector. If no image is found, return
+@code{#f}. This routine is mostly used by debuggers and other
+introspective tools.
+@end deffn
+
+@deffn {Scheme Variable} all-mapped-elf-images
+Return all mapped ELF images, as a list of bytevectors.
+@end deffn
@node Writing New High-Level Languages
Usually, installing the current locale is the right thing to do. It
allows Guile to correctly parse and print strings with non-ASCII
-characters. However, for compatibility with previous Guile 2.0
-releases, this option is off by default. The next stable release series
-of Guile (the 2.2 series) will install locales by default.
+characters. Therefore, this option is on by default.
@item GUILE_STACK_SIZE
@vindex GUILE_STACK_SIZE
@example
$ export GUILE_LOAD_COMPILED_PATH=".:../my-library"
$ guile -c '(display %load-compiled-path) (newline)'
-(. ../my-library /usr/local/lib/guile/2.0/ccache)
+(. ../my-library /usr/local/lib/guile/2.2/ccache)
@end example
@item GUILE_LOAD_PATH
@example
$ env GUILE_LOAD_PATH=".:...:../srfi" \
guile -c '(display %load-path) (newline)'
-(. /usr/local/share/guile/2.0 \
-/usr/local/share/guile/site/2.0 \
+(. /usr/local/share/guile/2.2 \
+/usr/local/share/guile/site/2.2 \
/usr/local/share/guile/site \
/usr/local/share/guile \
../srfi)
* Input and Output:: Ports, reading and writing.
* Regular Expressions:: Pattern matching and substitution.
* LALR(1) Parsing:: Generating LALR(1) parsers.
+* PEG Parsing:: Parsing Expression Grammars.
* Read/Load/Eval/Compile:: Reading and evaluating Scheme code.
* Memory Management:: Memory management and garbage collection.
* Modules:: Designing reusable code libraries.
@include api-io.texi
@include api-regex.texi
@include api-lalr.texi
+@include api-peg.texi
@include api-evaluation.texi
@include api-memory.texi
@include api-modules.texi
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2008, 2010, 2011
+@c Copyright (C) 2008, 2010, 2011, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
Schemes: SRFI-18 threads, module-hygienic macros, a profiler, tracer,
and debugger, SSAX XML integration, bytevectors, a dynamic FFI,
delimited continuations, module versions, and partial support for R6RS.
+
+@item 2.2 --- mid-2014
+The virtual machine and introduced in 2.0 was completely rewritten,
+along with much of the compiler and toolchain. This speeds up many
+Guile programs as well as reducing startup time and memory usage. A PEG
+parser toolkit was added, making it easier to write other language
+frontends.
@end table
@node Status
These days it is possible to write extensible applications almost
entirely from high-level languages, through byte-code and native
compilation, speed gains in the underlying hardware, and foreign call
-interfaces in the high-level language. Smalltalk systems are like
-this, as are Common Lisp-based systems. While there already are a
-number of pure-Guile applications out there, users still need to drop
-down to C for some tasks: interfacing to system libraries that don't
-have prebuilt Guile interfaces, and for some tasks requiring high
-performance.
-
-The addition of the virtual machine in Guile 2.0, together with the
-compiler infrastructure, should go a long way to addressing the speed
-issues. But there is much optimization to be done. Interested
-contributors will find lots of delightful low-hanging fruit, from
-simple profile-driven optimization to hacking a just-in-time compiler
-from VM bytecode to native code.
+interfaces in the high-level language. Smalltalk systems are like this,
+as are Common Lisp-based systems. While there already are a number of
+pure-Guile applications out there, users still need to drop down to C
+for some tasks: interfacing to system libraries that don't have prebuilt
+Guile interfaces, and for some tasks requiring high performance. Native
+ahead-of-time compilation, planned for Guile 3.0, should help with
+this.
Still, even with an all-Guile application, sometimes you want to
provide an opportunity for users to extend your program from a
interesting idea to consider is compiling e.g.@: Python to Guile. It's
not that far-fetched of an idea: see for example IronPython or JRuby.
-And then there's Emacs itself. Though there is a somewhat-working Emacs
-Lisp language frontend for Guile, it cannot yet execute all of Emacs
-Lisp. A serious integration of Guile with Emacs would replace the Elisp
-virtual machine with Guile, and provide the necessary C shims so that
-Guile could emulate Emacs' C API. This would give lots of exciting
-things to Emacs: native threads, a real object system, more
-sophisticated types, cleaner syntax, and access to all of the Guile
-extensions.
+And then there's Emacs itself. Guile's Emacs Lisp support has reached
+an excellent level of correctness, robustness, and speed. However there
+is still work to do to finish its integration into Emacs itself. This
+will give lots of exciting things to Emacs: native threads, a real
+object system, more sophisticated types, cleaner syntax, and access to
+all of the Guile extensions.
Finally, there is another axis of crystallization, the axis between
-different Scheme implementations. Guile does not yet support the
-latest Scheme standard, R6RS, and should do so. Like all standards,
-R6RS is imperfect, but supporting it will allow more code to run on
-Guile without modification, and will allow Guile hackers to produce
-code compatible with other schemes. Help in this regard would be much
+different Scheme implementations. Guile does not yet support the latest
+Scheme standard, R7RS, and should do so. Like all standards, R7RS is
+imperfect, but supporting it will allow more code to run on Guile
+without modification, and will allow Guile hackers to produce code
+compatible with other schemes. Help in this regard would be much
appreciated.
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2013, 2014
-@c Free Software Foundation, Inc.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010,
+@c 2011, 2013, 2014 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node General Libguile Concepts
guile mode for the first time, it gets a Scheme representation and is
listed by @code{all-threads}, for example.
-Threads in guile mode can block (e.g., do blocking I/O) without causing any
-problems@footnote{In Guile 1.8, a thread blocking in guile mode would prevent
-garbage collection to occur. Thus, threads had to leave guile mode whenever
-they could block. This is no longer needed with Guile 2.0.}; temporarily
-leaving guile mode with @code{scm_without_guile} before blocking slightly
-improves GC performance, though. For some common blocking operations, Guile
-provides convenience functions. For example, if you want to lock a pthread
-mutex while in guile mode, you might want to use @code{scm_pthread_mutex_lock}
-which is just like @code{pthread_mutex_lock} except that it leaves guile mode
-while blocking.
+Threads in guile mode can block (e.g., do blocking I/O) without causing
+any problems@footnote{In Guile 1.8, a thread blocking in guile mode
+would prevent garbage collection to occur. Thus, threads had to leave
+guile mode whenever they could block. This is no longer needed with
+Guile 2.@var{x}.}; temporarily leaving guile mode with
+@code{scm_without_guile} before blocking slightly improves GC
+performance, though. For some common blocking operations, Guile
+provides convenience functions. For example, if you want to lock a
+pthread mutex while in guile mode, you might want to use
+@code{scm_pthread_mutex_lock} which is just like
+@code{pthread_mutex_lock} except that it leaves guile mode while
+blocking.
All libguile functions are (intended to be) robust in the face of
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011,
-@c 2014 Free Software Foundation, Inc.
+@c 2013-2014 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Parallel Installations
@cindex effective version
Guile provides strong API and ABI stability guarantees during stable
-series, so that if a user writes a program against Guile version 2.0.3,
-it will be compatible with some future version 2.0.7. We say in this
-case that 2.0 is the @dfn{effective version}, composed of the major and
-minor versions, in this case 2 and 0.
+series, so that if a user writes a program against Guile version 2.2.3,
+it will be compatible with some future version 2.2.7. We say in this
+case that 2.2 is the @dfn{effective version}, composed of the major and
+minor versions, in this case 2 and 2.
Users may install multiple effective versions of Guile, with each
version's headers, libraries, and Scheme files under their own
Note that it is unsafe to fork a process that has multiple threads
running, as only the thread that calls @code{primitive-fork} will
persist in the child. Any resources that other threads held, such as
-locked mutexes or open file descriptors, are lost. Indeed, @acronym{POSIX}
-specifies that only async-signal-safe procedures are safe to call after
-a multithreaded fork, which is a very limited set. Guile issues a
-warning if it detects a fork from a multi-threaded program.
+locked mutexes or open file descriptors, are lost. Indeed,
+@acronym{POSIX} specifies that only async-signal-safe procedures are
+safe to call after a multithreaded fork, which is a very limited set.
+Guile issues a warning if it detects a fork from a multi-threaded
+program.
If you are going to @code{exec} soon after forking, the procedures in
@code{(ice-9 popen)} may be useful to you, as they fork and exec within
@end deffn
@deffn {Scheme Procedure} getitimer which_timer
-@deffnx {Scheme Procedure} setitimer which_timer interval_seconds interval_microseconds periodic_seconds periodic_microseconds
+@deffnx {Scheme Procedure} setitimer which_timer interval_seconds interval_microseconds value_seconds value_microseconds
@deffnx {C Function} scm_getitimer (which_timer)
-@deffnx {C Function} scm_setitimer (which_timer, interval_seconds, interval_microseconds, periodic_seconds, periodic_microseconds)
-Get or set the periods programmed in certain system timers. These
-timers have a current interval value which counts down and on reaching
-zero raises a signal. An optional periodic value can be set to
-restart from there each time, for periodic operation.
-@var{which_timer} is one of the following values
+@deffnx {C Function} scm_setitimer (which_timer, interval_seconds, interval_microseconds, value_seconds, value_microseconds)
+Get or set the periods programmed in certain system timers.
+
+These timers have two settings. The first setting, the interval, is the
+value at which the timer will be reset when the current timer expires.
+The second is the current value of the timer, indicating when the next
+expiry will be signalled.
+
+@var{which_timer} is one of the following values:
@defvar ITIMER_REAL
A real-time timer, counting down elapsed real time. At zero it raises
time (by looking where it is when the timer goes off).
@end defvar
-@code{getitimer} returns the current timer value and its programmed
-restart value, as a list containing two pairs. Each pair is a time in
-seconds and microseconds: @code{((@var{interval_secs}
-. @var{interval_usecs}) (@var{periodic_secs}
-. @var{periodic_usecs}))}.
+@code{getitimer} returns the restart timer value and its current value,
+as a list containing two pairs. Each pair is a time in seconds and
+microseconds: @code{((@var{interval_secs} . @var{interval_usecs})
+(@var{value_secs} . @var{value_usecs}))}.
@code{setitimer} sets the timer values similarly, in seconds and
-microseconds (which must be integers). The periodic value can be zero
+microseconds (which must be integers). The interval value can be zero
to have the timer run down just once. The return value is the timer's
previous setting, in the same form as @code{getitimer} returns.
@example
(setitimer ITIMER_REAL
- 5 500000 ;; first SIGALRM in 5.5 seconds time
- 2 0) ;; then repeat every 2 seconds
+ 5 500000 ;; Raise SIGALRM every 5.5 seconds
+ 2 0) ;; with the first SIGALRM in 2 seconds
@end example
Although the timers are programmed in microseconds, the actual
r5rs
srfi-0
srfi-4
+srfi-6
srfi-13
srfi-14
srfi-16
@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,
+between Guile 2.@var{x} and previous versions of Guile. For instance, it
+makes it possible to write code that accounts for Guile 2.@var{x}'s compiler,
yet be correctly interpreted on 1.8 and earlier versions:
@example
@cindex SRFI-6
SRFI-6 defines the procedures @code{open-input-string},
-@code{open-output-string} and @code{get-output-string}.
-
-Note that although versions of these procedures are included in the
-Guile core, the core versions are not fully conformant with SRFI-6:
-attempts to read or write characters that are not supported by the
-current @code{%default-port-encoding} will fail.
-
-We therefore recommend that you import this module, which supports all
-characters:
-
-@example
-(use-modules (srfi srfi-6))
-@end example
+@code{open-output-string} and @code{get-output-string}. These
+procedures are included in the Guile core, so using this module does not
+make any difference at the moment. But it is possible that support for
+SRFI-6 will be factored out of the core library in the future, so using
+this module does not hurt, after all.
@node SRFI-8
@subsection SRFI-8 - receive
-@c -*-texinfo-*-
-@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 2008,2009,2010,2013
-@c Free Software Foundation, Inc.
-@c See the file guile.texi for copying conditions.
-
-@node A Virtual Machine for Guile
-@section A Virtual Machine for Guile
-
-Guile has both an interpreter and a compiler. To a user, the difference
-is transparent---interpreted and compiled procedures can call each other
-as they please.
-
-The difference is that the compiler creates and interprets bytecode
-for a custom virtual machine, instead of interpreting the
-S-expressions directly. Loading and running compiled code is faster
-than loading and running source code.
-
-The virtual machine that does the bytecode interpretation is a part of
-Guile itself. This section describes the nature of Guile's virtual
-machine.
-
-@menu
-* Why a VM?::
-* VM Concepts::
-* Stack Layout::
-* Variables and the VM::
-* VM Programs::
-* Instruction Set::
-@end menu
-
-@node Why a VM?
-@subsection Why a VM?
-
-@cindex interpreter
-For a long time, Guile only had an interpreter. Guile's interpreter
-operated directly on the S-expression representation of Scheme source
-code.
-
-But while the interpreter was highly optimized and hand-tuned, it still
-performs many needless computations during the course of evaluating an
-expression. For example, application of a function to arguments
-needlessly consed up the arguments in a list. Evaluation of an
-expression always had to figure out what the car of the expression is --
-a procedure, a memoized form, or something else. All values have to be
-allocated on the heap. Et cetera.
-
-The solution to this problem was to compile the higher-level language,
-Scheme, into a lower-level language for which all of the checks and
-dispatching have already been done---the code is instead stripped to
-the bare minimum needed to ``do the job''.
-
-The question becomes then, what low-level language to choose? There
-are many options. We could compile to native code directly, but that
-poses portability problems for Guile, as it is a highly cross-platform
-project.
-
-So we want the performance gains that compilation provides, but we
-also want to maintain the portability benefits of a single code path.
-The obvious solution is to compile to a virtual machine that is
-present on all Guile installations.
-
-The easiest (and most fun) way to depend on a virtual machine is to
-implement the virtual machine within Guile itself. This way the
-virtual machine provides what Scheme needs (tail calls, multiple
-values, @code{call/cc}) and can provide optimized inline instructions
-for Guile (@code{cons}, @code{struct-ref}, etc.).
-
-So this is what Guile does. The rest of this section describes that VM
-that Guile implements, and the compiled procedures that run on it.
-
-Before moving on, though, we should note that though we spoke of the
-interpreter in the past tense, Guile still has an interpreter. The
-difference is that before, it was Guile's main evaluator, and so was
-implemented in highly optimized C; now, it is actually implemented in
-Scheme, and compiled down to VM bytecode, just like any other program.
-(There is still a C interpreter around, used to bootstrap the compiler,
-but it is not normally used at runtime.)
-
-The upside of implementing the interpreter in Scheme is that we preserve
-tail calls and multiple-value handling between interpreted and compiled
-code. The downside is that the interpreter in Guile 2.0 is slower than
-the interpreter in 1.8. We hope the that the compiler's speed makes up
-for the loss!
-
-Also note that this decision to implement a bytecode compiler does not
-preclude native compilation. We can compile from bytecode to native
-code at runtime, or even do ahead of time compilation. More
-possibilities are discussed in @ref{Extending the Compiler}.
-
-@node VM Concepts
-@subsection VM Concepts
-
-Compiled code is run by a virtual machine (VM). Each thread has its own
-VM. When a compiled procedure is run, Guile looks up the virtual machine
-for the current thread and executes the procedure using that VM.
-
-Guile's virtual machine is a stack machine---that is, it has few
-registers, and the instructions defined in the VM operate by pushing
-and popping values from a stack.
-
-Stack memory is exclusive to the virtual machine that owns it. In
-addition to their stacks, virtual machines also have access to the
-global memory (modules, global bindings, etc) that is shared among
-other parts of Guile, including other VMs.
-
-A VM has generic instructions, such as those to reference local
-variables, and instructions designed to support Guile's languages --
-mathematical instructions that support the entire numerical tower, an
-inlined implementation of @code{cons}, etc.
-
-The registers that a VM has are as follows:
-
-@itemize
-@item ip - Instruction pointer
-@item sp - Stack pointer
-@item fp - Frame pointer
-@end itemize
-
-In other architectures, the instruction pointer is sometimes called
-the ``program counter'' (pc). This set of registers is pretty typical
-for stack machines; their exact meanings in the context of Guile's VM
-are described in the next section.
-
-@c wingo: The following is true, but I don't know in what context to
-@c describe it. A documentation FIXME.
-
-@c A VM may have one of three engines: reckless, regular, or debugging.
-@c Reckless engine is fastest but dangerous. Regular engine is normally
-@c fail-safe and reasonably fast. Debugging engine is safest and
-@c functional but very slow.
-
-@c (Actually we have just a regular and a debugging engine; normally
-@c we use the latter, it's almost as fast as the ``regular'' engine.)
-
-@node Stack Layout
-@subsection Stack Layout
-
-While not strictly necessary to understand how to work with the VM, it
-is instructive and sometimes entertaining to consider the structure of
-the VM stack.
-
-Logically speaking, a VM stack is composed of ``frames''. Each frame
-corresponds to the application of one compiled procedure, and contains
-storage space for arguments, local variables, intermediate values, and
-some bookkeeping information (such as what to do after the frame
-computes its value).
-
-While the compiler is free to do whatever it wants to, as long as the
-semantics of a computation are preserved, in practice every time you
-call a function, a new frame is created. (The notable exception of
-course is the tail call case, @pxref{Tail Calls}.)
-
-Within a frame, you have the data associated with the function
-application itself, which is of a fixed size, and the stack space for
-intermediate values. Sometimes only the former is referred to as the
-``frame'', and the latter is the ``stack'', although all pending
-application frames can have some intermediate computations interleaved
-on the stack.
-
-The structure of the fixed part of an application frame is as follows:
-
-@example
- Stack
- | ... |
- | Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs = SCM_FRAME_UPPER_ADDRESS (fp)
- +==================+
- | Local variable 1 |
- | Local variable 0 | <- fp + bp->nargs
- | Argument 1 |
- | Argument 0 | <- fp
- | Program | <- fp - 1
- +------------------+
- | Return address |
- | MV return address|
- | Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) = SCM_FRAME_LOWER_ADDRESS (fp)
- +==================+
- | |
-@end example
-
-In the above drawing, the stack grows upward. The intermediate values
-stored in the application of this frame are stored above
-@code{SCM_FRAME_UPPER_ADDRESS (fp)}. @code{bp} refers to the
-@code{struct scm_objcode} data associated with the program at
-@code{fp - 1}. @code{nargs} and @code{nlocs} are properties of the
-compiled procedure, which will be discussed later.
-
-The individual fields of the frame are as follows:
-
-@table @asis
-@item Return address
-The @code{ip} that was in effect before this program was applied. When
-we return from this activation frame, we will jump back to this
-@code{ip}.
-
-@item MV return address
-The @code{ip} to return to if this application returns multiple
-values. For continuations that only accept one value, this value will
-be @code{NULL}; for others, it will be an @code{ip} that points to a
-multiple-value return address in the calling code. That code will
-expect the top value on the stack to be an integer---the number of
-values being returned---and that below that integer there are the
-values being returned.
-
-@item Dynamic link
-This is the @code{fp} in effect before this program was applied. In
-effect, this and the return address are the registers that are always
-``saved''. The dynamic link links the current frame to the previous
-frame; computing a stack trace involves traversing these frames.
-
-@item Local variable @var{n}
-Lambda-local variables that are all allocated as part of the frame.
-This makes access to variables very cheap.
-
-@item Argument @var{n}
-The calling convention of the VM requires arguments of a function
-application to be pushed on the stack, and here they are. References
-to arguments dispatch to these locations on the stack.
-
-@item Program
-This is the program being applied. For more information on how
-programs are implemented, @xref{VM Programs}.
-@end table
-
-@node Variables and the VM
-@subsection Variables and the VM
-
-Consider the following Scheme code as an example:
-
-@example
- (define (foo a)
- (lambda (b) (list foo a b)))
-@end example
-
-Within the lambda expression, @code{foo} is a top-level variable, @code{a} is a
-lexically captured variable, and @code{b} is a local variable.
-
-Another way to refer to @code{a} and @code{b} is to say that @code{a}
-is a ``free'' variable, since it is not defined within the lambda, and
-@code{b} is a ``bound'' variable. These are the terms used in the
-@dfn{lambda calculus}, a mathematical notation for describing
-functions. The lambda calculus is useful because it allows one to
-prove statements about functions. It is especially good at describing
-scope relations, and it is for that reason that we mention it here.
-
-Guile allocates all variables on the stack. When a lexically enclosed
-procedure with free variables---a @dfn{closure}---is created, it copies
-those variables into its free variable vector. References to free
-variables are then redirected through the free variable vector.
-
-If a variable is ever @code{set!}, however, it will need to be
-heap-allocated instead of stack-allocated, so that different closures
-that capture the same variable can see the same value. Also, this
-allows continuations to capture a reference to the variable, instead
-of to its value at one point in time. For these reasons, @code{set!}
-variables are allocated in ``boxes''---actually, in variable cells.
-@xref{Variables}, for more information. References to @code{set!}
-variables are indirected through the boxes.
-
-Thus perhaps counterintuitively, what would seem ``closer to the
-metal'', viz @code{set!}, actually forces an extra memory allocation
-and indirection.
-
-Going back to our example, @code{b} may be allocated on the stack, as
-it is never mutated.
-
-@code{a} may also be allocated on the stack, as it too is never
-mutated. Within the enclosed lambda, its value will be copied into
-(and referenced from) the free variables vector.
-
-@code{foo} is a top-level variable, because @code{foo} is not
-lexically bound in this example.
-
-@node VM Programs
-@subsection Compiled Procedures are VM Programs
-
-By default, when you enter in expressions at Guile's REPL, they are
-first compiled to VM object code, then that VM object code is executed
-to produce a value. If the expression evaluates to a procedure, the
-result of this process is a compiled procedure.
-
-A compiled procedure is a compound object, consisting of its bytecode,
-a reference to any captured lexical variables, an object array, and
-some metadata such as the procedure's arity, name, and documentation.
-You can pick apart these pieces with the accessors in @code{(system vm
-program)}. @xref{Compiled Procedures}, for a full API reference.
-
-@cindex object table
-@cindex object array
-The object array of a compiled procedure, also known as the
-@dfn{object table}, holds all Scheme objects whose values are known
-not to change across invocations of the procedure: constant strings,
-symbols, etc. The object table of a program is initialized right
-before a program is loaded with @code{load-program}.
-@xref{Loading Instructions}, for more information.
-
-Variable objects are one such type of constant object: when a global
-binding is defined, a variable object is associated to it and that
-object will remain constant over time, even if the value bound to it
-changes. Therefore, toplevel bindings only need to be looked up once.
-Thereafter, references to the corresponding toplevel variables from
-within the program are then performed via the @code{toplevel-ref}
-instruction, which uses the object vector, and are almost as fast as
-local variable references.
-
-We can see how these concepts tie together by disassembling the
-@code{foo} function we defined earlier to see what is going on:
-
-@smallexample
-scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b)))
-scheme@@(guile-user)> ,x foo
- 0 (assert-nargs-ee/locals 1)
- 2 (object-ref 1) ;; #<procedure 8ebec20 at <current input>:0:17 (b)>
- 4 (local-ref 0) ;; `a'
- 6 (make-closure 0 1)
- 9 (return)
-
-----------------------------------------
-Disassembly of #<procedure 8ebec20 at <current input>:0:17 (b)>:
-
- 0 (assert-nargs-ee/locals 1)
- 2 (toplevel-ref 1) ;; `foo'
- 4 (free-ref 0) ;; (closure variable)
- 6 (local-ref 0) ;; `b'
- 8 (list 0 3) ;; 3 elements at (unknown file):0:29
- 11 (return)
-@end smallexample
-
-First there's some prelude, where @code{foo} checks that it was called with only
-1 argument. Then at @code{ip} 2, we load up the compiled lambda. @code{Ip} 4
-loads up `a', so that it can be captured into a closure by at @code{ip}
-6---binding code (from the compiled lambda) with data (the free-variable
-vector). Finally we return the closure.
-
-The second stanza disassembles the compiled lambda. After the prelude, we note
-that toplevel variables are resolved relative to the module that was current
-when the procedure was created. This lookup occurs lazily, at the first time the
-variable is actually referenced, and the location of the lookup is cached so
-that future references are very cheap. @xref{Top-Level Environment Instructions},
-for more details.
-
-Then we see a reference to a free variable, corresponding to @code{a}. The
-disassembler doesn't have enough information to give a name to that variable, so
-it just marks it as being a ``closure variable''. Finally we see the reference
-to @code{b}, then the @code{list} opcode, an inline implementation of the
-@code{list} scheme routine.
-
-@node Instruction Set
-@subsection Instruction Set
-
-There are about 180 instructions in Guile's virtual machine. These
-instructions represent atomic units of a program's execution. Ideally,
-they perform one task without conditional branches, then dispatch to
-the next instruction in the stream.
-
-Instructions themselves are one byte long. Some instructions take
-parameters, which follow the instruction byte in the instruction
-stream.
-
-Sometimes the compiler can figure out that it is compiling a special
-case that can be run more efficiently. So, for example, while Guile
-offers a generic test-and-branch instruction, it also offers specific
-instructions for special cases, so that the following cases all have
-their own test-and-branch instructions:
-
-@example
-(if pred then else)
-(if (not pred) then else)
-(if (null? l) then else)
-(if (not (null? l)) then else)
-@end example
-
-In addition, some Scheme primitives have their own inline
-implementations, e.g.@: @code{cons}, and @code{list}, as we saw in the
-previous section.
-
-So Guile's instruction set is a @emph{complete} instruction set, in
-that it provides the instructions that are suited to the problem, and
-is not concerned with making a minimal, orthogonal set of
-instructions. More instructions may be added over time.
-
-@menu
-* Lexical Environment Instructions::
-* Top-Level Environment Instructions::
-* Procedure Call and Return Instructions::
-* Function Prologue Instructions::
-* Trampoline Instructions::
-* Branch Instructions::
-* Data Constructor Instructions::
-* Loading Instructions::
-* Dynamic Environment Instructions::
-* Miscellaneous Instructions::
-* Inlined Scheme Instructions::
-* Inlined Mathematical Instructions::
-* Inlined Bytevector Instructions::
-@end menu
-
-
-@node Lexical Environment Instructions
-@subsubsection Lexical Environment Instructions
-
-These instructions access and mutate the lexical environment of a
-compiled procedure---its free and bound variables.
-
-Some of these instructions have @code{long-} variants, the difference
-being that they take 16-bit arguments, encoded in big-endianness,
-instead of the normal 8-bit range.
-
-@xref{Stack Layout}, for more information on the format of stack frames.
-
-@deffn Instruction local-ref index
-@deffnx Instruction long-local-ref index
-Push onto the stack the value of the local variable located at
-@var{index} within the current stack frame.
-
-Note that arguments and local variables are all in one block. Thus the
-first argument, if any, is at index 0, and local bindings follow the
-arguments.
-@end deffn
-
-@deffn Instruction local-set index
-@deffnx Instruction long-local-set index
-Pop the Scheme object located on top of the stack and make it the new
-value of the local variable located at @var{index} within the current
-stack frame.
-@end deffn
-
-@deffn Instruction box index
-Pop a value off the stack, and set the @var{index}nth local variable
-to a box containing that value. A shortcut for @code{make-variable}
-then @code{local-set}, used when binding boxed variables.
-@end deffn
-
-@deffn Instruction empty-box index
-Set the @var{index}th local variable to a box containing a variable
-whose value is unbound. Used when compiling some @code{letrec}
-expressions.
-@end deffn
-
-@deffn Instruction local-boxed-ref index
-@deffnx Instruction local-boxed-set index
-Get or set the value of the variable located at @var{index} within the
-current stack frame. A shortcut for @code{local-ref} then
-@code{variable-ref} or @code{variable-set}, respectively.
-@end deffn
-
-@deffn Instruction free-ref index
-Push the value of the captured variable located at position
-@var{index} within the program's vector of captured variables.
-@end deffn
-
-@deffn Instruction free-boxed-ref index
-@deffnx Instruction free-boxed-set index
-Get or set a boxed free variable. A shortcut for @code{free-ref} then
-@code{variable-ref} or @code{variable-set}, respectively.
-
-Note that there is no @code{free-set} instruction, as variables that are
-@code{set!} must be boxed.
-@end deffn
-
-@deffn Instruction make-closure num-free-vars
-Pop @var{num-free-vars} values and a program object off the stack in
-that order, and push a new program object closing over the given free
-variables. @var{num-free-vars} is encoded as a two-byte big-endian
-value.
-
-The free variables are stored in an array, inline to the new program
-object, in the order that they were on the stack (not the order they are
-popped off). The new closure shares state with the original program. At
-the time of this writing, the space overhead of closures is 3 words,
-plus one word for each free variable.
-@end deffn
-
-@deffn Instruction fix-closure index
-Fix up the free variables array of the closure stored in the
-@var{index}th local variable. @var{index} is a two-byte big-endian
-integer.
-
-This instruction will pop as many values from the stack as are in the
-corresponding closure's free variables array. The topmost value on the
-stack will be stored as the closure's last free variable, with other
-values filling in free variable slots in order.
-
-@code{fix-closure} is part of a hack for allocating mutually recursive
-procedures. The hack is to store the procedures in their corresponding
-local variable slots, with space already allocated for free variables.
-Then once they are all in place, this instruction fixes up their
-procedures' free variable bindings in place. This allows most
-@code{letrec}-bound procedures to be allocated unboxed on the stack.
-@end deffn
-
-@deffn Instruction local-bound? index
-@deffnx Instruction long-local-bound? index
-Push @code{#t} on the stack if the @code{index}th local variable has
-been assigned, or @code{#f} otherwise. Mostly useful for handling
-optional arguments in procedure prologues.
-@end deffn
-
-
-@node Top-Level Environment Instructions
-@subsubsection Top-Level Environment Instructions
-
-These instructions access values in the top-level environment: bindings
-that were not lexically apparent at the time that the code in question
-was compiled.
-
-The location in which a toplevel binding is stored can be looked up once
-and cached for later. The binding itself may change over time, but its
-location will stay constant.
-
-Currently only toplevel references within procedures are cached, as only
-procedures have a place to cache them, in their object tables.
-
-@deffn Instruction toplevel-ref index
-@deffnx Instruction long-toplevel-ref index
-Push the value of the toplevel binding whose location is stored in at
-position @var{index} in the current procedure's object table. The
-@code{long-} variant encodes the index over two bytes.
-
-Initially, a cell in a procedure's object table that is used by
-@code{toplevel-ref} is initialized to one of two forms. The normal case
-is that the cell holds a symbol, whose binding will be looked up
-relative to the module that was current when the current program was
-created.
-
-Alternately, the lookup may be performed relative to a particular
-module, determined at compile-time (e.g.@: via @code{@@} or
-@code{@@@@}). In that case, the cell in the object table holds a list:
-@code{(@var{modname} @var{sym} @var{public?})}. The symbol @var{sym}
-will be looked up in the module named @var{modname} (a list of
-symbols). The lookup will be performed against the module's public
-interface, unless @var{public?} is @code{#f}, which it is for example
-when compiling @code{@@@@}.
-
-In any case, if the symbol is unbound, an error is signalled.
-Otherwise the initial form is replaced with the looked-up variable, an
-in-place mutation of the object table. This mechanism provides for
-lazy variable resolution, and an important cached fast-path once the
-variable has been successfully resolved.
-
-This instruction pushes the value of the variable onto the stack.
-@end deffn
-
-@deffn Instruction toplevel-set index
-@deffnx Instruction long-toplevel-set index
-Pop a value off the stack, and set it as the value of the toplevel
-variable stored at @var{index} in the object table. If the variable
-has not yet been looked up, we do the lookup as in
-@code{toplevel-ref}.
-@end deffn
-
-@deffn Instruction define
-Pop a symbol and a value from the stack, in that order. Look up its
-binding in the current toplevel environment, creating the binding if
-necessary. Set the variable to the value.
-@end deffn
-
-@deffn Instruction link-now
-Pop a value, @var{x}, from the stack. Look up the binding for @var{x},
-according to the rules for @code{toplevel-ref}, and push that variable
-on the stack. If the lookup fails, an error will be signalled.
-
-This instruction is mostly used when loading programs, because it can
-do toplevel variable lookups without an object table.
-@end deffn
-
-@deffn Instruction variable-ref
-Dereference the variable object which is on top of the stack and
-replace it by the value of the variable it represents.
-@end deffn
-
-@deffn Instruction variable-set
-Pop off two objects from the stack, a variable and a value, and set
-the variable to the value.
-@end deffn
-
-@deffn Instruction variable-bound?
-Pop off the variable object from top of the stack and push @code{#t} if
-it is bound, or @code{#f} otherwise. Mostly useful in procedure
-prologues for defining default values for boxed optional variables.
-@end deffn
-
-@deffn Instruction make-variable
-Replace the top object on the stack with a variable containing it.
-Used in some circumstances when compiling @code{letrec} expressions.
-@end deffn
-
-
-@node Procedure Call and Return Instructions
-@subsubsection Procedure Call and Return Instructions
-
-@c something about the calling convention here?
-
-@deffn Instruction new-frame
-Push a new frame on the stack, reserving space for the dynamic link,
-return address, and the multiple-values return address. The frame
-pointer is not yet updated, because the frame is not yet active -- it
-has to be patched by a @code{call} instruction to get the return
-address.
-@end deffn
-
-@deffn Instruction call nargs
-Call the procedure located at @code{sp[-nargs]} with the @var{nargs}
-arguments located from @code{sp[-nargs + 1]} to @code{sp[0]}.
-
-This instruction requires that a new frame be pushed on the stack before
-the procedure, via @code{new-frame}. @xref{Stack Layout}, for more
-information. It patches up that frame with the current @code{ip} as the
-return address, then dispatches to the first instruction in the called
-procedure, relying on the called procedure to return one value to the
-newly-created continuation. Because the new frame pointer will point to
-@code{sp[-nargs + 1]}, the arguments don't have to be shuffled around --
-they are already in place.
-@end deffn
-
-@deffn Instruction tail-call nargs
-Transfer control to the procedure located at @code{sp[-nargs]} with the
-@var{nargs} arguments located from @code{sp[-nargs + 1]} to
-@code{sp[0]}.
-
-Unlike @code{call}, which requires a new frame to be pushed onto the
-stack, @code{tail-call} simply shuffles down the procedure and arguments
-to the current stack frame. This instruction implements tail calls as
-required by RnRS.
-@end deffn
-
-@deffn Instruction apply nargs
-@deffnx Instruction tail-apply nargs
-Like @code{call} and @code{tail-call}, except that the top item on the
-stack must be a list. The elements of that list are then pushed on the
-stack and treated as additional arguments, replacing the list itself,
-then the procedure is invoked as usual.
-@end deffn
-
-@deffn Instruction call/nargs
-@deffnx Instruction tail-call/nargs
-These are like @code{call} and @code{tail-call}, except they take the
-number of arguments from the stack instead of the instruction stream.
-These instructions are used in the implementation of multiple value
-returns, where the actual number of values is pushed on the stack.
-@end deffn
-
-@deffn Instruction mv-call nargs offset
-Like @code{call}, except that a multiple-value continuation is created
-in addition to a single-value continuation.
-
-The offset (a three-byte value) is an offset within the instruction
-stream; the multiple-value return address in the new frame (@pxref{Stack
-Layout}) will be set to the normal return address plus this offset.
-Instructions at that offset will expect the top value of the stack to be
-the number of values, and below that values themselves, pushed
-separately.
-@end deffn
-
-@deffn Instruction return
-Free the program's frame, returning the top value from the stack to
-the current continuation. (The stack should have exactly one value on
-it.)
-
-Specifically, the @code{sp} is decremented to one below the current
-@code{fp}, the @code{ip} is reset to the current return address, the
-@code{fp} is reset to the value of the current dynamic link, and then
-the returned value is pushed on the stack.
-@end deffn
-
-@deffn Instruction return/values nvalues
-@deffnx Instruction return/nvalues
-Return the top @var{nvalues} to the current continuation. In the case of
-@code{return/nvalues}, @var{nvalues} itself is first popped from the top
-of the stack.
-
-If the current continuation is a multiple-value continuation,
-@code{return/values} pushes the number of values on the stack, then
-returns as in @code{return}, but to the multiple-value return address.
-
-Otherwise if the current continuation accepts only one value, i.e.@: the
-multiple-value return address is @code{NULL}, then we assume the user
-only wants one value, and we give them the first one. If there are no
-values, an error is signaled.
-@end deffn
-
-@deffn Instruction return/values* nvalues
-Like a combination of @code{apply} and @code{return/values}, in which
-the top value on the stack is interpreted as a list of additional
-values. This is an optimization for the common @code{(apply values
-...)} case.
-@end deffn
-
-@deffn Instruction truncate-values nbinds nrest
-Used in multiple-value continuations, this instruction takes the
-values that are on the stack (including the number-of-values marker)
-and truncates them for a binding construct.
-
-For example, a call to @code{(receive (x y . z) (foo) ...)} would,
-logically speaking, pop off the values returned from @code{(foo)} and
-push them as three values, corresponding to @code{x}, @code{y}, and
-@code{z}. In that case, @var{nbinds} would be 3, and @var{nrest} would
-be 1 (to indicate that one of the bindings was a rest argument).
-
-Signals an error if there is an insufficient number of values.
-@end deffn
-
-@deffn Instruction call/cc
-@deffnx Instruction tail-call/cc
-Capture the current continuation, and then call (or tail-call) the
-procedure on the top of the stack, with the continuation as the
-argument.
-
-@code{call/cc} does not require a @code{new-frame} to be pushed on the
-stack, as @code{call} does, because it needs to capture the stack
-before the frame is pushed.
-
-Both the VM continuation and the C continuation are captured.
-@end deffn
-
-
-@node Function Prologue Instructions
-@subsubsection Function Prologue Instructions
-
-A function call in Guile is very cheap: the VM simply hands control to
-the procedure. The procedure itself is responsible for asserting that it
-has been passed an appropriate number of arguments. This strategy allows
-arbitrarily complex argument parsing idioms to be developed, without
-harming the common case.
-
-For example, only calls to keyword-argument procedures ``pay'' for the
-cost of parsing keyword arguments. (At the time of this writing, calling
-procedures with keyword arguments is typically two to four times as
-costly as calling procedures with a fixed set of arguments.)
-
-@deffn Instruction assert-nargs-ee n
-@deffnx Instruction assert-nargs-ge n
-Assert that the current procedure has been passed exactly @var{n}
-arguments, for the @code{-ee} case, or @var{n} or more arguments, for
-the @code{-ge} case. @var{n} is encoded over two bytes.
-
-The number of arguments is determined by subtracting the frame pointer
-from the stack pointer (@code{sp - (fp -1)}). @xref{Stack Layout}, for
-more details on stack frames.
-@end deffn
-
-@deffn Instruction br-if-nargs-ne n offset
-@deffnx Instruction br-if-nargs-gt n offset
-@deffnx Instruction br-if-nargs-lt n offset
-Jump to @var{offset} if the number of arguments is not equal to, greater
-than, or less than @var{n}. @var{n} is encoded over two bytes, and
-@var{offset} has the normal three-byte encoding.
-
-These instructions are used to implement multiple arities, as in
-@code{case-lambda}. @xref{Case-lambda}, for more information.
-@end deffn
-
-@deffn Instruction bind-optionals n
-If the procedure has been called with fewer than @var{n} arguments, fill
-in the remaining arguments with an unbound value (@code{SCM_UNDEFINED}).
-@var{n} is encoded over two bytes.
-
-The optionals can be later initialized conditionally via the
-@code{local-bound?} instruction.
-@end deffn
-
-@deffn Instruction push-rest n
-Pop off excess arguments (more than @var{n}), collecting them into a
-list, and push that list. Used to bind a rest argument, if the procedure
-has no keyword arguments. Procedures with keyword arguments use
-@code{bind-rest} instead.
-@end deffn
-
-@deffn Instruction bind-rest n idx
-Pop off excess arguments (more than @var{n}), collecting them into a
-list. The list is then assigned to the @var{idx}th local variable.
-@end deffn
-
-@deffn Instruction bind-optionals/shuffle nreq nreq-and-opt ntotal
-@deffnx Instruction bind-optionals/shuffle-or-br nreq nreq-and-opt ntotal offset
-Shuffle keyword arguments to the top of the stack, filling in the holes
-with @code{SCM_UNDEFINED}. Each argument is encoded over two bytes.
-
-This instruction is used by procedures with keyword arguments.
-@var{nreq} is the number of required arguments to the procedure, and
-@var{nreq-and-opt} is the total number of positional arguments (required
-plus optional). @code{bind-optionals/shuffle} will scan the stack from
-the @var{nreq}th argument up to the @var{nreq-and-opt}th, and start
-shuffling when it sees the first keyword argument or runs out of
-positional arguments.
-
-@code{bind-optionals/shuffle-or-br} does the same, except that it checks
-if there are too many positional arguments before shuffling. If this is
-the case, it jumps to @var{offset}, encoded using the normal three-byte
-encoding.
-
-Shuffling simply moves the keyword arguments past the total number of
-arguments, @var{ntotal}, which includes keyword and rest arguments. The
-free slots created by the shuffle are filled in with
-@code{SCM_UNDEFINED}, so they may be conditionally initialized later in
-the function's prologue.
-@end deffn
-
-@deffn Instruction bind-kwargs idx ntotal flags
-Parse keyword arguments, assigning their values to the corresponding
-local variables. The keyword arguments should already have been shuffled
-above the @var{ntotal}th stack slot by @code{bind-optionals/shuffle}.
-
-The parsing is driven by a keyword arguments association list, looked up
-from the @var{idx}th element of the procedures object array. The alist
-is a list of pairs of the form @code{(@var{kw} . @var{index})}, mapping
-keyword arguments to their local variable indices.
-
-There are two bitflags that affect the parser, @code{allow-other-keys?}
-(@code{0x1}) and @code{rest?} (@code{0x2}). Unless
-@code{allow-other-keys?} is set, the parser will signal an error if an
-unknown key is found. If @code{rest?} is set, errors parsing the
-keyword arguments will be ignored, as a later @code{bind-rest}
-instruction will collect all of the tail arguments, including the
-keywords, into a list. Otherwise if the keyword arguments are invalid,
-an error is signalled.
-
-@var{idx} and @var{ntotal} are encoded over two bytes each, and
-@var{flags} is encoded over one byte.
-@end deffn
-
-@deffn Instruction reserve-locals n
-Resets the stack pointer to have space for @var{n} local variables,
-including the arguments. If this operation increments the stack pointer,
-as in a push, the new slots are filled with @code{SCM_UNBOUND}. If this
-operation decrements the stack pointer, any excess values are dropped.
-
-@code{reserve-locals} is typically used after argument parsing to
-reserve space for local variables.
-@end deffn
-
-@deffn Instruction assert-nargs-ee/locals n
-@deffnx Instruction assert-nargs-ge/locals n
-A combination of @code{assert-nargs-ee} and @code{reserve-locals}. The
-number of arguments is encoded in the lower three bits of @var{n}, a
-one-byte value. The number of additional local variables is take from
-the upper 5 bits of @var{n}.
-@end deffn
-
-
-@node Trampoline Instructions
-@subsubsection Trampoline Instructions
-
-Though most applicable objects in Guile are procedures implemented
-in bytecode, not all are. There are primitives, continuations, and other
-procedure-like objects that have their own calling convention. Instead
-of adding special cases to the @code{call} instruction, Guile wraps
-these other applicable objects in VM trampoline procedures, then
-provides special support for these objects in bytecode.
-
-Trampoline procedures are typically generated by Guile at runtime, for
-example in response to a call to @code{scm_c_make_gsubr}. As such, a
-compiler probably shouldn't emit code with these instructions. However,
-it's still interesting to know how these things work, so we document
-these trampoline instructions here.
-
-@deffn Instruction subr-call nargs
-Pop off a foreign pointer (which should have been pushed on by the
-trampoline), and call it directly, with the @var{nargs} arguments from
-the stack. Return the resulting value or values to the calling
-procedure.
-@end deffn
-
-@deffn Instruction foreign-call nargs
-Pop off an internal foreign object (which should have been pushed on by
-the trampoline), and call that foreign function with the @var{nargs}
-arguments from the stack. Return the resulting value to the calling
-procedure.
-@end deffn
-
-@deffn Instruction continuation-call
-Pop off an internal continuation object (which should have been pushed
-on by the trampoline), and reinstate that continuation. All of the
-procedure's arguments are passed to the continuation. Does not return.
-@end deffn
-
-@deffn Instruction partial-cont-call
-Pop off two objects from the stack: the dynamic winds associated with
-the partial continuation, and the VM continuation object. Unroll the
-continuation onto the stack, rewinding the dynamic environment and
-overwriting the current frame, and pass all arguments to the
-continuation. Control flow proceeds where the continuation was captured.
-@end deffn
-
-
-@node Branch Instructions
-@subsubsection Branch Instructions
-
-All the conditional branch instructions described below work in the
-same way:
-
-@itemize
-@item They pop off Scheme object(s) located on the stack for use in the
-branch condition
-@item If the condition is true, then the instruction pointer is
-increased by the offset passed as an argument to the branch
-instruction;
-@item Program execution proceeds with the next instruction (that is,
-the one to which the instruction pointer points).
-@end itemize
-
-Note that the offset passed to the instruction is encoded as three 8-bit
-integers, in big-endian order, effectively giving Guile a 24-bit
-relative address space.
-
-@deffn Instruction br offset
-Jump to @var{offset}. No values are popped.
-@end deffn
-
-@deffn Instruction br-if offset
-Jump to @var{offset} if the object on the stack is not false.
-@end deffn
-
-@deffn Instruction br-if-not offset
-Jump to @var{offset} if the object on the stack is false.
-@end deffn
-
-@deffn Instruction br-if-eq offset
-Jump to @var{offset} if the two objects located on the stack are
-equal in the sense of @code{eq?}. Note that, for this instruction, the
-stack pointer is decremented by two Scheme objects instead of only
-one.
-@end deffn
-
-@deffn Instruction br-if-not-eq offset
-Same as @code{br-if-eq} for non-@code{eq?} objects.
-@end deffn
-
-@deffn Instruction br-if-null offset
-Jump to @var{offset} if the object on the stack is @code{'()}.
-@end deffn
-
-@deffn Instruction br-if-not-null offset
-Jump to @var{offset} if the object on the stack is not @code{'()}.
-@end deffn
-
-
-@node Data Constructor Instructions
-@subsubsection Data Constructor Instructions
-
-These instructions push simple immediate values onto the stack,
-or construct compound data structures from values on the stack.
-
-@deffn Instruction make-int8 value
-Push @var{value}, an 8-bit integer, onto the stack.
-@end deffn
-
-@deffn Instruction make-int8:0
-Push the immediate value @code{0} onto the stack.
-@end deffn
-
-@deffn Instruction make-int8:1
-Push the immediate value @code{1} onto the stack.
-@end deffn
-
-@deffn Instruction make-int16 value
-Push @var{value}, a 16-bit integer, onto the stack.
-@end deffn
-
-@deffn Instruction make-uint64 value
-Push @var{value}, an unsigned 64-bit integer, onto the stack. The
-value is encoded in 8 bytes, most significant byte first (big-endian).
-@end deffn
-
-@deffn Instruction make-int64 value
-Push @var{value}, a signed 64-bit integer, onto the stack. The value
-is encoded in 8 bytes, most significant byte first (big-endian), in
-twos-complement arithmetic.
-@end deffn
-
-@deffn Instruction make-false
-Push @code{#f} onto the stack.
-@end deffn
-
-@deffn Instruction make-true
-Push @code{#t} onto the stack.
-@end deffn
-
-@deffn Instruction make-nil
-Push @code{#nil} onto the stack.
-@end deffn
-
-@deffn Instruction make-eol
-Push @code{'()} onto the stack.
-@end deffn
-
-@deffn Instruction make-char8 value
-Push @var{value}, an 8-bit character, onto the stack.
-@end deffn
-
-@deffn Instruction make-char32 value
-Push @var{value}, an 32-bit character, onto the stack. The value is
-encoded in big-endian order.
-@end deffn
-
-@deffn Instruction make-symbol
-Pops a string off the stack, and pushes a symbol.
-@end deffn
-
-@deffn Instruction make-keyword value
-Pops a symbol off the stack, and pushes a keyword.
-@end deffn
-
-@deffn Instruction list n
-Pops off the top @var{n} values off of the stack, consing them up into
-a list, then pushes that list on the stack. What was the topmost value
-will be the last element in the list. @var{n} is a two-byte value,
-most significant byte first.
-@end deffn
-
-@deffn Instruction vector n
-Create and fill a vector with the top @var{n} values from the stack,
-popping off those values and pushing on the resulting vector. @var{n}
-is a two-byte value, like in @code{vector}.
-@end deffn
-
-@deffn Instruction make-struct n
-Make a new struct from the top @var{n} values on the stack. The values
-are popped, and the new struct is pushed.
-
-The deepest value is used as the vtable for the struct, and the rest are
-used in order as the field initializers. Tail arrays are not supported
-by this instruction.
-@end deffn
-
-@deffn Instruction make-array n
-Pop an array shape from the stack, then pop the remaining @var{n}
-values, pushing a new array. @var{n} is encoded over three bytes.
-
-The array shape should be appropriate to store @var{n} values.
-@xref{Array Procedures}, for more information on array shapes.
-@end deffn
-
-Many of these data structures are constant, never changing over the
-course of the different invocations of the procedure. In that case it is
-often advantageous to make them once when the procedure is created, and
-just reference them from the object table thereafter. @xref{Variables
-and the VM}, for more information on the object table.
-
-@deffn Instruction object-ref n
-@deffnx Instruction long-object-ref n
-Push @var{n}th value from the current program's object vector. The
-``long'' variant has a 16-bit index instead of an 8-bit index.
-@end deffn
-
-
-@node Loading Instructions
-@subsubsection Loading Instructions
-
-In addition to VM instructions, an instruction stream may contain
-variable-length data embedded within it. This data is always preceded
-by special loading instructions, which interpret the data and advance
-the instruction pointer to the next VM instruction.
-
-All of these loading instructions have a @code{length} parameter,
-indicating the size of the embedded data, in bytes. The length itself
-is encoded in 3 bytes.
-
-@deffn Instruction load-number length
-Load an arbitrary number from the instruction stream. The number is
-embedded in the stream as a string.
-@end deffn
-@deffn Instruction load-string length
-Load a string from the instruction stream. The string is assumed to be
-encoded in the ``latin1'' locale.
-@end deffn
-@deffn Instruction load-wide-string length
-Load a UTF-32 string from the instruction stream. @var{length} is the
-length in bytes, not in codepoints.
-@end deffn
-@deffn Instruction load-symbol length
-Load a symbol from the instruction stream. The symbol is assumed to be
-encoded in the ``latin1'' locale. Symbols backed by wide strings may
-be loaded via @code{load-wide-string} then @code{make-symbol}.
-@end deffn
-@deffn Instruction load-array length
-Load a uniform array from the instruction stream. The shape and type
-of the array are popped off the stack, in that order.
-@end deffn
-
-@deffn Instruction load-program
-Load bytecode from the instruction stream, and push a compiled
-procedure.
-
-This instruction pops one value from the stack: the program's object
-table, as a vector, or @code{#f} in the case that the program has no
-object table. A program that does not reference toplevel bindings and
-does not use @code{object-ref} does not need an object table.
-
-This instruction is unlike the rest of the loading instructions,
-because instead of parsing its data, it directly maps the instruction
-stream onto a C structure, @code{struct scm_objcode}. @xref{Bytecode
-and Objcode}, for more information.
-
-The resulting compiled procedure will not have any free variables
-captured, so it may be loaded only once but used many times to create
-closures.
-@end deffn
-
-@node Dynamic Environment Instructions
-@subsubsection Dynamic Environment Instructions
-
-Guile's virtual machine has low-level support for @code{dynamic-wind},
-dynamic binding, and composable prompts and aborts.
-
-@deffn Instruction wind
-Pop an unwind thunk and a wind thunk from the stack, in that order, and
-push them onto the ``dynamic stack''. The unwind thunk will be called on
-nonlocal exits, and the wind thunk on reentries. Used to implement
-@code{dynamic-wind}.
-
-Note that neither thunk is actually called; the compiler should emit
-calls to wind and unwind for the normal dynamic-wind control flow.
-@xref{Dynamic Wind}.
-@end deffn
-
-@deffn Instruction unwind
-Pop off the top entry from the ``dynamic stack'', for example, a
-wind/unwind thunk pair. @code{unwind} instructions should be properly
-paired with their winding instructions, like @code{wind}.
-@end deffn
-
-@deffn Instruction wind-fluids n
-Pop off @var{n} values and @var{n} fluids from the stack, in that order.
-Set the fluids to the values by creating a with-fluids object and
-pushing that object on the dynamic stack. @xref{Fluids and Dynamic
-States}.
-@end deffn
-
-@deffn Instruction unwind-fluids
-Pop a with-fluids object from the dynamic stack, and swap the current
-values of its fluids with the saved values of its fluids. In this way,
-the dynamic environment is left as it was before the corresponding
-@code{wind-fluids} instruction was processed.
-@end deffn
-
-@deffn Instruction fluid-ref
-Pop a fluid from the stack, and push its current value.
-@end deffn
-
-@deffn Instruction fluid-set
-Pop a value and a fluid from the stack, in that order, and set the fluid
-to the value.
-@end deffn
-
-@deffn Instruction prompt escape-only? offset
-Establish a dynamic prompt. @xref{Prompts}, for more information on
-prompts.
-
-The prompt will be pushed on the dynamic stack. The normal control flow
-should ensure that the prompt is popped off at the end, via
-@code{unwind}.
-
-If an abort is made to this prompt, control will jump to @var{offset}, a
-three-byte relative address. The continuation and all arguments to the
-abort will be pushed on the stack, along with the total number of
-arguments (including the continuation. If control returns to the
-handler, the prompt is already popped off by the abort mechanism.
-(Guile's @code{prompt} implements Felleisen's @dfn{--F--} operator.)
-
-If @var{escape-only?} is nonzero, the prompt will be marked as
-escape-only, which allows an abort to this prompt to avoid reifying the
-continuation.
-@end deffn
-
-@deffn Instruction abort n
-Abort to a dynamic prompt.
-
-This instruction pops one tail argument list, @var{n} arguments, and a
-prompt tag from the stack. The dynamic environment is then searched for
-a prompt having the given tag. If none is found, an error is signalled.
-Otherwise all arguments are passed to the prompt's handler, along with
-the captured continuation, if necessary.
-
-If the prompt's handler can be proven to not reference the captured
-continuation, no continuation is allocated. This decision happens
-dynamically, at run-time; the general case is that the continuation may
-be captured, and thus resumed. A reinstated continuation will have its
-arguments pushed on the stack, along with the number of arguments, as in
-the multiple-value return convention. Therefore an @code{abort}
-instruction should be followed by code ready to handle the equivalent of
-a multiply-valued return.
-@end deffn
-
-@node Miscellaneous Instructions
-@subsubsection Miscellaneous Instructions
-
-@deffn Instruction nop
-Does nothing! Used for padding other instructions to certain
-alignments.
-@end deffn
-
-@deffn Instruction halt
-Exits the VM, returning a SCM value. Normally, this instruction is
-only part of the ``bootstrap program'', a program run when a virtual
-machine is first entered; compiled Scheme procedures will not contain
-this instruction.
-
-If multiple values have been returned, the SCM value will be a
-multiple-values object (@pxref{Multiple Values}).
-@end deffn
-
-@deffn Instruction break
-Does nothing, but invokes the break hook.
-@end deffn
-
-@deffn Instruction drop
-Pops off the top value from the stack, throwing it away.
-@end deffn
-
-@deffn Instruction dup
-Re-pushes the top value onto the stack.
-@end deffn
-
-@deffn Instruction void
-Pushes ``the unspecified value'' onto the stack.
-@end deffn
-
-@node Inlined Scheme Instructions
-@subsubsection Inlined Scheme Instructions
-
-The Scheme compiler can recognize the application of standard Scheme
-procedures. It tries to inline these small operations to avoid the
-overhead of creating new stack frames.
-
-Since most of these operations are historically implemented as C
-primitives, not inlining them would entail constantly calling out from
-the VM to the interpreter, which has some costs---registers must be
-saved, the interpreter has to dispatch, called procedures have to do
-much type checking, etc. It's much more efficient to inline these
-operations in the virtual machine itself.
-
-All of these instructions pop their arguments from the stack and push
-their results, and take no parameters from the instruction stream.
-Thus, unlike in the previous sections, these instruction definitions
-show stack parameters instead of parameters from the instruction
-stream.
-
-@deffn Instruction not x
-@deffnx Instruction not-not x
-@deffnx Instruction eq? x y
-@deffnx Instruction not-eq? x y
-@deffnx Instruction null?
-@deffnx Instruction not-null?
-@deffnx Instruction eqv? x y
-@deffnx Instruction equal? x y
-@deffnx Instruction pair? x y
-@deffnx Instruction list? x
-@deffnx Instruction set-car! pair x
-@deffnx Instruction set-cdr! pair x
-@deffnx Instruction cons x y
-@deffnx Instruction car x
-@deffnx Instruction cdr x
-@deffnx Instruction vector-ref x y
-@deffnx Instruction vector-set x n y
-@deffnx Instruction struct? x
-@deffnx Instruction struct-ref x n
-@deffnx Instruction struct-set x n v
-@deffnx Instruction struct-vtable x
-@deffnx Instruction class-of x
-@deffnx Instruction slot-ref struct n
-@deffnx Instruction slot-set struct n x
-Inlined implementations of their Scheme equivalents.
-@end deffn
-
-Note that @code{caddr} and friends compile to a series of @code{car}
-and @code{cdr} instructions.
-
-@node Inlined Mathematical Instructions
-@subsubsection Inlined Mathematical Instructions
-
-Inlining mathematical operations has the obvious advantage of handling
-fixnums without function calls or allocations. The trick, of course,
-is knowing when the result of an operation will be a fixnum, and there
-might be a couple bugs here.
-
-More instructions could be added here over time.
-
-As in the previous section, the definitions below show stack
-parameters instead of instruction stream parameters.
-
-@deffn Instruction add x y
-@deffnx Instruction add1 x
-@deffnx Instruction sub x y
-@deffnx Instruction sub1 x
-@deffnx Instruction mul x y
-@deffnx Instruction div x y
-@deffnx Instruction quo x y
-@deffnx Instruction rem x y
-@deffnx Instruction mod x y
-@deffnx Instruction ee? x y
-@deffnx Instruction lt? x y
-@deffnx Instruction gt? x y
-@deffnx Instruction le? x y
-@deffnx Instruction ge? x y
-@deffnx Instruction ash x n
-@deffnx Instruction logand x y
-@deffnx Instruction logior x y
-@deffnx Instruction logxor x y
-Inlined implementations of the corresponding mathematical operations.
-@end deffn
-
-@node Inlined Bytevector Instructions
-@subsubsection Inlined Bytevector Instructions
-
-Bytevector operations correspond closely to what the current hardware
-can do, so it makes sense to inline them to VM instructions, providing
-a clear path for eventual native compilation. Without this, Scheme
-programs would need other primitives for accessing raw bytes -- but
-these primitives are as good as any.
-
-As in the previous section, the definitions below show stack
-parameters instead of instruction stream parameters.
-
-The multibyte formats (@code{u16}, @code{f64}, etc) take an extra
-endianness argument. Only aligned native accesses are currently
-fast-pathed in Guile's VM.
-
-@deffn Instruction bv-u8-ref bv n
-@deffnx Instruction bv-s8-ref bv n
-@deffnx Instruction bv-u16-native-ref bv n
-@deffnx Instruction bv-s16-native-ref bv n
-@deffnx Instruction bv-u32-native-ref bv n
-@deffnx Instruction bv-s32-native-ref bv n
-@deffnx Instruction bv-u64-native-ref bv n
-@deffnx Instruction bv-s64-native-ref bv n
-@deffnx Instruction bv-f32-native-ref bv n
-@deffnx Instruction bv-f64-native-ref bv n
-@deffnx Instruction bv-u16-ref bv n endianness
-@deffnx Instruction bv-s16-ref bv n endianness
-@deffnx Instruction bv-u32-ref bv n endianness
-@deffnx Instruction bv-s32-ref bv n endianness
-@deffnx Instruction bv-u64-ref bv n endianness
-@deffnx Instruction bv-s64-ref bv n endianness
-@deffnx Instruction bv-f32-ref bv n endianness
-@deffnx Instruction bv-f64-ref bv n endianness
-@deffnx Instruction bv-u8-set bv n val
-@deffnx Instruction bv-s8-set bv n val
-@deffnx Instruction bv-u16-native-set bv n val
-@deffnx Instruction bv-s16-native-set bv n val
-@deffnx Instruction bv-u32-native-set bv n val
-@deffnx Instruction bv-s32-native-set bv n val
-@deffnx Instruction bv-u64-native-set bv n val
-@deffnx Instruction bv-s64-native-set bv n val
-@deffnx Instruction bv-f32-native-set bv n val
-@deffnx Instruction bv-f64-native-set bv n val
-@deffnx Instruction bv-u16-set bv n val endianness
-@deffnx Instruction bv-s16-set bv n val endianness
-@deffnx Instruction bv-u32-set bv n val endianness
-@deffnx Instruction bv-s32-set bv n val endianness
-@deffnx Instruction bv-u64-set bv n val endianness
-@deffnx Instruction bv-s64-set bv n val endianness
-@deffnx Instruction bv-f32-set bv n val endianness
-@deffnx Instruction bv-f64-set bv n val endianness
-Inlined implementations of the corresponding bytevector operations.
-@end deffn
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 2008,2009,2010,2011,2013
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node A Virtual Machine for Guile
+@section A Virtual Machine for Guile
+
+Guile has both an interpreter and a compiler. To a user, the difference
+is transparent---interpreted and compiled procedures can call each other
+as they please.
+
+The difference is that the compiler creates and interprets bytecode
+for a custom virtual machine, instead of interpreting the
+S-expressions directly. Loading and running compiled code is faster
+than loading and running source code.
+
+The virtual machine that does the bytecode interpretation is a part of
+Guile itself. This section describes the nature of Guile's virtual
+machine.
+
+@menu
+* Why a VM?::
+* VM Concepts::
+* Stack Layout::
+* Variables and the VM::
+* VM Programs::
+* Object File Format::
+* Instruction Set::
+@end menu
+
+@node Why a VM?
+@subsection Why a VM?
+
+@cindex interpreter
+For a long time, Guile only had an interpreter. Guile's interpreter
+operated directly on the S-expression representation of Scheme source
+code.
+
+But while the interpreter was highly optimized and hand-tuned, it still
+performed many needless computations during the course of evaluating an
+expression. For example, application of a function to arguments
+needlessly consed up the arguments in a list. Evaluation of an
+expression always had to figure out what the car of the expression is --
+a procedure, a memoized form, or something else. All values have to be
+allocated on the heap. Et cetera.
+
+The solution to this problem was to compile the higher-level language,
+Scheme, into a lower-level language for which all of the checks and
+dispatching have already been done---the code is instead stripped to
+the bare minimum needed to ``do the job''.
+
+The question becomes then, what low-level language to choose? There
+are many options. We could compile to native code directly, but that
+poses portability problems for Guile, as it is a highly cross-platform
+project.
+
+So we want the performance gains that compilation provides, but we
+also want to maintain the portability benefits of a single code path.
+The obvious solution is to compile to a virtual machine that is
+present on all Guile installations.
+
+The easiest (and most fun) way to depend on a virtual machine is to
+implement the virtual machine within Guile itself. This way the
+virtual machine provides what Scheme needs (tail calls, multiple
+values, @code{call/cc}) and can provide optimized inline instructions
+for Guile (@code{cons}, @code{struct-ref}, etc.).
+
+So this is what Guile does. The rest of this section describes that VM
+that Guile implements, and the compiled procedures that run on it.
+
+Before moving on, though, we should note that though we spoke of the
+interpreter in the past tense, Guile still has an interpreter. The
+difference is that before, it was Guile's main evaluator, and so was
+implemented in highly optimized C; now, it is actually implemented in
+Scheme, and compiled down to VM bytecode, just like any other program.
+(There is still a C interpreter around, used to bootstrap the compiler,
+but it is not normally used at runtime.)
+
+The upside of implementing the interpreter in Scheme is that we preserve
+tail calls and multiple-value handling between interpreted and compiled
+code. The downside is that the interpreter in Guile 2.2 is still slower
+than the interpreter in 1.8. We hope the that the compiler's speed makes
+up for the loss. In any case, once we have native compilation for
+Scheme code, we expect the new self-hosted interpreter to beat the old
+hand-tuned C implementation.
+
+Also note that this decision to implement a bytecode compiler does not
+preclude native compilation. We can compile from bytecode to native
+code at runtime, or even do ahead of time compilation. More
+possibilities are discussed in @ref{Extending the Compiler}.
+
+@node VM Concepts
+@subsection VM Concepts
+
+Compiled code is run by a virtual machine (VM). Each thread has its own
+VM. The virtual machine executes the sequence of instructions in a
+procedure.
+
+Each VM instruction starts by indicating which operation it is, and then
+follows by encoding its source and destination operands. Each procedure
+declares that it has some number of local variables, including the
+function arguments. These local variables form the available operands
+of the procedure, and are accessed by index.
+
+The local variables for a procedure are stored on a stack. Calling a
+procedure typically enlarges the stack, and returning from a procedure
+shrinks it. Stack memory is exclusive to the virtual machine that owns
+it.
+
+In addition to their stacks, virtual machines also have access to the
+global memory (modules, global bindings, etc) that is shared among other
+parts of Guile, including other VMs.
+
+The registers that a VM has are as follows:
+
+@itemize
+@item ip - Instruction pointer
+@item sp - Stack pointer
+@item fp - Frame pointer
+@end itemize
+
+In other architectures, the instruction pointer is sometimes called the
+``program counter'' (pc). This set of registers is pretty typical for
+virtual machines; their exact meanings in the context of Guile's VM are
+described in the next section.
+
+@node Stack Layout
+@subsection Stack Layout
+
+The stack of Guile's virtual machine is composed of @dfn{frames}. Each
+frame corresponds to the application of one compiled procedure, and
+contains storage space for arguments, local variables, and some
+bookkeeping information (such as what to do after the frame is
+finished).
+
+While the compiler is free to do whatever it wants to, as long as the
+semantics of a computation are preserved, in practice every time you
+call a function, a new frame is created. (The notable exception of
+course is the tail call case, @pxref{Tail Calls}.)
+
+The structure of the top stack frame is as follows:
+
+@example
+ /------------------\ <- top of stack
+ | Local N-1 | <- sp
+ | ... |
+ | Local 1 |
+ | Local 0 | <- fp = SCM_FRAME_LOCALS_ADDRESS (fp)
+ +==================+
+ | Return address |
+ | Dynamic link | <- fp - 2 = SCM_FRAME_LOWER_ADDRESS (fp)
+ +==================+
+ | | <- fp - 3 = SCM_FRAME_PREVIOUS_SP (fp)
+@end example
+
+In the above drawing, the stack grows upward. Usually the procedure
+being applied is in local 0, followed by the arguments from local 1.
+After that are enough slots to store the various lexically-bound and
+temporary values that are needed in the function's application.
+
+The @dfn{return address} is the @code{ip} that was in effect before this
+program was applied. When we return from this activation frame, we will
+jump back to this @code{ip}. Likewise, the @dfn{dynamic link} is the
+@code{fp} in effect before this program was applied.
+
+To prepare for a non-tail application, Guile's VM will emit code that
+shuffles the function to apply and its arguments into appropriate stack
+slots, with two free slots below them. The call then initializes those
+free slots with the current @code{ip} and @code{fp}, and updates
+@code{ip} to point to the function entry, and @code{fp} to point to the
+new call frame.
+
+In this way, the dynamic link links the current frame to the previous
+frame. Computing a stack trace involves traversing these frames.
+
+@node Variables and the VM
+@subsection Variables and the VM
+
+Consider the following Scheme code as an example:
+
+@example
+ (define (foo a)
+ (lambda (b) (list foo a b)))
+@end example
+
+Within the lambda expression, @code{foo} is a top-level variable,
+@code{a} is a lexically captured variable, and @code{b} is a local
+variable.
+
+Another way to refer to @code{a} and @code{b} is to say that @code{a} is
+a ``free'' variable, since it is not defined within the lambda, and
+@code{b} is a ``bound'' variable. These are the terms used in the
+@dfn{lambda calculus}, a mathematical notation for describing functions.
+The lambda calculus is useful because it is a language in which to
+reason precisely about functions and variables. It is especially good
+at describing scope relations, and it is for that reason that we mention
+it here.
+
+Guile allocates all variables on the stack. When a lexically enclosed
+procedure with free variables---a @dfn{closure}---is created, it copies
+those variables into its free variable vector. References to free
+variables are then redirected through the free variable vector.
+
+If a variable is ever @code{set!}, however, it will need to be
+heap-allocated instead of stack-allocated, so that different closures
+that capture the same variable can see the same value. Also, this
+allows continuations to capture a reference to the variable, instead
+of to its value at one point in time. For these reasons, @code{set!}
+variables are allocated in ``boxes''---actually, in variable cells.
+@xref{Variables}, for more information. References to @code{set!}
+variables are indirected through the boxes.
+
+Thus perhaps counterintuitively, what would seem ``closer to the
+metal'', viz @code{set!}, actually forces an extra memory allocation
+and indirection.
+
+Going back to our example, @code{b} may be allocated on the stack, as
+it is never mutated.
+
+@code{a} may also be allocated on the stack, as it too is never
+mutated. Within the enclosed lambda, its value will be copied into
+(and referenced from) the free variables vector.
+
+@code{foo} is a top-level variable, because @code{foo} is not
+lexically bound in this example.
+
+@node VM Programs
+@subsection Compiled Procedures are VM Programs
+
+By default, when you enter in expressions at Guile's REPL, they are
+first compiled to bytecode. Then that bytecode is executed to produce a
+value. If the expression evaluates to a procedure, the result of this
+process is a compiled procedure.
+
+A compiled procedure is a compound object consisting of its bytecode and
+a reference to any captured lexical variables. In addition, when a
+procedure is compiled, it has associated metadata written to side
+tables, for instance a line number mapping, or its docstring. You can
+pick apart these pieces with the accessors in @code{(system vm
+program)}. @xref{Compiled Procedures}, for a full API reference.
+
+A procedure may reference data that was statically allocated when the
+procedure was compiled. For example, a pair of immediate objects
+(@pxref{Immediate objects}) can be allocated directly in the memory
+segment that contains the compiled bytecode, and accessed directly by
+the bytecode.
+
+Another use for statically allocated data is to serve as a cache for a
+bytecode. Top-level variable lookups are handled in this way. If the
+@code{toplevel-box} instruction finds that it does not have a cached
+variable for a top-level reference, it accesses other static data to
+resolve the reference, and fills in the cache slot. Thereafter all
+access to the variable goes through the cache cell. The variable's
+value may change in the future, but the variable itself will not.
+
+We can see how these concepts tie together by disassembling the
+@code{foo} function we defined earlier to see what is going on:
+
+@smallexample
+scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b)))
+scheme@@(guile-user)> ,x foo
+Disassembly of #<procedure foo (a)> at #x203be34:
+
+ 0 (assert-nargs-ee/locals 2 1) ;; 1 arg, 1 local at (unknown file):1:0
+ 1 (make-closure 2 6 1) ;; anonymous procedure at #x203be50 (1 free var)
+ 4 (free-set! 2 1 0) ;; free var 0
+ 6 (return 2)
+
+----------------------------------------
+Disassembly of anonymous procedure at #x203be50:
+
+ 0 (assert-nargs-ee/locals 2 3) ;; 1 arg, 3 locals at (unknown file):1:0
+ 1 (toplevel-box 2 73 57 71 #t) ;; `foo'
+ 6 (box-ref 2 2)
+ 7 (make-short-immediate 3 772) ;; ()
+ 8 (cons 3 1 3)
+ 9 (free-ref 4 0 0) ;; free var 0
+ 11 (cons 3 4 3)
+ 12 (cons 2 2 3)
+ 13 (return 2)
+@end smallexample
+
+First there's some prelude, where @code{foo} checks that it was called
+with only 1 argument. Then at @code{ip} 1, we allocate a new closure
+and store it in slot 2. The `6' in the @code{(make-closure 2 6 1)} is a
+relative offset from the instruction pointer of the code for the
+closure.
+
+A closure is code with data. We already have the code part initialized;
+what remains is to set the data. @code{Ip} 4 initializes free variable
+0 in the new closure with the value from local variable 1, which
+corresponds to the first argument of @code{foo}: `a'. Finally we return
+the closure.
+
+The second stanza disassembles the code for the closure. After the
+prelude, we load the variable for the toplevel variable @code{foo} into
+local variable 2. This lookup occurs lazily, the first time the
+variable is actually referenced, and the location of the lookup is
+cached so that future references are very cheap. @xref{Top-Level
+Environment Instructions}, for more details. The @code{box-ref}
+dereferences the variable cell, replacing the contents of local 2.
+
+What follows is a sequence of conses to build up the result list.
+@code{Ip} 7 makes the tail of the list. @code{Ip} 8 conses on the value
+in local 1, corresponding to the first argument to the closure: `b'.
+@code{Ip} 9 loads free variable 0 of local 0 -- the procedure being
+called -- into slot 4, then @code{ip} 11 conses it onto the list.
+Finally we cons local 2, containing the @code{foo} toplevel, onto the
+front of the list, and we return it.
+
+
+@node Object File Format
+@subsection Object File Format
+
+To compile a file to disk, we need a format in which to write the
+compiled code to disk, and later load it into Guile. A good @dfn{object
+file format} has a number of characteristics:
+
+@itemize
+@item Above all else, it should be very cheap to load a compiled file.
+@item It should be possible to statically allocate constants in the
+file. For example, a bytevector literal in source code can be emitted
+directly into the object file.
+@item The compiled file should enable maximum code and data sharing
+between different processes.
+@item The compiled file should contain debugging information, such as
+line numbers, but that information should be separated from the code
+itself. It should be possible to strip debugging information if space
+is tight.
+@end itemize
+
+These characteristics are not specific to Scheme. Indeed, mainstream
+languages like C and C++ have solved this issue many times in the past.
+Guile builds on their work by adopting ELF, the object file format of
+GNU and other Unix-like systems, as its object file format. Although
+Guile uses ELF on all platforms, we do not use platform support for ELF.
+Guile implements its own linker and loader. The advantage of using ELF
+is not sharing code, but sharing ideas. ELF is simply a well-designed
+object file format.
+
+An ELF file has two meta-tables describing its contents. The first
+meta-table is for the loader, and is called the @dfn{program table} or
+sometimes the @dfn{segment table}. The program table divides the file
+into big chunks that should be treated differently by the loader.
+Mostly the difference between these @dfn{segments} is their
+permissions.
+
+Typically all segments of an ELF file are marked as read-only, except
+that part that represents modifiable static data or static data that
+needs load-time initialization. Loading an ELF file is as simple as
+mmapping the thing into memory with read-only permissions, then using
+the segment table to mark a small sub-region of the file as writable.
+This writable section is typically added to the root set of the garbage
+collector as well.
+
+One ELF segment is marked as ``dynamic'', meaning that it has data of
+interest to the loader. Guile uses this segment to record the Guile
+version corresponding to this file. There is also an entry in the
+dynamic segment that points to the address of an initialization thunk
+that is run to perform any needed link-time initialization. (This is
+like dynamic relocations for normal ELF shared objects, except that we
+compile the relocations as a procedure instead of having the loader
+interpret a table of relocations.) Finally, the dynamic segment marks
+the location of the ``entry thunk'' of the object file. This thunk is
+returned to the caller of @code{load-thunk-from-memory} or
+@code{load-thunk-from-file}. When called, it will execute the ``body''
+of the compiled expression.
+
+The other meta-table in an ELF file is the @dfn{section table}. Whereas
+the program table divides an ELF file into big chunks for the loader,
+the section table specifies small sections for use by introspective
+tools like debuggers or the like. One segment (program table entry)
+typically contains many sections. There may be sections outside of any
+segment, as well.
+
+Typical sections in a Guile @code{.go} file include:
+
+@table @code
+@item .rtl-text
+Bytecode.
+@item .data
+Data that needs initialization, or which may be modified at runtime.
+@item .rodata
+Statically allocated data that needs no run-time initialization, and
+which therefore can be shared between processes.
+@item .dynamic
+The dynamic section, discussed above.
+@item .symtab
+@itemx .strtab
+A table mapping addresses in the @code{.rtl-text} to procedure names.
+@code{.strtab} is used by @code{.symtab}.
+@item .guile.procprops
+@itemx .guile.arities
+@itemx .guile.arities.strtab
+@itemx .guile.docstrs
+@itemx .guile.docstrs.strtab
+Side tables of procedure properties, arities, and docstrings.
+@item .debug_info
+@itemx .debug_abbrev
+@itemx .debug_str
+@itemx .debug_loc
+@itemx .debug_line
+Debugging information, in DWARF format. See the DWARF specification,
+for more information.
+@item .shstrtab
+Section name string table.
+@end table
+
+For more information, see @uref{http://linux.die.net/man/5/elf,,the
+elf(5) man page}. See @uref{http://dwarfstd.org/,the DWARF
+specification} for more on the DWARF debugging format. Or if you are an
+adventurous explorer, try running @code{readelf} or @code{objdump} on
+compiled @code{.go} files. It's good times!
+
+
+@node Instruction Set
+@subsection Instruction Set
+
+There are currently about 130 instructions in Guile's virtual machine.
+These instructions represent atomic units of a program's execution.
+Ideally, they perform one task without conditional branches, then
+dispatch to the next instruction in the stream.
+
+Instructions themselves are composed of 1 or more 32-bit units. The low
+8 bits of the first word indicate the opcode, and the rest of
+instruction describe the operands. There are a number of different ways
+operands can be encoded.
+
+@table @code
+@item u@var{n}
+An unsigned @var{n}-bit integer. Usually indicates the index of a local
+variable, but some instructions interpret these operands as immediate
+values.
+@item l24
+An offset from the current @code{ip}, in 32-bit units, as a signed
+24-bit value. Indicates a bytecode address, for a relative jump.
+@item i16
+@itemx i32
+An immediate Scheme value (@pxref{Immediate objects}), encoded directly
+in 16 or 32 bits.
+@item a32
+@itemx b32
+An immediate Scheme value, encoded as a pair of 32-bit words.
+@code{a32} and @code{b32} values always go together on the same opcode,
+and indicate the high and low bits, respectively. Normally only used on
+64-bit systems.
+@item n32
+A statically allocated non-immediate. The address of the non-immediate
+is encoded as a signed 32-bit integer, and indicates a relative offset
+in 32-bit units. Think of it as @code{SCM x = ip + offset}.
+@item s32
+Indirect scheme value, like @code{n32} but indirected. Think of it as
+@code{SCM *x = ip + offset}.
+@item l32
+@item lo32
+An ip-relative address, as a signed 32-bit integer. Could indicate a
+bytecode address, as in @code{make-closure}, or a non-immediate address,
+as with @code{static-patch!}.
+
+@code{l32} and @code{lo32} are the same from the perspective of the
+virtual machine. The difference is that an assembler might want to
+allow an @code{lo32} address to be specified as a label and then some
+number of words offset from that label, for example when patching a
+field of a statically allocated object.
+@item b1
+A boolean value: 1 for true, otherwise 0.
+@item x@var{n}
+An ignored sequence of @var{n} bits.
+@end table
+
+An instruction is specified by giving its name, then describing its
+operands. The operands are packed by 32-bit words, with earlier
+operands occupying the lower bits.
+
+For example, consider the following instruction specification:
+
+@deftypefn Instruction {} free-set! u12:@var{dst} u12:@var{src} x8:@var{_} u24:@var{idx}
+Set free variable @var{idx} from the closure @var{dst} to @var{src}.
+@end deftypefn
+
+The first word in the instruction will start with the 8-bit value
+corresponding to the @var{free-set!} opcode in the low bits, followed by
+@var{dst} and @var{src} as 12-bit values. The second word starts with 8
+dead bits, followed by the index as a 24-bit immediate value.
+
+Sometimes the compiler can figure out that it is compiling a special
+case that can be run more efficiently. So, for example, while Guile
+offers a generic test-and-branch instruction, it also offers specific
+instructions for special cases, so that the following cases all have
+their own test-and-branch instructions:
+
+@example
+(if pred then else)
+(if (not pred) then else)
+(if (null? l) then else)
+(if (not (null? l)) then else)
+@end example
+
+In addition, some Scheme primitives have their own inline
+implementations. For example, in the previous section we saw
+@code{cons}.
+
+Guile's instruction set is a @emph{complete} instruction set, in that it
+provides the instructions that are suited to the problem, and is not
+concerned with making a minimal, orthogonal set of instructions. More
+instructions may be added over time.
+
+@menu
+* Lexical Environment Instructions::
+* Top-Level Environment Instructions::
+* Procedure Call and Return Instructions::
+* Function Prologue Instructions::
+* Trampoline Instructions::
+* Branch Instructions::
+* Constant Instructions::
+* Dynamic Environment Instructions::
+* Miscellaneous Instructions::
+* Inlined Scheme Instructions::
+* Inlined Mathematical Instructions::
+* Inlined Bytevector Instructions::
+@end menu
+
+
+@node Lexical Environment Instructions
+@subsubsection Lexical Environment Instructions
+
+These instructions access and mutate the lexical environment of a
+compiled procedure---its free and bound variables. @xref{Stack Layout},
+for more information on the format of stack frames.
+
+@deftypefn Instruction {} mov u12:@var{dst} u12:@var{src}
+@deftypefnx Instruction {} long-mov u24:@var{dst} x8:@var{_} u24:@var{src}
+Copy a value from one local slot to another.
+
+As discussed previously, procedure arguments and local variables are
+allocated to local slots. Guile's compiler tries to avoid shuffling
+variables around to different slots, which often makes @code{mov}
+instructions redundant. However there are some cases in which shuffling
+is necessary, and in those cases, @code{mov} is the thing to use.
+@end deftypefn
+
+@deftypefn Instruction {} make-closure u24:@var{dst} l32:@var{offset} x8:@var{_} u24:@var{nfree}
+Make a new closure, and write it to @var{dst}. The code for the closure
+will be found at @var{offset} words from the current @code{ip}.
+@var{offset} is a signed 32-bit integer. Space for @var{nfree} free
+variables will be allocated.
+
+The size of a closure is currently two words, plus one word per free
+variable.
+@end deftypefn
+
+@deftypefn Instruction {} free-ref u12:@var{dst} u12:@var{src} x8:@var{_} u24:@var{idx}
+Load free variable @var{idx} from the closure @var{src} into local slot
+@var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} free-set! u12:@var{dst} u12:@var{src} x8:@var{_} u24:@var{idx}
+Set free variable @var{idx} from the closure @var{dst} to @var{src}.
+
+This instruction is usually used when initializing a closure's free
+variables, but not to mutate free variables, as variables that are
+assigned are boxed.
+@end deftypefn
+
+Recall that variables that are assigned are usually allocated in boxes,
+so that continuations and closures can capture their identity and not
+their value at one point in time. Variables are also used in the
+implementation of top-level bindings; see the next section for more
+information.
+
+@deftypefn Instruction {} box u12:@var{dst} u12:@var{src}
+Create a new variable holding @var{src}, and place it in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} box-ref u12:@var{dst} u12:@var{src}
+Unpack the variable at @var{src} into @var{dst}, asserting that the
+variable is actually bound.
+@end deftypefn
+
+@deftypefn Instruction {} box-set! u12:@var{dst} u12:@var{src}
+Set the contents of the variable at @var{dst} to @var{set}.
+@end deftypefn
+
+
+@node Top-Level Environment Instructions
+@subsubsection Top-Level Environment Instructions
+
+These instructions access values in the top-level environment: bindings
+that were not lexically apparent at the time that the code in question
+was compiled.
+
+The location in which a toplevel binding is stored can be looked up once
+and cached for later. The binding itself may change over time, but its
+location will stay constant.
+
+@deftypefn Instruction {} current-module u24:@var{dst}
+Store the current module in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} resolve u24:@var{dst} b1:@var{bound?} x7:@var{_} u24:@var{sym}
+Resolve @var{sym} in the current module, and place the resulting
+variable in @var{dst}. An error will be signalled if no variable is
+found. If @var{bound?} is true, an error will be signalled if the
+variable is unbound.
+@end deftypefn
+
+@deftypefn Instruction {} define! u12:@var{sym} u12:@var{val}
+Look up a binding for @var{sym} in the current module, creating it if
+necessary. Set its value to @var{val}.
+@end deftypefn
+
+@deftypefn Instruction {} toplevel-box u24:@var{dst} s32:@var{var-offset} s32:@var{mod-offset} n32:@var{sym-offset} b1:@var{bound?} x31:@var{_}
+Load a value. The value will be fetched from memory, @var{var-offset}
+32-bit words away from the current instruction pointer.
+@var{var-offset} is a signed value. Up to here, @code{toplevel-box} is
+like @code{static-ref}.
+
+Then, if the loaded value is a variable, it is placed in @var{dst}, and
+control flow continues.
+
+Otherwise, we have to resolve the variable. In that case we load the
+module from @var{mod-offset}, just as we loaded the variable. Usually
+the module gets set when the closure is created. @var{sym-offset}
+specifies the name, as an offset to a symbol.
+
+We use the module and the symbol to resolve the variable, placing it in
+@var{dst}, and caching the resolved variable so that we will hit the
+cache next time. If @var{bound?} is true, an error will be signalled if
+the variable is unbound.
+@end deftypefn
+
+@deftypefn Instruction {} module-box u24:@var{dst} s32:@var{var-offset} n32:@var{mod-offset} n32:@var{sym-offset} b1:@var{bound?} x31:@var{_}
+Like @code{toplevel-box}, except @var{mod-offset} points at a module
+identifier instead of the module itself. A module identifier is a
+module name, as a list, prefixed by a boolean. If the prefix is true,
+then the variable is resolved relative to the module's public interface
+instead of its private interface.
+@end deftypefn
+
+
+@node Procedure Call and Return Instructions
+@subsubsection Procedure Call and Return Instructions
+
+As described earlier (@pxref{Stack Layout}), Guile's calling convention
+is that arguments are passed and values returned on the stack.
+
+For calls, both in tail position and in non-tail position, we require
+that the procedure and the arguments already be shuffled into place
+befor the call instruction. ``Into place'' for a tail call means that
+the procedure should be in slot 0, and the arguments should follow. For
+a non-tail call, if the procedure is in slot @var{n}, the arguments
+should follow from slot @var{n}+1, and there should be two free slots at
+@var{n}-1 and @var{n}-2 in which to save the @code{ip} and @code{fp}.
+
+Returning values is similar. Multiple-value returns should have values
+already shuffled down to start from slot 1 before emitting
+@code{return-values}. There is a short-cut in the single-value case, in
+that @code{return} handles the trivial shuffling itself. We start from
+slot 1 instead of slot 0 to make tail calls to @code{values} trivial.
+
+In both calls and returns, the @code{sp} is used to indicate to the
+callee or caller the number of arguments or return values, respectively.
+After receiving return values, it is the caller's responsibility to
+@dfn{restore the frame} by resetting the @code{sp} to its former value.
+
+@deftypefn Instruction {} call u24:@var{proc} x8:@var{_} u24:@var{nlocals}
+Call a procedure. @var{proc} is the local corresponding to a procedure.
+The two values below @var{proc} will be overwritten by the saved call
+frame data. The new frame will have space for @var{nlocals} locals: one
+for the procedure, and the rest for the arguments which should already
+have been pushed on.
+
+When the call returns, execution proceeds with the next instruction.
+There may be any number of values on the return stack; the precise
+number can be had by subtracting the address of @var{proc} from the
+post-call @code{sp}.
+@end deftypefn
+
+@deftypefn Instruction {} tail-call u24:@var{nlocals}
+Tail-call a procedure. Requires that the procedure and all of the
+arguments have already been shuffled into position. Will reset the
+frame to @var{nlocals}.
+@end deftypefn
+
+@deftypefn Instruction {} tail-call/shuffle u24:@var{from}
+Tail-call a procedure. The procedure should already be set to slot 0.
+The rest of the args are taken from the frame, starting at @var{from},
+shuffled down to start at slot 0. This is part of the implementation of
+the @code{call-with-values} builtin.
+@end deftypefn
+
+@deftypefn Instruction {} receive u12:@var{dst} u12:@var{proc} x8:@var{_} u24:@var{nlocals}
+Receive a single return value from a call whose procedure was in
+@var{proc}, asserting that the call actually returned at least one
+value. Afterwards, resets the frame to @var{nlocals} locals.
+@end deftypefn
+
+@deftypefn Instruction {} receive-values u24:@var{proc} b1:@var{allow-extra?} x7:@var{_} u24:@var{nvalues}
+Receive a return of multiple values from a call whose procedure was in
+@var{proc}. If fewer than @var{nvalues} values were returned, signal an
+error. Unless @var{allow-extra?} is true, require that the number of
+return values equals @var{nvalues} exactly. After @code{receive-values}
+has run, the values can be copied down via @code{mov}, or used in place.
+@end deftypefn
+
+@deftypefn Instruction {} return u24:@var{src}
+Return a value.
+@end deftypefn
+
+@deftypefn Instruction {} return-values x24:@var{_}
+Return a number of values from a call frame. This opcode corresponds to
+an application of @code{values} in tail position. As with tail calls,
+we expect that the values have already been shuffled down to a
+contiguous array starting at slot 1. We also expect the frame has
+already been reset.
+@end deftypefn
+
+@deftypefn Instruction {} call/cc x24:@var{_}
+Capture the current continuation, and tail-apply the procedure in local
+slot 1 to it. This instruction is part of the implementation of
+@code{call/cc}, and is not generated by the compiler.
+@end deftypefn
+
+
+@node Function Prologue Instructions
+@subsubsection Function Prologue Instructions
+
+A function call in Guile is very cheap: the VM simply hands control to
+the procedure. The procedure itself is responsible for asserting that it
+has been passed an appropriate number of arguments. This strategy allows
+arbitrarily complex argument parsing idioms to be developed, without
+harming the common case.
+
+For example, only calls to keyword-argument procedures ``pay'' for the
+cost of parsing keyword arguments. (At the time of this writing, calling
+procedures with keyword arguments is typically two to four times as
+costly as calling procedures with a fixed set of arguments.)
+
+@deftypefn Instruction {} assert-nargs-ee u24:@var{expected}
+@deftypefnx Instruction {} assert-nargs-ge u24:@var{expected}
+@deftypefnx Instruction {} assert-nargs-le u24:@var{expected}
+If the number of actual arguments is not @code{==}, @code{>=}, or
+@code{<=} @var{expected}, respectively, signal an error.
+
+The number of arguments is determined by subtracting the frame pointer
+from the stack pointer (@code{sp + 1 - fp}). @xref{Stack Layout}, for
+more details on stack frames. Note that @var{expected} includes the
+procedure itself.
+@end deftypefn
+
+@deftypefn Instruction {} br-if-nargs-ne u24:@var{expected} x8:@var{_} l24:@var{offset}
+@deftypefnx Instruction {} br-if-nargs-lt u24:@var{expected} x8:@var{_} l24:@var{offset}
+@deftypefnx Instruction {} br-if-nargs-gt u24:@var{expected} x8:@var{_} l24:@var{offset}
+If the number of actual arguments is not equal, less than, or greater
+than @var{expected}, respectively, add @var{offset}, a signed 24-bit
+number, to the current instruction pointer. Note that @var{expected}
+includes the procedure itself.
+
+These instructions are used to implement multiple arities, as in
+@code{case-lambda}. @xref{Case-lambda}, for more information.
+@end deftypefn
+
+@deftypefn Instruction {} alloc-frame u24:@var{nlocals}
+Ensure that there is space on the stack for @var{nlocals} local
+variables, setting them all to @code{SCM_UNDEFINED}, except those values
+that are already on the stack.
+@end deftypefn
+
+@deftypefn Instruction {} reset-frame u24:@var{nlocals}
+Like @code{alloc-frame}, but doesn't check that the stack is big enough,
+and doesn't initialize values to @code{SCM_UNDEFINED}. Used to reset
+the frame size to something less than the size that was previously set
+via alloc-frame.
+@end deftypefn
+
+@deftypefn Instruction {} assert-nargs-ee/locals u12:@var{expected} u12:@var{nlocals}
+Equivalent to a sequence of @code{assert-nargs-ee} and
+@code{reserve-locals}. The number of locals reserved is @var{expected}
++ @var{nlocals}.
+@end deftypefn
+
+@deftypefn Instruction {} br-if-npos-gt u24:@var{nreq} x8:@var{_} u24:@var{npos} x8:@var{_} l24:@var{offset}
+Find the first positional argument after @var{nreq}. If it is greater
+than @var{npos}, jump to @var{offset}.
+
+This instruction is only emitted for functions with multiple clauses,
+and an earlier clause has keywords and no rest arguments.
+@xref{Case-lambda}, for more on how @code{case-lambda} chooses the
+clause to apply.
+@end deftypefn
+
+@deftypefn Instruction {} bind-kwargs u24:@var{nreq} u8:@var{flags} u24:@var{nreq-and-opt} x8:@var{_} u24:@var{ntotal} n32:@var{kw-offset}
+@var{flags} is a bitfield, whose lowest bit is @var{allow-other-keys},
+second bit is @var{has-rest}, and whose following six bits are unused.
+
+Find the last positional argument, and shuffle all the rest above
+@var{ntotal}. Initialize the intervening locals to
+@code{SCM_UNDEFINED}. Then load the constant at @var{kw-offset} words
+from the current @var{ip}, and use it and the @var{allow-other-keys}
+flag to bind keyword arguments. If @var{has-rest}, collect all shuffled
+arguments into a list, and store it in @var{nreq-and-opt}. Finally,
+clear the arguments that we shuffled up.
+
+The parsing is driven by a keyword arguments association list, looked up
+using @var{kw-offset}. The alist is a list of pairs of the form
+@code{(@var{kw} . @var{index})}, mapping keyword arguments to their
+local slot indices. Unless @code{allow-other-keys} is set, the parser
+will signal an error if an unknown key is found.
+
+A macro-mega-instruction.
+@end deftypefn
+
+@deftypefn Instruction {} bind-rest u24:@var{dst}
+Collect any arguments at or above @var{dst} into a list, and store that
+list at @var{dst}.
+@end deftypefn
+
+
+@node Trampoline Instructions
+@subsubsection Trampoline Instructions
+
+Though most applicable objects in Guile are procedures implemented in
+bytecode, not all are. There are primitives, continuations, and other
+procedure-like objects that have their own calling convention. Instead
+of adding special cases to the @code{call} instruction, Guile wraps
+these other applicable objects in VM trampoline procedures, then
+provides special support for these objects in bytecode.
+
+Trampoline procedures are typically generated by Guile at runtime, for
+example in response to a call to @code{scm_c_make_gsubr}. As such, a
+compiler probably shouldn't emit code with these instructions. However,
+it's still interesting to know how these things work, so we document
+these trampoline instructions here.
+
+@deftypefn Instruction {} subr-call u24:@var{ptr-idx}
+Call a subr, passing all locals in this frame as arguments. Fetch the
+foreign pointer from @var{ptr-idx}, a free variable. Return from the
+calling frame.
+@end deftypefn
+
+@deftypefn Instruction {} foreign-call u12:@var{cif-idx} u12:@var{ptr-idx}
+Call a foreign function. Fetch the @var{cif} and foreign pointer from
+@var{cif-idx} and @var{ptr-idx}, both free variables. Return from the calling
+frame. Arguments are taken from the stack.
+@end deftypefn
+
+@deftypefn Instruction {} continuation-call u24:@var{contregs}
+Return to a continuation, nonlocally. The arguments to the continuation
+are taken from the stack. @var{contregs} is a free variable containing
+the reified continuation.
+@end deftypefn
+
+@deftypefn Instruction {} compose-continuation u24:@var{cont}
+Compose a partial continution with the current continuation. The
+arguments to the continuation are taken from the stack. @var{cont} is a
+free variable containing the reified continuation.
+@end deftypefn
+
+@deftypefn Instruction {} tail-apply x24:@var{_}
+Tail-apply the procedure in local slot 0 to the rest of the arguments.
+This instruction is part of the implementation of @code{apply}, and is
+not generated by the compiler.
+@end deftypefn
+
+@deftypefn Instruction {} builtin-ref u12:@var{dst} u12:@var{idx}
+Load a builtin stub by index into @var{dst}.
+@end deftypefn
+
+
+@node Branch Instructions
+@subsubsection Branch Instructions
+
+All offsets to branch instructions are 24-bit signed numbers, which
+count 32-bit units. This gives Guile effectively a 26-bit address range
+for relative jumps.
+
+@deftypefn Instruction {} br l24:@var{offset}
+Add @var{offset} to the current instruction pointer.
+@end deftypefn
+
+All the conditional branch instructions described below have an
+@var{invert} parameter, which if true reverses the test:
+@code{br-if-true} becomes @code{br-if-false}, and so on.
+
+@deftypefn Instruction {} br-if-true u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset}
+If the value in @var{test} is true for the purposes of Scheme, add
+@var{offset} to the current instruction pointer.
+@end deftypefn
+
+@deftypefn Instruction {} br-if-null u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset}
+If the value in @var{test} is the end-of-list or Lisp nil, add
+@var{offset} to the current instruction pointer.
+@end deftypefn
+
+@deftypefn Instruction {} br-if-nil u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset}
+If the value in @var{test} is false to Lisp, add @var{offset} to the
+current instruction pointer.
+@end deftypefn
+
+@deftypefn Instruction {} br-if-pair u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset}
+If the value in @var{test} is a pair, add @var{offset} to the current
+instruction pointer.
+@end deftypefn
+
+@deftypefn Instruction {} br-if-struct u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset}
+If the value in @var{test} is a struct, add @var{offset} number to the
+current instruction pointer.
+@end deftypefn
+
+@deftypefn Instruction {} br-if-char u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset}
+If the value in @var{test} is a char, add @var{offset} to the current
+instruction pointer.
+@end deftypefn
+
+@deftypefn Instruction {} br-if-tc7 u24:@var{test} b1:@var{invert} u7:@var{tc7} l24:@var{offset}
+If the value in @var{test} has the TC7 given in the second word, add
+@var{offset} to the current instruction pointer. TC7 codes are part of
+the way Guile represents non-immediate objects, and are deep wizardry.
+See @code{libguile/tags.h} for all the details.
+@end deftypefn
+
+@deftypefn Instruction {} br-if-eq u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset}
+@deftypefnx Instruction {} br-if-eqv u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset}
+@deftypefnx Instruction {} br-if-equal u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset}
+If the value in @var{a} is @code{eq?}, @code{eqv?}, or @code{equal?} to
+the value in @var{b}, respectively, add @var{offset} to the current
+instruction pointer.
+@end deftypefn
+
+@deftypefn Instruction {} br-if-= u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset}
+@deftypefnx Instruction {} br-if-< u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset}
+@deftypefnx Instruction {} br-if-<= u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset}
+If the value in @var{a} is @code{=}, @code{<}, or @code{<=} to the value
+in @var{b}, respectively, add @var{offset} to the current instruction
+pointer.
+@end deftypefn
+
+
+@node Constant Instructions
+@subsubsection Constant Instructions
+
+The following instructions load literal data into a program. There are
+two kinds.
+
+The first set of instructions loads immediate values. These
+instructions encode the immediate directly into the instruction stream.
+
+@deftypefn Instruction {} make-short-immediate u8:@var{dst} i16:@var{low-bits}
+Make an immediate whose low bits are @var{low-bits}, and whose top bits are
+0.
+@end deftypefn
+
+@deftypefn Instruction {} make-long-immediate u24:@var{dst} i32:@var{low-bits}
+Make an immediate whose low bits are @var{low-bits}, and whose top bits are
+0.
+@end deftypefn
+
+@deftypefn Instruction {} make-long-long-immediate u24:@var{dst} a32:@var{high-bits} b32:@var{low-bits}
+Make an immediate with @var{high-bits} and @var{low-bits}.
+@end deftypefn
+
+Non-immediate constant literals are referenced either directly or
+indirectly. For example, Guile knows at compile-time what the layout of
+a string will be like, and arranges to embed that object directly in the
+compiled image. A reference to a string will use
+@code{make-non-immediate} to treat a pointer into the compilation unit
+as a @code{SCM} value directly.
+
+@deftypefn Instruction {} make-non-immediate u24:@var{dst} n32:@var{offset}
+Load a pointer to statically allocated memory into @var{dst}. The
+object's memory is will be found @var{offset} 32-bit words away from the
+current instruction pointer. Whether the object is mutable or immutable
+depends on where it was allocated by the compiler, and loaded by the
+loader.
+@end deftypefn
+
+Some objects must be unique across the whole system. This is the case
+for symbols and keywords. For these objects, Guile arranges to
+initialize them when the compilation unit is loaded, storing them into a
+slot in the image. References go indirectly through that slot.
+@code{static-ref} is used in this case.
+
+@deftypefn Instruction {} static-ref u24:@var{dst} s32:@var{offset}
+Load a @var{scm} value into @var{dst}. The @var{scm} value will be fetched from
+memory, @var{offset} 32-bit words away from the current instruction
+pointer. @var{offset} is a signed value.
+@end deftypefn
+
+Fields of non-immediates may need to be fixed up at load time, because
+we do not know in advance at what address they will be loaded. This is
+the case, for example, for a pair containing a non-immediate in one of
+its fields. @code{static-ref} and @code{static-patch!} are used in
+these situations.
+
+@deftypefn Instruction {} static-set! u24:@var{src} lo32:@var{offset}
+Store a @var{scm} value into memory, @var{offset} 32-bit words away from the
+current instruction pointer. @var{offset} is a signed value.
+@end deftypefn
+
+@deftypefn Instruction {} static-patch! x24:@var{_} lo32:@var{dst-offset} l32:@var{src-offset}
+Patch a pointer at @var{dst-offset} to point to @var{src-offset}. Both offsets
+are signed 32-bit values, indicating a memory address as a number
+of 32-bit words away from the current instruction pointer.
+@end deftypefn
+
+Many kinds of literals can be loaded with the above instructions, once
+the compiler has prepared the statically allocated data. This is the
+case for vectors, strings, uniform vectors, pairs, and procedures with
+no free variables. Other kinds of data might need special initializers;
+those instructions follow.
+
+@deftypefn Instruction {} string->number u12:@var{dst} u12:@var{src}
+Parse a string in @var{src} to a number, and store in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} string->symbol u12:@var{dst} u12:@var{src}
+Parse a string in @var{src} to a symbol, and store in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} symbol->keyword u12:@var{dst} u12:@var{src}
+Make a keyword from the symbol in @var{src}, and store it in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} load-typed-array u8:@var{dst} u8:@var{type} u8:@var{shape} n32:@var{offset} u32:@var{len}
+Load the contiguous typed array located at @var{offset} 32-bit words away
+from the instruction pointer, and store into @var{dst}. @var{len} is a byte
+length. @var{offset} is signed.
+@end deftypefn
+
+
+@node Dynamic Environment Instructions
+@subsubsection Dynamic Environment Instructions
+
+Guile's virtual machine has low-level support for @code{dynamic-wind},
+dynamic binding, and composable prompts and aborts.
+
+@deftypefn Instruction {} abort x24:@var{_}
+Abort to a prompt handler. The tag is expected in slot 1, and the rest
+of the values in the frame are returned to the prompt handler. This
+corresponds to a tail application of abort-to-prompt.
+
+If no prompt can be found in the dynamic environment with the given tag,
+an error is signalled. Otherwise all arguments are passed to the
+prompt's handler, along with the captured continuation, if necessary.
+
+If the prompt's handler can be proven to not reference the captured
+continuation, no continuation is allocated. This decision happens
+dynamically, at run-time; the general case is that the continuation may
+be captured, and thus resumed. A reinstated continuation will have its
+arguments pushed on the stack from slot 1, as if from a multiple-value
+return, and control resumes in the caller. Thus to the calling
+function, a call to @code{abort-to-prompt} looks like any other function
+call.
+@end deftypefn
+
+@deftypefn Instruction {} prompt u24:@var{tag} b1:@var{escape-only?} x7:@var{_} u24:@var{proc-slot} x8:@var{_} l24:@var{handler-offset}
+Push a new prompt on the dynamic stack, with a tag from @var{tag} and a
+handler at @var{handler-offset} words from the current @var{ip}.
+
+If an abort is made to this prompt, control will jump to the handler.
+The handler will expect a multiple-value return as if from a call with
+the procedure at @var{proc-slot}, with the reified partial continuation
+as the first argument, followed by the values returned to the handler.
+If control returns to the handler, the prompt is already popped off by
+the abort mechanism. (Guile's @code{prompt} implements Felleisen's
+@dfn{--F--} operator.)
+
+If @var{escape-only?} is nonzero, the prompt will be marked as
+escape-only, which allows an abort to this prompt to avoid reifying the
+continuation.
+
+@xref{Prompts}, for more information on prompts.
+@end deftypefn
+
+@deftypefn Instruction {} wind u12:@var{winder} u12:@var{unwinder}
+Push wind and unwind procedures onto the dynamic stack. Note that
+neither are actually called; the compiler should emit calls to wind and
+unwind for the normal dynamic-wind control flow. Also note that the
+compiler should have inserted checks that they wind and unwind procs are
+thunks, if it could not prove that to be the case. @xref{Dynamic Wind}.
+@end deftypefn
+
+@deftypefn Instruction {} unwind x24:@var{_}
+@var{a} normal exit from the dynamic extent of an expression. Pop the top
+entry off of the dynamic stack.
+@end deftypefn
+
+@deftypefn Instruction {} push-fluid u12:@var{fluid} u12:@var{value}
+Dynamically bind @var{value} to @var{fluid} by creating a with-fluids
+object and pushing that object on the dynamic stack. @xref{Fluids and
+Dynamic States}.
+@end deftypefn
+
+@deftypefn Instruction {} pop-fluid x24:@var{_}
+Leave the dynamic extent of a @code{with-fluid*} expression, restoring
+the fluid to its previous value. @code{push-fluid} should always be
+balanced with @code{pop-fluid}.
+@end deftypefn
+
+@deftypefn Instruction {} fluid-ref u12:@var{dst} u12:@var{src}
+Reference the fluid in @var{src}, and place the value in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} fluid-set u12:@var{fluid} u12:@var{val}
+Set the value of the fluid in @var{dst} to the value in @var{src}.
+@end deftypefn
+
+
+@node Miscellaneous Instructions
+@subsubsection Miscellaneous Instructions
+
+@deftypefn Instruction {} halt x24:@var{_}
+Bring the VM to a halt, returning all the values from the stack. Used
+in the ``boot continuation'', which is used when entering the VM from C.
+@end deftypefn
+
+
+@node Inlined Scheme Instructions
+@subsubsection Inlined Scheme Instructions
+
+The Scheme compiler can recognize the application of standard Scheme
+procedures. It tries to inline these small operations to avoid the
+overhead of creating new stack frames. This allows the compiler to
+optimize better.
+
+@deftypefn Instruction {} make-vector/immediate u8:@var{dst} u8:@var{length} u8:@var{init}
+Make a short vector of known size and write it to @var{dst}. The vector
+will have space for @var{length} slots, an immediate value. They will
+be filled with the value in slot @var{init}.
+@end deftypefn
+
+@deftypefn Instruction {} vector-length u12:@var{dst} u12:@var{src}
+Store the length of the vector in @var{src} in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} vector-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+Fetch the item at position @var{idx} in the vector in @var{src}, and
+store it in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} vector-ref/immediate u8:@var{dst} u8:@var{src} u8:@var{idx}
+Fill @var{dst} with the item @var{idx} elements into the vector at
+@var{src}. Useful for building data types using vectors.
+@end deftypefn
+
+@deftypefn Instruction {} vector-set! u8:@var{dst} u8:@var{idx} u8:@var{src}
+Store @var{src} into the vector @var{dst} at index @var{idx}.
+@end deftypefn
+
+@deftypefn Instruction {} vector-set!/immediate u8:@var{dst} u8:@var{idx} u8:@var{src}
+Store @var{src} into the vector @var{dst} at index @var{idx}. Here
+@var{idx} is an immediate value.
+@end deftypefn
+
+@deftypefn Instruction {} struct-vtable u12:@var{dst} u12:@var{src}
+Store the vtable of @var{src} into @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} allocate-struct/immediate u8:@var{dst} u8:@var{vtable} u8:@var{nfields}
+Allocate a new struct with @var{vtable}, and place it in @var{dst}. The
+struct will be constructed with space for @var{nfields} fields, which
+should correspond to the field count of the @var{vtable}.
+@end deftypefn
+
+@deftypefn Instruction {} struct-ref/immediate u8:@var{dst} u8:@var{src} u8:@var{idx}
+Fetch the item at slot @var{idx} in the struct in @var{src}, and store
+it in @var{dst}. @var{idx} is an immediate unsigned 8-bit value.
+@end deftypefn
+
+@deftypefn Instruction {} struct-set!/immediate u8:@var{dst} u8:@var{idx} u8:@var{src}
+Store @var{src} into the struct @var{dst} at slot @var{idx}. @var{idx}
+is an immediate unsigned 8-bit value.
+@end deftypefn
+
+@deftypefn Instruction {} class-of u12:@var{dst} u12:@var{type}
+Store the vtable of @var{src} into @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} make-array u12:@var{dst} u12:@var{type} x8:@var{_} u12:@var{fill} u12:@var{bounds}
+Make a new array with @var{type}, @var{fill}, and @var{bounds}, storing it in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} string-length u12:@var{dst} u12:@var{src}
+Store the length of the string in @var{src} in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} string-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+Fetch the character at position @var{idx} in the string in @var{src}, and store
+it in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} cons u8:@var{dst} u8:@var{car} u8:@var{cdr}
+Cons @var{car} and @var{cdr}, and store the result in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} car u12:@var{dst} u12:@var{src}
+Place the car of @var{src} in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} cdr u12:@var{dst} u12:@var{src}
+Place the cdr of @var{src} in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} set-car! u12:@var{pair} u12:@var{car}
+Set the car of @var{dst} to @var{src}.
+@end deftypefn
+
+@deftypefn Instruction {} set-cdr! u12:@var{pair} u12:@var{cdr}
+Set the cdr of @var{dst} to @var{src}.
+@end deftypefn
+
+Note that @code{caddr} and friends compile to a series of @code{car}
+and @code{cdr} instructions.
+
+
+@node Inlined Mathematical Instructions
+@subsubsection Inlined Mathematical Instructions
+
+Inlining mathematical operations has the obvious advantage of handling
+fixnums without function calls or allocations. The trick, of course,
+is knowing when the result of an operation will be a fixnum, and there
+might be a couple bugs here.
+
+More instructions could be added here over time.
+
+All of these operations place their result in their first operand,
+@var{dst}.
+
+@deftypefn Instruction {} add u8:@var{dst} u8:@var{a} u8:@var{b}
+Add @var{a} to @var{b}.
+@end deftypefn
+
+@deftypefn Instruction {} add1 u12:@var{dst} u12:@var{src}
+Add 1 to the value in @var{src}.
+@end deftypefn
+
+@deftypefn Instruction {} sub u8:@var{dst} u8:@var{a} u8:@var{b}
+Subtract @var{b} from @var{a}.
+@end deftypefn
+
+@deftypefn Instruction {} sub1 u12:@var{dst} u12:@var{src}
+Subtract 1 from @var{src}.
+@end deftypefn
+
+@deftypefn Instruction {} mul u8:@var{dst} u8:@var{a} u8:@var{b}
+Multiply @var{a} and @var{b}.
+@end deftypefn
+
+@deftypefn Instruction {} div u8:@var{dst} u8:@var{a} u8:@var{b}
+Divide @var{a} by @var{b}.
+@end deftypefn
+
+@deftypefn Instruction {} quo u8:@var{dst} u8:@var{a} u8:@var{b}
+Divide @var{a} by @var{b}.
+@end deftypefn
+
+@deftypefn Instruction {} rem u8:@var{dst} u8:@var{a} u8:@var{b}
+Divide @var{a} by @var{b}.
+@end deftypefn
+
+@deftypefn Instruction {} mod u8:@var{dst} u8:@var{a} u8:@var{b}
+Compute the modulo of @var{a} by @var{b}.
+@end deftypefn
+
+@deftypefn Instruction {} ash u8:@var{dst} u8:@var{a} u8:@var{b}
+Shift @var{a} arithmetically by @var{b} bits.
+@end deftypefn
+
+@deftypefn Instruction {} logand u8:@var{dst} u8:@var{a} u8:@var{b}
+Compute the bitwise @code{and} of @var{a} and @var{b}.
+@end deftypefn
+
+@deftypefn Instruction {} logior u8:@var{dst} u8:@var{a} u8:@var{b}
+Compute the bitwise inclusive @code{or} of @var{a} with @var{b}.
+@end deftypefn
+
+@deftypefn Instruction {} logxor u8:@var{dst} u8:@var{a} u8:@var{b}
+Compute the bitwise exclusive @code{or} of @var{a} with @var{b}.
+@end deftypefn
+
+
+@node Inlined Bytevector Instructions
+@subsubsection Inlined Bytevector Instructions
+
+Bytevector operations correspond closely to what the current hardware
+can do, so it makes sense to inline them to VM instructions, providing
+a clear path for eventual native compilation. Without this, Scheme
+programs would need other primitives for accessing raw bytes -- but
+these primitives are as good as any.
+
+@deftypefn Instruction {} bv-u8-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+@deftypefnx Instruction {} bv-s8-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+@deftypefnx Instruction {} bv-u16-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+@deftypefnx Instruction {} bv-s16-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+@deftypefnx Instruction {} bv-u32-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+@deftypefnx Instruction {} bv-s32-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+@deftypefnx Instruction {} bv-u64-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+@deftypefnx Instruction {} bv-s64-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+@deftypefnx Instruction {} bv-f32-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+@deftypefnx Instruction {} bv-f64-ref u8:@var{dst} u8:@var{src} u8:@var{idx}
+
+Fetch the item at byte offset @var{idx} in the bytevector @var{src}, and
+store it in @var{dst}. All accesses use native endianness.
+@end deftypefn
+
+@deftypefn Instruction {} bv-u8-set! u8:@var{dst} u8:@var{idx} u8:@var{src}
+@deftypefnx Instruction {} bv-s8-set! u8:@var{dst} u8:@var{idx} u8:@var{src}
+@deftypefnx Instruction {} bv-u16-set! u8:@var{dst} u8:@var{idx} u8:@var{src}
+@deftypefnx Instruction {} bv-s16-set! u8:@var{dst} u8:@var{idx} u8:@var{src}
+@deftypefnx Instruction {} bv-u32-set! u8:@var{dst} u8:@var{idx} u8:@var{src}
+@deftypefnx Instruction {} bv-s32-set! u8:@var{dst} u8:@var{idx} u8:@var{src}
+@deftypefnx Instruction {} bv-u64-set! u8:@var{dst} u8:@var{idx} u8:@var{src}
+@deftypefnx Instruction {} bv-s64-set! u8:@var{dst} u8:@var{idx} u8:@var{src}
+@deftypefnx Instruction {} bv-f32-set! u8:@var{dst} u8:@var{idx} u8:@var{src}
+@deftypefnx Instruction {} bv-f64-set! u8:@var{dst} u8:@var{idx} u8:@var{src}
+
+Store @var{src} into the bytevector @var{dst} at byte offset @var{idx}.
+Multibyte values are written using native endianness.
+@end deftypefn
+++ /dev/null
-# -*-shell-script-*-
-
-# This file contains the shared library versioning information. 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 Makefile.am, and add a call to
-# source this file from configure.in. Later we may automate more of
-# this.
-
-LIBGUILEREADLINE_MAJOR=18
-LIBGUILEREADLINE_INTERFACE_CURRENT=18
-LIBGUILEREADLINE_INTERFACE_REVISION=0
-LIBGUILEREADLINE_INTERFACE_AGE=0
-LIBGUILEREADLINE_INTERFACE="${LIBGUILEREADLINE_INTERFACE_CURRENT}:${LIBGUILEREADLINE_INTERFACE_REVISION}:${LIBGUILEREADLINE_INTERFACE_AGE}"
## Process this file with Automake to create Makefile.in
##
## Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2007, 2008,
-## 2009, 2010, 2012 Free Software Foundation, Inc.
+## 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
##
## This file is part of guile-readline.
##
AM_CFLAGS = $(GCC_CFLAGS)
-lib_LTLIBRARIES = libguilereadline-v-@LIBGUILEREADLINE_MAJOR@.la
+extensionsdir=$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions
-libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_SOURCES = readline.c
-libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LIBADD = \
+extensions_LTLIBRARIES = guile-readline.la
+
+guile_readline_la_SOURCES = readline.c
+guile_readline_la_LIBADD = \
$(READLINE_LIBS) \
../libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la ../lib/libgnu.la
-libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LDFLAGS = \
- -version-info @LIBGUILEREADLINE_INTERFACE@ -export-dynamic \
- -no-undefined
-
+guile_readline_la_LDFLAGS = -export-dynamic -no-undefined -module
BUILT_SOURCES = readline.x
.c.x:
$(AM_V_SNARF)$(GUILE_SNARF) -o $@ $< $(snarfcppopts)
-EXTRA_DIST += LIBGUILEREADLINE-VERSION ChangeLog-2008
+EXTRA_DIST += ChangeLog-2008
-ETAGS_ARGS += \
- $(libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_SOURCES)
+ETAGS_ARGS += $(guile_readline_la_SOURCES)
CLEANFILES += *.x *.go
;;;; readline.scm --- support functions for command-line editing
;;;;
-;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 2009, 2010, 2011,
+;;;; 2013, 2014 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
;;; but only when it isn't already present.
(if (not (provided? 'readline))
- (load-extension "libguilereadline-v-18" "scm_init_readline"))
+ (load-extension "guile-readline" "scm_init_readline"))
(if (not (provided? 'readline))
(scm-error 'misc-error
/* readline.c --- line editing support for Guile */
-/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, 2009, 2010, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008,
+ * 2009, 2010, 2013 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
promptp = 1;
s = readline (prompt);
if (s)
- {
- scm_t_port *pt = SCM_PTAB_ENTRY (output_port);
-
- ret = scm_from_stringn (s, strlen (s), pt->encoding,
- SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
- }
+ ret = scm_from_port_string (s, output_port);
else
ret = SCM_EOF_VAL;
#ifndef SCM_LIBGUILE_H
#define SCM_LIBGUILE_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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/foreign-object.h"
#include "libguile/fports.h"
#include "libguile/gc.h"
-#include "libguile/gdbint.h"
#include "libguile/generalized-arrays.h"
#include "libguile/generalized-vectors.h"
#include "libguile/goops.h"
#include "libguile/srfi-4.h"
#include "libguile/version.h"
#include "libguile/vports.h"
-#include "libguile/weaks.h"
+#include "libguile/weak-set.h"
+#include "libguile/weak-table.h"
+#include "libguile/weak-vector.h"
#include "libguile/backtrace.h"
#include "libguile/debug.h"
#include "libguile/stacks.h"
debug.c \
deprecated.c \
deprecation.c \
+ dynstack.c \
dynwind.c \
eq.c \
error.c \
frames.c \
gc-malloc.c \
gc.c \
- gdbint.c \
gettext.c \
generalized-arrays.c \
generalized-vectors.c \
keywords.c \
list.c \
load.c \
+ loader.c \
macros.c \
mallocs.c \
memoize.c \
modules.c \
null-threads.c \
numbers.c \
- objcodes.c \
objprop.c \
options.c \
pairs.c \
version.c \
vm.c \
vports.c \
- weaks.c
+ weak-set.c \
+ weak-table.c \
+ weak-vector.c
DOT_X_FILES = \
alist.x \
fluids.x \
foreign.x \
fports.x \
+ frames.x \
gc-malloc.x \
gc.x \
gettext.x \
hooks.x \
i18n.x \
init.x \
+ instructions.x \
ioext.x \
keywords.x \
list.x \
load.x \
+ loader.x \
macros.x \
mallocs.x \
memoize.x \
print.x \
procprop.x \
procs.x \
+ programs.x \
promises.x \
r6rs-ports.x \
random.x \
variable.x \
vectors.x \
version.x \
+ vm.x \
vports.x \
- weaks.x
-
-# vm-related snarfs
-DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
+ weak-set.x \
+ weak-table.x \
+ weak-vector.x
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
vectors.doc \
version.doc \
vports.doc \
- weaks.doc
+ weak-set.doc \
+ weak-table.doc \
+ weak-vector.doc
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
-DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i
-
-.c.i:
- $(AM_V_GEN)$(GREP) '^VM_DEFINE' $< > $@
+vm-operations.h: vm-engine.c
+ @echo '/* This file was generated automatically from $<; do not' > $@
+ @echo ' edit. See the source file for copyright information. */' >> $@
+ @echo '' >> $@
+ @echo "#define FOR_EACH_VM_OPERATION(M) \\" >> $@
+ $(AM_V_GEN)$(GREP) '^ *VM_DEFINE_OP' $< \
+ | sed -e 's,VM_DEFINE_OP (\(.*\)).*, M (\1) \\,' >> $@
+ @echo '' >> $@
BUILT_SOURCES = cpp-E.c cpp-SIG.c libpath.h \
scmconfig.h \
- $(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
+ $(DOT_I_FILES) vm-operations.h $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
# Force the generation of `guile-procedures.texi' because the top-level
# Makefile expects it to be built.
install-exec-hook:
rm -f $(DESTDIR)$(bindir)/guile-snarf.awk
-install-data-hook: libguile-2.0-gdb.scm
+install-data-hook: libguile-2.2-gdb.scm
@$(MKDIR_P) $(DESTDIR)$(libdir)
-## We want to install libguile-2.0-gdb.scm as SOMETHING-gdb.scm.
+## We want to install libguile-2.2-gdb.scm as SOMETHING-gdb.scm.
## SOMETHING is the full name of the final library. We want to ignore
## symlinks, the .la file, and any previous -gdb.py file. This is
## inherently fragile, but there does not seem to be a better option,
## Perhaps we can deal with them normally once the merge seems to be
## working.
noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
+ elf.h \
srfi-14.i.c \
quicksort.i.c \
win32-uname.h \
- private-gc.h private-options.h ports-internal.h
+ private-options.h ports-internal.h
# vm instructions
-noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
+noinst_HEADERS += vm-engine.c
libguile_@GUILE_EFFECTIVE_VERSION@_la_DEPENDENCIES = @LIBLOBJS@
deprecated.h \
deprecation.h \
dynl.h \
+ dynstack.h \
dynwind.h \
eq.h \
error.h \
fports.h \
frames.h \
gc.h \
- gdb_interface.h \
- gdbint.h \
+ gc-inline.h \
gettext.h \
generalized-arrays.h \
generalized-vectors.h \
keywords.h \
list.h \
load.h \
+ loader.h \
macros.h \
mallocs.h \
memoize.h \
net_db.h \
null-threads.h \
numbers.h \
- objcodes.h \
objprop.h \
options.h \
pairs.h \
values.h \
variable.h \
vectors.h \
- vm-engine.h \
+ vm-builtins.h \
vm-expand.h \
vm.h \
vports.h \
- weaks.h
+ weak-set.h \
+ weak-table.h \
+ weak-vector.h
nodist_modinclude_HEADERS = version.h scmconfig.h
cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \
c-tokenize.lex \
scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map \
- libguile-2.0-gdb.scm
+ libguile-2.2-gdb.scm
# $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
# guile-procedures.txt guile.texi
dynl.x: libpath.h
alldotdocfiles = $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES)
-snarf2checkedtexi = GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \
- $(top_builddir)/meta/uninstalled-env guild snarf-check-and-output-texi
+snarf2checkedtexi = GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guild snarf-check-and-output-texi
dotdoc2texi = cat $(alldotdocfiles) | $(snarf2checkedtexi)
guile.texi: $(alldotdocfiles) guile$(EXEEXT)
MOSTLYCLEANFILES = \
scmconfig.h scmconfig.h.tmp
-CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi \
- vm-i-*.i
+CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi
MAINTAINERCLEANFILES = c-tokenize.c
#endif
\f
-/* {Supported Options}
- *
- * These may be defined or undefined.
- */
-
-/* #define GUILE_DEBUG_FREELIST */
-
-
-/* Use engineering notation when converting numbers strings?
- */
-#undef ENGNOT
-
-\f
-/* {Unsupported Options}
- *
- * These must be defined as given here.
- */
-
-
-/* Guile Scheme supports the #f/() distinction; Guile Lisp won't. We
- have horrible plans for their unification. */
-#undef SICP
-
-\f
-
-/* Random options (not yet supported or in final form). */
-
-#define STACK_CHECKING
-#undef NO_CEVAL_STACK_CHECKING
-
-\f
/* SCM_API is a macro prepended to all function and data definitions
which should be exported from libguile. */
#define SCM_DEBUG 0
#endif
-/* For debugging purposes: define this is to ensure nobody is using
- * the mark bits outside of the marking phase. This is meant for
- * debugging purposes only.
- */
-#ifndef SCM_DEBUG_MARKING_API
-#define SCM_DEBUG_MARKING_API 0
-#endif
-
/* If SCM_DEBUG_CELL_ACCESSES is set to 1, cell accesses will perform
* exhaustive parameter checking: It will be verified that cell parameters
* actually point to a valid heap cell. Note: If this option is enabled,
#define SCM_DEBUG_CELL_ACCESSES SCM_DEBUG
#endif
-/* If SCM_DEBUG_INTERRUPTS is set to 1, with every deferring and allowing of
- * interrupts a consistency check will be performed.
- */
-#ifndef SCM_DEBUG_INTERRUPTS
-#define SCM_DEBUG_INTERRUPTS SCM_DEBUG
-#endif
-
/* If SCM_DEBUG_PAIR_ACCESSES is set to 1, accesses to cons cells will be
* exhaustively checked. Note: If this option is enabled, guile will run
* slower than normally.
#define SCM_DEBUG_TYPING_STRICTNESS 1
#endif
-/* If SCM_DEBUG_DEBUGGING_SUPPORT is set to 1, guile will provide a set of
- * special functions that support debugging with a debugger like gdb or
- * debugging of guile internals on the scheme level. The behaviour of guile
- * is not changed by this macro, only the set of functions that are available
- * will differ. All functions that are introduced this way have the prefix
- * 'scm_dbg_' on the C level and the prefix 'dbg-' on the scheme level. This
- * allows to easily determine the set of support functions, given that your
- * debugger or repl provide automatic name completion. Note that these
- * functions are intended to be used during interactive debugging sessions
- * only. They are not considered part of guile's official API. They may
- * change or disappear without notice or deprecation phase.
- */
-#ifndef SCM_DEBUG_DEBUGGING_SUPPORT
-#define SCM_DEBUG_DEBUGGING_SUPPORT SCM_DEBUG
-#endif
-
\f
/* {Feature Options}
#define SCM_T_INT64_MIN SCM_I_TYPE_MIN(scm_t_int64,SCM_T_UINT64_MAX)
#define SCM_T_INT64_MAX SCM_I_TYPE_MAX(scm_t_int64,SCM_T_UINT64_MAX)
-#if SCM_SIZEOF_LONG_LONG
-#define SCM_I_ULLONG_MAX SCM_I_UTYPE_MAX(unsigned long long)
-#define SCM_I_LLONG_MIN SCM_I_TYPE_MIN(long long,SCM_I_ULLONG_MAX)
-#define SCM_I_LLONG_MAX SCM_I_TYPE_MAX(long long,SCM_I_ULLONG_MAX)
-#endif
-
#define SCM_T_UINTMAX_MAX SCM_I_UTYPE_MAX(scm_t_uintmax)
#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_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)
-
\f
#include "libguile/tags.h"
#endif
\f
-#ifdef vms
-# ifndef CHEAP_CONTINUATIONS
- typedef int jmp_buf[17];
- extern int setjump(jmp_buf env);
- extern int longjump(jmp_buf env, int ret);
-# define setjmp setjump
-# define longjmp longjump
-# else
-# include <setjmp.h>
-# endif
-#else /* ndef vms */
-# ifdef _CRAY1
- typedef int jmp_buf[112];
- extern int setjump(jmp_buf env);
- extern int longjump(jmp_buf env, int ret);
-# define setjmp setjump
-# define longjmp longjump
-# else /* ndef _CRAY1 */
-# if defined (__ia64__)
-/* For IA64, emulate the setjmp API using getcontext. */
-# include <signal.h>
-# include <ucontext.h>
- typedef struct {
- ucontext_t ctx;
- int fresh;
- } scm_i_jmp_buf;
-# define SCM_I_SETJMP(JB) \
- ( (JB).fresh = 1, \
- getcontext (&((JB).ctx)), \
- ((JB).fresh ? ((JB).fresh = 0, 0) : 1) )
-# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
- void scm_ia64_longjmp (scm_i_jmp_buf *, int);
-# else /* ndef __ia64__ */
-# include <setjmp.h>
-# endif /* ndef __ia64__ */
-# endif /* ndef _CRAY1 */
-#endif /* ndef vms */
-
-/* For any platform where SCM_I_SETJMP hasn't been defined in some
- special way above, map SCM_I_SETJMP, SCM_I_LONGJMP and
- scm_i_jmp_buf to setjmp, longjmp and jmp_buf. */
-#ifndef SCM_I_SETJMP
-#define scm_i_jmp_buf jmp_buf
-#define SCM_I_SETJMP setjmp
-#define SCM_I_LONGJMP longjmp
-#endif
-/* James Clark came up with this neat one instruction fix for
- * continuations on the SPARC. It flushes the register windows so
- * that all the state of the process is contained in the stack.
+/* scm_i_jmp_buf
+ *
+ * The corresponding SCM_I_SETJMP and SCM_I_LONGJMP are defined in the
+ * _scm.h private header.
*/
-#if defined (sparc) || defined (__sparc__) || defined (__sparc)
-# define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3")
+#if defined (vms)
+typedef int scm_i_jmp_buf[17];
+
+#elif defined (_CRAY1)
+typedef int scm_i_jmp_buf[112];
+
+#elif defined (__ia64__)
+# include <signal.h>
+# include <ucontext.h>
+typedef struct {
+ ucontext_t ctx;
+ int fresh;
+} scm_i_jmp_buf;
+
#else
-# define SCM_FLUSH_REGISTER_WINDOWS /* empty */
+# include <setjmp.h>
+typedef jmp_buf scm_i_jmp_buf;
#endif
+
+\f
+
/* If stack is not longword aligned then
*/
#define SCM_STACK_PTR(ptr) ((SCM_STACKITEM *) (void *) (ptr))
\f
-SCM_API void scm_async_tick (void);
-
#ifdef BUILDING_LIBGUILE
-
-/* FIXME: should change names */
-# define SCM_ASYNC_TICK \
- do \
- { \
- if (SCM_UNLIKELY (SCM_I_CURRENT_THREAD->pending_asyncs)) \
- scm_async_click (); \
- } \
- while (0)
-
-/* SCM_ASYNC_TICK_WITH_CODE is only available to Guile itself */
-# define SCM_ASYNC_TICK_WITH_CODE(thr, stmt) \
- do \
- { \
- if (SCM_UNLIKELY (thr->pending_asyncs)) \
- { \
- stmt; \
- scm_async_click (); \
- } \
- } \
- while (0)
-
-#else /* !BUILDING_LIBGUILE */
-
-# define SCM_ASYNC_TICK (scm_async_tick ())
-
-#endif /* !BUILDING_LIBGUILE */
-
-
-/* Anthony Green writes:
- When the compiler sees...
- DEFER_INTS;
- [critical code here]
- ALLOW_INTS;
- ...it doesn't actually promise to keep the critical code within the
- boundries of the DEFER/ALLOW_INTS instructions. It may very well
- schedule it outside of the magic defined in those macros.
-
- However, GCC's volatile asm feature forms a barrier over which code is
- never moved. So if you add...
- asm ("");
- ...to each of the DEFER_INTS and ALLOW_INTS macros, the critical
- code will always remain in place. asm's without inputs or outputs
- are implicitly volatile. */
-#ifdef __GNUC__
-#define SCM_FENCE asm /* volatile */ ("")
-#elif defined (__INTEL_COMPILER) && defined (__ia64)
-#define SCM_FENCE __memory_barrier()
+#define SCM_TICK SCM_ASYNC_TICK
#else
-#define SCM_FENCE
+#define SCM_TICK scm_async_tick ()
#endif
-#define SCM_TICK \
-do { \
- SCM_ASYNC_TICK; \
- SCM_THREAD_SWITCHING_CODE; \
-} while (0)
-
\f
-/** SCM_ASSERT
- **
- **/
-
-
-#ifdef SCM_RECKLESS
-#define SCM_ASSERT(_cond, _arg, _pos, _subr)
-#define SCM_ASSERT_TYPE(_cond, _arg, _pos, _subr, _msg)
-#else
-#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
- do { if (SCM_UNLIKELY (!(_cond))) \
- scm_wrong_type_arg (_subr, _pos, _arg); } while (0)
-#define SCM_ASSERT_TYPE(_cond, _arg, _pos, _subr, _msg) \
- do { if (SCM_UNLIKELY (!(_cond))) \
- scm_wrong_type_arg_msg(_subr, _pos, _arg, _msg); } while (0)
-#endif
-
-/*
- * SCM_WTA_DISPATCH
- */
-
-/* Dirk:FIXME:: In all of the SCM_WTA_DISPATCH_* macros it is assumed that
- * 'gf' is zero if uninitialized. It would be cleaner if some valid SCM value
- * like SCM_BOOL_F or SCM_UNDEFINED was chosen.
- */
-
-SCM_API SCM scm_call_generic_0 (SCM gf);
-
-#define SCM_WTA_DISPATCH_0(gf, subr) \
- return (SCM_UNPACK (gf) \
- ? scm_call_generic_0 ((gf)) \
- : (scm_error_num_args_subr ((subr)), SCM_UNSPECIFIED))
-#define SCM_GASSERT0(cond, gf, subr) \
- if (SCM_UNLIKELY(!(cond))) \
- SCM_WTA_DISPATCH_0((gf), (subr))
-
-SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
-
-#define SCM_WTA_DISPATCH_1(gf, a1, pos, subr) \
- return (SCM_UNPACK (gf) \
- ? scm_call_generic_1 ((gf), (a1)) \
- : (scm_wrong_type_arg ((subr), (pos), (a1)), SCM_UNSPECIFIED))
-
-/* This form is for dispatching a subroutine. */
-#define SCM_WTA_DISPATCH_1_SUBR(subr, a1, pos) \
- return (SCM_UNPACK ((*SCM_SUBR_GENERIC (subr))) \
- ? scm_call_generic_1 ((*SCM_SUBR_GENERIC (subr)), (a1)) \
- : (scm_i_wrong_type_arg_symbol (SCM_SUBR_NAME (subr), (pos), (a1)), SCM_UNSPECIFIED))
-
-#define SCM_GASSERT1(cond, gf, a1, pos, subr) \
- if (SCM_UNLIKELY (!(cond))) \
- SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr))
-
-SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
-
-#define SCM_WTA_DISPATCH_2(gf, a1, a2, pos, subr) \
- return (SCM_UNPACK (gf) \
- ? scm_call_generic_2 ((gf), (a1), (a2)) \
- : (scm_wrong_type_arg ((subr), (pos), \
- (pos) == SCM_ARG1 ? (a1) : (a2)), \
- SCM_UNSPECIFIED))
-#define SCM_GASSERT2(cond, gf, a1, a2, pos, subr) \
- if (SCM_UNLIKELY (!(cond))) \
- SCM_WTA_DISPATCH_2((gf), (a1), (a2), (pos), (subr))
-
-SCM_API SCM scm_apply_generic (SCM gf, SCM args);
-
-#define SCM_WTA_DISPATCH_n(gf, args, pos, subr) \
- return (SCM_UNPACK (gf) \
- ? scm_apply_generic ((gf), (args)) \
- : (scm_wrong_type_arg ((subr), (pos), \
- scm_list_ref ((args), \
- scm_from_int ((pos) - 1))), \
- SCM_UNSPECIFIED))
-#define SCM_GASSERTn(cond, gf, args, pos, subr) \
- if (SCM_UNLIKELY (!(cond))) \
- SCM_WTA_DISPATCH_n((gf), (args), (pos), (subr))
-
#ifndef SCM_MAGIC_SNARFER
/* Let these macros pass through if
we are snarfing; thus we can tell the
\f
-/* SCM_EXIT_SUCCESS is the default code to return from SCM if no errors
- * were encountered. SCM_EXIT_FAILURE is the default code to return from
- * SCM if errors were encountered. The return code can be explicitly
- * specified in a SCM program with (scm_quit <n>).
- */
-
-#ifndef SCM_EXIT_SUCCESS
-#ifdef vms
-#define SCM_EXIT_SUCCESS 1
-#else
-#define SCM_EXIT_SUCCESS 0
-#endif /* def vms */
-#endif /* ndef SCM_EXIT_SUCCESS */
-#ifndef SCM_EXIT_FAILURE
-#ifdef vms
-#define SCM_EXIT_FAILURE 2
-#else
-#define SCM_EXIT_FAILURE 1
-#endif /* def vms */
-#endif /* ndef SCM_EXIT_FAILURE */
-
/* Define SCM_C_INLINE_KEYWORD so that it can be used as a replacement
for the "inline" keyword, expanding to nothing when "inline" is not
available.
#define SCM__SCM_H
/* Copyright (C) 1995, 1996, 2000, 2001, 2002, 2006, 2008, 2009, 2010,
- * 2011, 2013 Free Software Foundation, Inc.
+ * 2011, 2013, 2014 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_to_off64_t scm_to_int64
#define scm_from_off64_t scm_from_int64
+
+\f
+
+#if defined (vms)
+/* VMS: Implement SCM_I_SETJMP in terms of setjump. */
+extern int setjump(scm_i_jmp_buf env);
+extern int longjump(scm_i_jmp_buf env, int ret);
+#define SCM_I_SETJMP setjump
+#define SCM_I_LONGJMP longjump
+
+#elif defined (_CRAY1)
+/* Cray: Implement SCM_I_SETJMP in terms of setjump. */
+extern int setjump(scm_i_jmp_buf env);
+extern int longjump(scm_i_jmp_buf env, int ret);
+#define SCM_I_SETJMP setjump
+#define SCM_I_LONGJMP longjump
+
+#elif defined (__ia64__)
+/* IA64: Implement SCM_I_SETJMP in terms of getcontext. */
+# define SCM_I_SETJMP(JB) \
+ ( (JB).fresh = 1, \
+ getcontext (&((JB).ctx)), \
+ ((JB).fresh ? ((JB).fresh = 0, 0) : 1) )
+# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
+void scm_ia64_longjmp (scm_i_jmp_buf *, int);
+
+#else
+/* All other systems just use setjmp and longjmp. */
+
+#define SCM_I_SETJMP setjmp
+#define SCM_I_LONGJMP longjmp
+#endif
+
+\f
+
+#define SCM_ASYNC_TICK_WITH_GUARD_CODE(thr, pre, post) \
+ do \
+ { \
+ if (SCM_UNLIKELY (thr->pending_asyncs)) \
+ { \
+ pre; \
+ scm_async_tick (); \
+ post; \
+ } \
+ } \
+ while (0)
+
+#define SCM_ASYNC_TICK_WITH_CODE(thr, stmt) \
+ SCM_ASYNC_TICK_WITH_GUARD_CODE (thr, stmt, (void) 0)
+#define SCM_ASYNC_TICK \
+ SCM_ASYNC_TICK_WITH_CODE (SCM_I_CURRENT_THREAD, (void) 0)
+
+
+\f
+
#if (defined __GNUC__)
# define SCM_NOINLINE __attribute__ ((__noinline__))
#else
# define SCM_NOINLINE /* noinline */
#endif
+\f
+
/* The endianness marker in objcode. */
#ifdef WORDS_BIGENDIAN
# define SCM_OBJCODE_ENDIANNESS "BE"
#define SCM_OBJCODE_WORD_SIZE SCM_CPP_STRINGIFY (SIZEOF_VOID_P)
/* Major and minor versions must be single characters. */
-#define SCM_OBJCODE_MAJOR_VERSION 2
-#define SCM_OBJCODE_MINOR_VERSION 0
+#define SCM_OBJCODE_MAJOR_VERSION 3
+#define SCM_OBJCODE_MINOR_VERSION 6
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \
#define SCM_OBJCODE_MACHINE_VERSION_STRING \
SCM_OBJCODE_ENDIANNESS "-" SCM_OBJCODE_WORD_SIZE "-" SCM_OBJCODE_VERSION_STRING
-/* The objcode magic header. */
-#define SCM_OBJCODE_COOKIE \
- "GOOF----" SCM_OBJCODE_MACHINE_VERSION_STRING
-#define SCM_OBJCODE_ENDIANNESS_OFFSET 8
-#define SCM_OBJCODE_WORD_SIZE_OFFSET 11
-
-
#endif /* SCM__SCM_H */
/*
-/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001, 2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
"function is @emph{not} destructive; @var{alist} is not modified.")
#define FUNC_NAME s_scm_acons
{
- return scm_cell (SCM_UNPACK (scm_cell (SCM_UNPACK (key),
- SCM_UNPACK (value))),
- SCM_UNPACK (alist));
+ return scm_cons (scm_cons (key, value), alist);
}
#undef FUNC_NAME
-/* Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
static int
arbiter_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<arbiter ", port);
+ scm_puts
_unlocked ("#<arbiter ", port);
if (SCM_ARB_LOCKED (exp))
- scm_puts ("locked ", port);
+ scm_puts_unlocked ("locked ", port);
scm_iprin1 (SCM_PACK (SCM_SMOB_DATA (exp)), port, pstate);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return !0;
}
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
+ * 2006, 2009, 2011, 2013, 2014 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 scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1];
-#define ARRAY_IMPLS_N_STATIC_ALLOC 7
-static scm_t_array_implementation array_impls[ARRAY_IMPLS_N_STATIC_ALLOC];
-static int num_array_impls_registered = 0;
+/* Bytevectors as generalized vectors & arrays. */
+#define DEFINE_BYTEVECTOR_ACCESSORS(type, tag, infix) \
+ static SCM \
+ bytevector_##tag##_ref (SCM bv, size_t pos) \
+ { \
+ SCM idx = scm_from_size_t (pos * sizeof (type)); \
+ return scm_bytevector_##infix##_ref (bv, idx); \
+ } \
+ static void \
+ bytevector_##tag##_set (SCM bv, size_t pos, SCM val) \
+ { \
+ SCM idx = scm_from_size_t (pos * sizeof (type)); \
+ scm_bytevector_##infix##_set_x (bv, idx, val); \
+ }
-void
-scm_i_register_array_implementation (scm_t_array_implementation *impl)
+DEFINE_BYTEVECTOR_ACCESSORS (uint8_t, u8, u8);
+DEFINE_BYTEVECTOR_ACCESSORS (int8_t, s8, s8);
+DEFINE_BYTEVECTOR_ACCESSORS (uint16_t, u16, u16_native);
+DEFINE_BYTEVECTOR_ACCESSORS (int16_t, s16, s16_native);
+DEFINE_BYTEVECTOR_ACCESSORS (uint32_t, u32, u32_native);
+DEFINE_BYTEVECTOR_ACCESSORS (int32_t, s32, s32_native);
+DEFINE_BYTEVECTOR_ACCESSORS (uint64_t, u64, u64_native);
+DEFINE_BYTEVECTOR_ACCESSORS (int64_t, s64, s64_native);
+DEFINE_BYTEVECTOR_ACCESSORS (float, f32, ieee_single_native);
+DEFINE_BYTEVECTOR_ACCESSORS (double, f64, ieee_double_native);
+
+/* Since these functions are only called by Guile's C code, we can abort
+ instead of throwing if there is an error. */
+static SCM
+bytevector_c32_ref (SCM bv, size_t pos)
{
- if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC)
- /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */
+ char *c_bv;
+ float real, imag;
+
+ if (!SCM_BYTEVECTOR_P (bv))
abort ();
- else
- array_impls[num_array_impls_registered++] = *impl;
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ pos *= 2 * sizeof (float);
+ if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
+ abort ();
+
+ memcpy (&real, &c_bv[pos], sizeof (float));
+ memcpy (&imag, &c_bv[pos + sizeof (float)], sizeof (float));
+ return scm_c_make_rectangular (real, imag);
}
-scm_t_array_implementation*
-scm_i_array_implementation_for_obj (SCM obj)
+static SCM
+bytevector_c64_ref (SCM bv, size_t pos)
{
- int i;
- for (i = 0; i < num_array_impls_registered; i++)
- if (SCM_NIMP (obj)
- && (SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag)
- return &array_impls[i];
- return NULL;
+ char *c_bv;
+ double real, imag;
+
+ if (!SCM_BYTEVECTOR_P (bv))
+ abort ();
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ pos *= 2 * sizeof (double);
+ if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
+ abort ();
+
+ memcpy (&real, &c_bv[pos], sizeof (double));
+ memcpy (&imag, &c_bv[pos + sizeof (double)], sizeof (double));
+ return scm_c_make_rectangular (real, imag);
+}
+
+static void
+bytevector_c32_set (SCM bv, size_t pos, SCM val)
+{
+ char *c_bv;
+ float real, imag;
+
+ if (!SCM_BYTEVECTOR_P (bv))
+ abort ();
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ pos *= 2 * sizeof (float);
+ if (pos + 2 * sizeof (float) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
+ abort ();
+
+ real = scm_c_real_part (val);
+ imag = scm_c_imag_part (val);
+ memcpy (&c_bv[pos], &real, sizeof (float));
+ memcpy (&c_bv[pos + sizeof (float)], &imag, sizeof (float));
+}
+
+static void
+bytevector_c64_set (SCM bv, size_t pos, SCM val)
+{
+ char *c_bv;
+ double real, imag;
+
+ if (!SCM_BYTEVECTOR_P (bv))
+ abort ();
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ pos *= 2 * sizeof (double);
+ if (pos + 2 * sizeof (double) - 1 >= SCM_BYTEVECTOR_LENGTH (bv))
+ abort ();
+
+ real = scm_c_real_part (val);
+ imag = scm_c_imag_part (val);
+ memcpy (&c_bv[pos], &real, sizeof (double));
+ memcpy (&c_bv[pos + sizeof (double)], &imag, sizeof (double));
+}
+
+static void
+initialize_vector_handle (scm_t_array_handle *h, size_t len,
+ scm_t_array_element_type element_type,
+ scm_t_vector_ref vref, scm_t_vector_set vset,
+ void *writable_elements)
+{
+ h->base = 0;
+ h->ndims = 1;
+ h->dims = &h->dim0;
+ h->dim0.lbnd = 0;
+ h->dim0.ubnd = (ssize_t) (len - 1U);
+ h->dim0.inc = 1;
+ h->element_type = element_type;
+ h->elements = h->writable_elements = writable_elements;
+ h->vector = h->array;
+ h->vref = vref;
+ h->vset = vset;
}
void
scm_array_get_handle (SCM array, scm_t_array_handle *h)
{
- scm_t_array_implementation *impl = scm_i_array_implementation_for_obj (array);
- if (!impl)
+ if (!SCM_HEAP_OBJECT_P (array))
scm_wrong_type_arg_msg (NULL, 0, array, "array");
+
h->array = array;
- h->impl = impl;
- h->base = 0;
- h->ndims = 0;
- h->dims = NULL;
- h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; /* have to default to
- something... */
- h->elements = NULL;
- h->writable_elements = NULL;
- h->impl->get_handle (array, h);
+
+ switch (SCM_TYP7 (array))
+ {
+ case scm_tc7_string:
+ initialize_vector_handle (h, scm_c_string_length (array),
+ SCM_ARRAY_ELEMENT_TYPE_CHAR,
+ scm_c_string_ref, scm_c_string_set_x,
+ NULL);
+ break;
+ case scm_tc7_vector:
+ initialize_vector_handle (h, scm_c_vector_length (array),
+ SCM_ARRAY_ELEMENT_TYPE_SCM,
+ scm_c_vector_ref, scm_c_vector_set_x,
+ SCM_I_VECTOR_WELTS (array));
+ break;
+ case scm_tc7_bitvector:
+ initialize_vector_handle (h, scm_c_bitvector_length (array),
+ SCM_ARRAY_ELEMENT_TYPE_BIT,
+ scm_c_bitvector_ref, scm_c_bitvector_set_x,
+ scm_i_bitvector_bits (array));
+ break;
+ case scm_tc7_bytevector:
+ {
+ size_t byte_length, length, element_byte_size;
+ scm_t_array_element_type element_type;
+ scm_t_vector_ref vref;
+ scm_t_vector_set vset;
+
+ byte_length = scm_c_bytevector_length (array);
+ element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (array);
+ element_byte_size = scm_i_array_element_type_sizes[element_type] / 8;
+ length = byte_length / element_byte_size;
+
+ switch (element_type)
+ {
+#define ACCESSOR_CASE(tag, TAG) \
+ case SCM_ARRAY_ELEMENT_TYPE_##TAG: \
+ vref = bytevector_##tag##_ref; \
+ vset = bytevector_##tag##_set; \
+ break
+
+ case SCM_ARRAY_ELEMENT_TYPE_VU8:
+ ACCESSOR_CASE(u8, U8);
+ ACCESSOR_CASE(s8, S8);
+ ACCESSOR_CASE(u16, U16);
+ ACCESSOR_CASE(s16, S16);
+ ACCESSOR_CASE(u32, U32);
+ ACCESSOR_CASE(s32, S32);
+ ACCESSOR_CASE(u64, U64);
+ ACCESSOR_CASE(s64, S64);
+ ACCESSOR_CASE(f32, F32);
+ ACCESSOR_CASE(f64, F64);
+ ACCESSOR_CASE(c32, C32);
+ ACCESSOR_CASE(c64, C64);
+
+ case SCM_ARRAY_ELEMENT_TYPE_SCM:
+ case SCM_ARRAY_ELEMENT_TYPE_BIT:
+ case SCM_ARRAY_ELEMENT_TYPE_CHAR:
+ default:
+ abort ();
+
+#undef ACCESSOR_CASE
+ }
+
+ initialize_vector_handle (h, length, element_type, vref, vset,
+ SCM_BYTEVECTOR_CONTENTS (array));
+ }
+ break;
+ case scm_tc7_array:
+ scm_array_get_handle (SCM_I_ARRAY_V (array), h);
+ h->array = array;
+ h->base = SCM_I_ARRAY_BASE (array);
+ h->ndims = SCM_I_ARRAY_NDIM (array);
+ h->dims = SCM_I_ARRAY_DIMS (array);
+ break;
+ default:
+ scm_wrong_type_arg_msg (NULL, 0, array, "array");
+ }
}
ssize_t
scm_init_array_handle (void)
{
#define DEFINE_ARRAY_TYPE(tag, 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_##TAG] = scm_from_utf8_symbol (#tag)
scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
DEFINE_ARRAY_TYPE (a, CHAR);
#define SCM_ARRAY_HANDLE_H
/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2004, 2006,
- * 2008, 2009, 2011, 2013 Free Software Foundation, Inc.
+ * 2008, 2009, 2011, 2013, 2014 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
-struct scm_t_array_handle;
-
-typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, size_t);
-typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, size_t, SCM);
-
-typedef struct
-{
- scm_t_bits tag;
- scm_t_bits mask;
- scm_i_t_array_ref vref;
- scm_i_t_array_set vset;
- void (*get_handle)(SCM, struct scm_t_array_handle*);
-} scm_t_array_implementation;
-
-#define SCM_ARRAY_IMPLEMENTATION(tag_,mask_,vref_,vset_,handle_) \
- SCM_SNARF_INIT ({ \
- scm_t_array_implementation impl; \
- impl.tag = tag_; impl.mask = mask_; \
- impl.vref = vref_; impl.vset = vset_; \
- impl.get_handle = handle_; \
- scm_i_register_array_implementation (&impl); \
- })
-
-
-SCM_INTERNAL void scm_i_register_array_implementation (scm_t_array_implementation *impl);
-SCM_INTERNAL scm_t_array_implementation* scm_i_array_implementation_for_obj (SCM obj);
-
-
-\f
+typedef SCM (*scm_t_vector_ref) (SCM, size_t);
+typedef void (*scm_t_vector_set) (SCM, size_t, SCM);
typedef struct scm_t_array_dim
{
typedef struct scm_t_array_handle {
SCM array;
- scm_t_array_implementation *impl;
+
/* `Base' is an offset into elements or writable_elements, corresponding to
the first element in the array. It would be nicer just to adjust the
elements/writable_elements pointer, but we can't because that element might
scm_t_array_element_type element_type;
const void *elements;
void *writable_elements;
+
+ /* The backing store for the array, and its accessors. */
+ SCM vector;
+ scm_t_vector_ref vref;
+ scm_t_vector_set vset;
} scm_t_array_handle;
#define scm_array_handle_rank(h) ((h)->ndims)
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
- return h->impl->vref (h, h->base + p);
+ return h->vref (h->vector, h->base + p);
}
SCM_INLINE_IMPLEMENTATION void
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
- h->impl->vset (h, h->base + p, v);
+ h->vset (h->vector, h->base + p, v);
}
#endif
/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
- * 2010, 2012, 2013 Free Software Foundation, Inc.
+ * 2010, 2011, 2012, 2013, 2014 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/bitvectors.h"
#include "libguile/srfi-4.h"
#include "libguile/generalized-arrays.h"
-#include "libguile/generalized-vectors.h"
#include "libguile/validate.h"
#include "libguile/array-map.h"
\f
/* The WHAT argument for `scm_gc_malloc ()' et al. */
-static const char indices_gc_hint[] = "array-indices";
+static const char vi_gc_hint[] = "array-indices";
+static SCM
+AREF (SCM v, size_t pos)
+{
+ return scm_c_array_ref_1 (v, pos);
+}
-#define GVREF scm_c_generalized_vector_ref
-#define GVSET scm_c_generalized_vector_set_x
+static void
+ASET (SCM v, size_t pos, SCM val)
+{
+ scm_c_array_set_1_x (v, val, pos);
+}
-static unsigned long
-cind (SCM ra, long *ve)
+static SCM
+make1array (SCM v, ssize_t inc)
{
- unsigned long i;
- int k;
- if (!SCM_I_ARRAYP (ra))
- return *ve;
- i = SCM_I_ARRAY_BASE (ra);
- for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
- i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
- return i;
-}
-
-
-/* Checker for scm_array mapping functions:
- return values: 4 --> shapes, increments, and bases are the same;
- 3 --> shapes and increments are the same;
- 2 --> shapes are the same;
- 1 --> ras are at least as big as ra0;
- 0 --> no match.
- */
-
-int
-scm_ra_matchp (SCM ra0, SCM ras)
-{
- SCM ra1;
- scm_t_array_dim dims;
- scm_t_array_dim *s0 = &dims;
- scm_t_array_dim *s1;
- unsigned long bas0 = 0;
- int i, ndim = 1;
- int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
-
- if (scm_is_generalized_vector (ra0))
- {
- s0->lbnd = 0;
- s0->inc = 1;
- s0->ubnd = scm_c_generalized_vector_length (ra0) - 1;
- }
- else if (SCM_I_ARRAYP (ra0))
- {
- ndim = SCM_I_ARRAY_NDIM (ra0);
- s0 = SCM_I_ARRAY_DIMS (ra0);
- bas0 = SCM_I_ARRAY_BASE (ra0);
- }
- else
- return 0;
+ SCM a = scm_i_make_array (1);
+ SCM_I_ARRAY_SET_BASE (a, 0);
+ SCM_I_ARRAY_DIMS (a)->lbnd = 0;
+ SCM_I_ARRAY_DIMS (a)->ubnd = scm_c_array_length (v) - 1;
+ SCM_I_ARRAY_DIMS (a)->inc = inc;
+ SCM_I_ARRAY_SET_V (a, v);
+ return a;
+}
- while (SCM_NIMP (ras))
+/* Linear index of not-unrolled index set. */
+static size_t
+cindk (SCM ra, ssize_t *ve, int kend)
+{
+ if (SCM_I_ARRAYP (ra))
{
- ra1 = SCM_CAR (ras);
-
- if (scm_is_generalized_vector (ra1))
- {
- size_t length;
-
- if (1 != ndim)
- return 0;
-
- length = scm_c_generalized_vector_length (ra1);
-
- switch (exact)
- {
- case 4:
- if (0 != bas0)
- exact = 3;
- case 3:
- if (1 != s0->inc)
- exact = 2;
- case 2:
- if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
- break;
- exact = 1;
- case 1:
- if (s0->lbnd < 0 || s0->ubnd >= length)
- return 0;
- }
- }
- else if (SCM_I_ARRAYP (ra1) && ndim == SCM_I_ARRAY_NDIM (ra1))
- {
- s1 = SCM_I_ARRAY_DIMS (ra1);
- if (bas0 != SCM_I_ARRAY_BASE (ra1))
- exact = 3;
- for (i = 0; i < ndim; i++)
- switch (exact)
- {
- case 4:
- case 3:
- if (s0[i].inc != s1[i].inc)
- exact = 2;
- case 2:
- if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
- break;
- exact = 1;
- default:
- if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
- return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
- }
- }
- else
- return 0;
-
- ras = SCM_CDR (ras);
+ int k;
+ size_t i = SCM_I_ARRAY_BASE (ra);
+ for (k = 0; k < kend; ++k)
+ i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
+ return i;
}
-
- return exact;
+ else
+ return 0; /* this is BASE */
}
-/* array mapper: apply cproc to each dimension of the given arrays?.
+/* array mapper: apply cproc to each dimension of the given arrays?.
int (*cproc) (); procedure to call on unrolled arrays?
cproc (dest, source list) or
- cproc (dest, data, source list).
- SCM data; data to give to cproc or unbound.
+ cproc (dest, data, source list).
+ SCM data; data to give to cproc or unbound.
SCM ra0; destination array.
SCM lra; list of source arrays.
const char *what; caller, for error reporting. */
-int
+
+#define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd
+#define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd
+
+int
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{
- SCM z;
- SCM vra0, ra1, vra1;
- SCM lvra, *plvra;
- long *vinds;
- int k, kmax;
- int (*cproc) ();
+ int (*cproc) () = cproc_ptr;
+ SCM z, va0, lva, *plva;
+ int k, kmax, kroll;
+ ssize_t *vi, inc;
+ size_t len;
+
+ /* Prepare reference argument. */
+ if (SCM_I_ARRAYP (ra0))
+ {
+ kmax = SCM_I_ARRAY_NDIM (ra0)-1;
+ inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
+ va0 = make1array (SCM_I_ARRAY_V (ra0), inc);
- cproc = cproc_ptr;
- switch (scm_ra_matchp (ra0, lra))
+ /* Find unroll depth */
+ for (kroll = max(0, kmax); kroll > 0; --kroll)
+ {
+ inc *= (UBND (ra0, kroll) - LBND (ra0, kroll) + 1);
+ if (inc != SCM_I_ARRAY_DIMS (ra0)[kroll-1].inc)
+ break;
+ }
+ }
+ else
{
- default:
- case 0:
- scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
- case 2:
- case 3:
- case 4: /* Try unrolling arrays */
- kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_NDIM (ra0) - 1 : 0);
- if (kmax < 0)
- goto gencase;
- vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
- if (SCM_IMP (vra0)) goto gencase;
- if (!SCM_I_ARRAYP (vra0))
- {
- size_t length = scm_c_generalized_vector_length (vra0);
- vra1 = scm_i_make_array (1);
- SCM_I_ARRAY_BASE (vra1) = 0;
- SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
- SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
- SCM_I_ARRAY_DIMS (vra1)->inc = 1;
- SCM_I_ARRAY_V (vra1) = vra0;
- vra0 = vra1;
- }
- lvra = SCM_EOL;
- plvra = &lvra;
- for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
- {
- ra1 = SCM_CAR (z);
- vra1 = scm_i_make_array (1);
- SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
- SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
- if (!SCM_I_ARRAYP (ra1))
- {
- SCM_I_ARRAY_BASE (vra1) = 0;
- SCM_I_ARRAY_DIMS (vra1)->inc = 1;
- SCM_I_ARRAY_V (vra1) = ra1;
- }
- else if (!SCM_I_ARRAY_CONTP (ra1))
- goto gencase;
- else
- {
- SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1);
- SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
- SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
- }
- *plvra = scm_cons (vra1, SCM_EOL);
- plvra = SCM_CDRLOC (*plvra);
- }
- return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
- case 1:
- gencase: /* Have to loop over all dimensions. */
- vra0 = scm_i_make_array (1);
- if (SCM_I_ARRAYP (ra0))
- {
- kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
- if (kmax < 0)
- {
- SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
- SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
- SCM_I_ARRAY_DIMS (vra0)->inc = 1;
- }
- else
- {
- SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
- SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
- SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
- }
- SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
- SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
- }
- else
- {
- size_t length = scm_c_generalized_vector_length (ra0);
- kmax = 0;
- SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
- SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
- SCM_I_ARRAY_DIMS (vra0)->inc = 1;
- SCM_I_ARRAY_BASE (vra0) = 0;
- SCM_I_ARRAY_V (vra0) = ra0;
- ra0 = vra0;
- }
- lvra = SCM_EOL;
- plvra = &lvra;
- for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
- {
- ra1 = SCM_CAR (z);
- vra1 = scm_i_make_array (1);
- SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
- SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
- if (SCM_I_ARRAYP (ra1))
- {
- if (kmax >= 0)
- SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
- SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
- }
- else
- {
- SCM_I_ARRAY_DIMS (vra1)->inc = 1;
- SCM_I_ARRAY_V (vra1) = ra1;
- }
- *plvra = scm_cons (vra1, SCM_EOL);
- plvra = SCM_CDRLOC (*plvra);
- }
-
- 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;
- k = kmax;
- do
- {
- if (k == kmax)
- {
- SCM y = lra;
- SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
- for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
- SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
- if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
- return 0;
- k--;
- continue;
- }
- if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
- {
- vinds[k]++;
- k++;
- continue;
- }
- vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
- k--;
- }
- while (k >= 0);
+ kroll = kmax = 0;
+ va0 = ra0 = make1array (ra0, 1);
+ }
- return 1;
+ /* Prepare rest arguments. */
+ lva = SCM_EOL;
+ plva = &lva;
+ for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
+ {
+ SCM va1, ra1 = SCM_CAR (z);
+ if (SCM_I_ARRAYP (ra1))
+ {
+ if (kmax != SCM_I_ARRAY_NDIM (ra1) - 1)
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
+ inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
+ va1 = make1array (SCM_I_ARRAY_V (ra1), inc);
+
+ /* Check unroll depth. */
+ for (k = kmax; k > kroll; --k)
+ {
+ ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k);
+ if (l0 < LBND (ra1, k) || u0 > UBND (ra1, k))
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
+ inc *= (u0 - l0 + 1);
+ if (inc != SCM_I_ARRAY_DIMS (ra1)[k-1].inc)
+ {
+ kroll = k;
+ break;
+ }
+ }
+
+ /* Check matching of not-unrolled axes. */
+ for (; k>=0; --k)
+ if (LBND (ra0, k) < LBND (ra1, k) || UBND (ra0, k) > UBND (ra1, k))
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
+ }
+ else
+ {
+ if (kmax != 0)
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
+ va1 = make1array (ra1, 1);
+
+ if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0))
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
+ }
+ *plva = scm_cons (va1, SCM_EOL);
+ plva = SCM_CDRLOC (*plva);
}
+
+ /* Check emptiness of not-unrolled axes. */
+ for (k = 0; k < kroll; ++k)
+ if (0 == (UBND (ra0, k) - LBND (ra0, k) + 1))
+ return 1;
+
+ /* Set unrolled size. */
+ for (len = 1; k <= kmax; ++k)
+ len *= (UBND (ra0, k) - LBND (ra0, k) + 1);
+ UBND (va0, 0) = len - 1;
+ for (z = lva; !scm_is_null (z); z = SCM_CDR (z))
+ UBND (SCM_CAR (z), 0) = len - 1;
+
+ /* Set starting indices and go. */
+ vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint);
+ for (k = 0; k < kroll; ++k)
+ vi[k] = LBND (ra0, k);
+ do
+ {
+ if (k == kroll)
+ {
+ SCM y = lra;
+ SCM_I_ARRAY_SET_BASE (va0, cindk (ra0, vi, kroll));
+ for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
+ SCM_I_ARRAY_SET_BASE (SCM_CAR (z), cindk (SCM_CAR (y), vi, kroll));
+ if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data, lva)))
+ return 0;
+ --k;
+ }
+ else if (vi[k] < UBND (ra0, k))
+ {
+ ++vi[k];
+ ++k;
+ }
+ else
+ {
+ vi[k] = LBND (ra0, k) - 1;
+ --k;
+ }
+ }
+ while (k >= 0);
+
+ return 1;
}
+#undef UBND
+#undef LBND
+
static int
rafill (SCM dst, SCM fill)
{
- long n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
scm_t_array_handle h;
- size_t i;
+ size_t n, i;
ssize_t inc;
scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
- i = h.base + h.dims[0].lbnd + SCM_I_ARRAY_BASE (dst)*h.dims[0].inc;
- inc = SCM_I_ARRAY_DIMS (dst)->inc * h.dims[0].inc;
+ i = SCM_I_ARRAY_BASE (dst);
+ inc = SCM_I_ARRAY_DIMS (dst)->inc;
+ n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
+ dst = SCM_I_ARRAY_V (dst);
for (; n-- > 0; i += inc)
- h.impl->vset (&h, i, fill);
+ h.vset (h.vector, i, fill);
scm_array_handle_release (&h);
return 1;
static int
racp (SCM src, SCM dst)
{
- long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
scm_t_array_handle h_s, h_d;
- size_t i_s, i_d;
+ size_t n, i_s, i_d;
ssize_t inc_s, inc_d;
dst = SCM_CAR (dst);
- scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s);
- scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d);
-
- i_s = h_s.base + h_s.dims[0].lbnd + SCM_I_ARRAY_BASE (src) * h_s.dims[0].inc;
- i_d = h_d.base + h_d.dims[0].lbnd + SCM_I_ARRAY_BASE (dst) * h_d.dims[0].inc;
- inc_s = SCM_I_ARRAY_DIMS (src)->inc * h_s.dims[0].inc;
- inc_d = SCM_I_ARRAY_DIMS (dst)->inc * h_d.dims[0].inc;
-
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
+ i_s = SCM_I_ARRAY_BASE (src);
+ i_d = SCM_I_ARRAY_BASE (dst);
+ inc_s = SCM_I_ARRAY_DIMS (src)->inc;
+ inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
+ n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
+ src = SCM_I_ARRAY_V (src);
+ dst = SCM_I_ARRAY_V (dst);
+
+ scm_array_get_handle (src, &h_s);
+ scm_array_get_handle (dst, &h_d);
+
+ if (h_s.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM
+ && h_d.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ {
+ SCM const * el_s = h_s.elements;
+ SCM * el_d = h_d.writable_elements;
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ el_d[i_d] = el_s[i_s];
+ }
+ else
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ h_d.vset (h_d.vector, i_d, h_s.vref (h_s.vector, i_s));
scm_array_handle_release (&h_d);
scm_array_handle_release (&h_s);
ra = SCM_I_ARRAY_V (ra);
for (i = base; n--; i += inc)
- GVSET (ra, i, fill);
+ ASET (ra, i, fill);
return 1;
}
{
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
- if (!scm_is_eq (GVREF (ra1, i1), GVREF (ra2, i2)))
+ if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2)))
scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
}
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
if (opt ?
- scm_is_true (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))) :
- scm_is_false (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))))
+ scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) :
+ scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))))
scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
}
default:
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_sum (GVREF(ra0, i0), GVREF(ra1, i1)));
+ ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1)));
break;
}
}
default:
{
for (; n-- > 0; i0 += inc0)
- GVSET (ra0, i0, scm_difference (GVREF(ra0, i0), SCM_UNDEFINED));
+ ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED));
break;
}
}
default:
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_difference (GVREF (ra0, i0),
- GVREF (ra1, i1)));
+ ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1)));
break;
}
}
default:
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
- GVSET (ra0, i0, scm_product (GVREF (ra0, i0),
- GVREF (ra1, i1)));
+ ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1)));
}
}
}
default:
{
for (; n-- > 0; i0 += inc0)
- GVSET (ra0, i0, scm_divide (GVREF (ra0, i0), SCM_UNDEFINED));
+ ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED));
break;
}
}
{
for (; n-- > 0; i0 += inc0, i1 += inc1)
{
- SCM res = scm_divide (GVREF (ra0, i0),
- GVREF (ra1, i1));
- GVSET (ra0, i0, res);
+ SCM res = scm_divide (AREF (ra0, i0), AREF (ra1, i1));
+ ASET (ra0, i0, res);
}
break;
}
static int
ramap (SCM ra0, SCM proc, SCM ras)
{
- ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
- size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
-
scm_t_array_handle h0;
- size_t i0, i0end;
- ssize_t inc0;
- scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
- i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
- i0end = i0 + n*inc0;
+ size_t n, i0;
+ ssize_t i, inc0;
+ i0 = SCM_I_ARRAY_BASE (ra0);
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+ n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ scm_array_get_handle (ra0, &h0);
if (scm_is_null (ras))
- for (; i0 < i0end; i0 += inc0)
- h0.impl->vset (&h0, i0, scm_call_0 (proc));
+ for (; n--; i0 += inc0)
+ h0.vset (h0.vector, i0, scm_call_0 (proc));
else
{
SCM ra1 = SCM_CAR (ras);
scm_t_array_handle h1;
size_t i1;
ssize_t inc1;
- scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1);
- i1 = h1.base + h1.dims[0].lbnd + SCM_I_ARRAY_BASE (ra1)*h1.dims[0].inc;
- inc1 = SCM_I_ARRAY_DIMS (ra1)->inc * h1.dims[0].inc;
+ i1 = SCM_I_ARRAY_BASE (ra1);
+ inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
ras = SCM_CDR (ras);
+ ra1 = SCM_I_ARRAY_V (ra1);
+ scm_array_get_handle (ra1, &h1);
if (scm_is_null (ras))
- for (; i0 < i0end; i0 += inc0, i1 += inc1)
- h0.impl->vset (&h0, i0, scm_call_1 (proc, h1.impl->vref (&h1, i1)));
+ for (; n--; i0 += inc0, i1 += inc1)
+ h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1)));
else
{
ras = scm_vector (ras);
- for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i)
+ for (; n--; i0 += inc0, i1 += inc1, ++i)
{
SCM args = SCM_EOL;
unsigned long k;
for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
- h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1, i1), args));
+ args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
+ h0.vset (h0.vector, i0,
+ scm_apply_1 (proc, h1.vref (h1.vector, i1), args));
}
}
scm_array_handle_release (&h1);
size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
scm_t_array_handle h0;
- size_t i0, i0end;
+ size_t i0;
ssize_t inc0;
- scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
- i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
- inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
- i0end = i0 + n*inc0;
+ i0 = SCM_I_ARRAY_BASE (ra0);
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ scm_array_get_handle (ra0, &h0);
if (scm_is_null (ras))
- for (; i0 < i0end; i0 += inc0)
- scm_call_1 (proc, h0.impl->vref (&h0, i0));
+ for (; n--; i0 += inc0)
+ scm_call_1 (proc, h0.vref (h0.vector, i0));
else
{
ras = scm_vector (ras);
- for (; i0 < i0end; i0 += inc0, ++i)
+ for (; n--; i0 += inc0, ++i)
{
SCM args = SCM_EOL;
unsigned long k;
for (k = scm_c_vector_length (ras); k--;)
- args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
- scm_apply_1 (proc, h0.impl->vref (&h0, i0), args);
+ args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args);
+ scm_apply_1 (proc, h0.vref (h0.vector, i0), args);
}
}
scm_array_handle_release (&h0);
}
#undef FUNC_NAME
+static void
+array_index_map_1 (SCM ra, SCM proc)
+{
+ scm_t_array_handle h;
+ ssize_t i, inc;
+ size_t p;
+ scm_array_get_handle (ra, &h);
+ inc = h.dims[0].inc;
+ for (i = h.dims[0].lbnd, p = h.base; i <= h.dims[0].ubnd; ++i, p += inc)
+ h.vset (h.vector, p, scm_call_1 (proc, scm_from_ssize_t (i)));
+ scm_array_handle_release (&h);
+}
+
+/* Here we assume that the array is a scm_tc7_array, as that is the only
+ kind of array in Guile that supports rank > 1. */
+static void
+array_index_map_n (SCM ra, SCM proc)
+{
+ scm_t_array_handle h;
+ size_t i;
+ int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
+ ssize_t *vi;
+ SCM **si;
+ SCM args = SCM_EOL;
+ SCM *p = &args;
+
+ vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint);
+ si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint);
+
+ for (k = 0; k <= kmax; k++)
+ {
+ vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ if (vi[k] > SCM_I_ARRAY_DIMS (ra)[k].ubnd)
+ return;
+ *p = scm_cons (scm_from_ssize_t (vi[k]), SCM_EOL);
+ si[k] = SCM_CARLOC (*p);
+ p = SCM_CDRLOC (*p);
+ }
+
+ scm_array_get_handle (ra, &h);
+ k = kmax;
+ do
+ {
+ if (k == kmax)
+ {
+ vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd;
+ i = cindk (ra, vi, kmax+1);
+ for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax])
+ {
+ *(si[kmax]) = scm_from_ssize_t (vi[kmax]);
+ h.vset (h.vector, i, scm_apply_0 (proc, args));
+ i += SCM_I_ARRAY_DIMS (ra)[kmax].inc;
+ }
+ k--;
+ }
+ else if (vi[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
+ {
+ *(si[k]) = scm_from_ssize_t (++vi[k]);
+ k++;
+ }
+ else
+ {
+ vi[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
+ k--;
+ }
+ }
+ while (k >= 0);
+ scm_array_handle_release (&h);
+}
+
SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
(SCM ra, SCM proc),
"Apply @var{proc} to the indices of each element of @var{ra} in\n"
"@end lisp")
#define FUNC_NAME s_scm_array_index_map_x
{
- unsigned long i;
SCM_VALIDATE_PROC (2, proc);
- if (SCM_I_ARRAYP (ra))
- {
- SCM args = SCM_EOL;
- int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
- long *vinds;
-
- if (kmax < 0)
- return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
-
- 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;
- k = kmax;
- do
- {
- if (k == kmax)
- {
- vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
- i = cind (ra, vinds);
- for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
- {
- for (j = kmax + 1, args = SCM_EOL; j--;)
- args = scm_cons (scm_from_long (vinds[j]), args);
- GVSET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
- i += SCM_I_ARRAY_DIMS (ra)[k].inc;
- }
- k--;
- continue;
- }
- if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
- {
- vinds[k]++;
- k++;
- continue;
- }
- vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
- k--;
- }
- while (k >= 0);
-
- return SCM_UNSPECIFIED;
- }
- else if (scm_is_generalized_vector (ra))
+ switch (scm_c_array_rank (ra))
{
- size_t length = scm_c_generalized_vector_length (ra);
- for (i = 0; i < length; i++)
- GVSET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
- return SCM_UNSPECIFIED;
+ case 0:
+ scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
+ break;
+ case 1:
+ array_index_map_1 (ra, proc);
+ break;
+ default:
+ array_index_map_n (ra, proc);
+ break;
}
- else
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
return 0;
i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;
-
+
incx = hx->dims[dim].inc;
incy = hy->dims[dim].inc;
posx += (i - 1) * incx;
scm_array_equal_p (SCM x, SCM y)
{
scm_t_array_handle hx, hy;
- SCM res;
-
+ SCM res;
+
scm_array_get_handle (x, &hx);
scm_array_get_handle (y, &hy);
-
+
res = scm_from_bool (hx.ndims == hy.ndims
&& hx.element_type == hy.element_type);
{
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;
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
- * 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
- *
+ * 2006, 2009, 2010, 2011, 2012, 2013, 2014 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 <stdio.h>
#include <errno.h>
#include <string.h>
+#include <assert.h>
+
+#include "verify.h"
#include "libguile/_scm.h"
#include "libguile/__scm.h"
(SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
-SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
+SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
(SCM ra),
"Return the root vector of a shared array.")
#define FUNC_NAME s_scm_shared_array_root
{
if (SCM_I_ARRAYP (ra))
return SCM_I_ARRAY_V (ra);
- else if (scm_is_generalized_vector (ra))
+ else if (!scm_is_array (ra))
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
+ else
return ra;
- scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
-SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
+SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
(SCM ra),
"Return the root vector index of the first element in the array.")
#define FUNC_NAME s_scm_shared_array_offset
#undef FUNC_NAME
-SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
+SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
(SCM ra),
"For each dimension, return the distance between elements in the root vector.")
#define FUNC_NAME s_scm_shared_array_increments
}
#undef FUNC_NAME
+/* FIXME: to avoid this assumption, fix the accessors in arrays.h,
+ scm_i_make_array, and the array cases in system/vm/assembler.scm. */
+
+verify (sizeof (scm_t_array_dim) == 3*sizeof (scm_t_bits));
+
+/* Matching SCM_I_ARRAY accessors in arrays.h */
SCM
scm_i_make_array (int ndim)
{
- SCM ra;
- ra = scm_cell (((scm_t_bits) ndim << 17) + scm_tc7_array,
- (scm_t_bits) scm_gc_malloc (sizeof (scm_i_t_array) +
- ndim * sizeof (scm_t_array_dim),
- "array"));
- SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
+ SCM ra = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
+ SCM_I_ARRAY_SET_V (ra, SCM_BOOL_F);
+ SCM_I_ARRAY_SET_BASE (ra, 0);
+ /* dimensions are unset */
return ra;
}
/* Increments will still need to be set. */
-static SCM
+static SCM
scm_i_shap2ra (SCM args)
{
scm_t_array_dim *s;
- SCM ra, spec, sp;
+ SCM ra, spec;
int ndim = scm_ilength (args);
if (ndim < 0)
scm_misc_error (NULL, s_bad_spec, SCM_EOL);
ra = scm_i_make_array (ndim);
- SCM_I_ARRAY_BASE (ra) = 0;
+ SCM_I_ARRAY_SET_BASE (ra, 0);
s = SCM_I_ARRAY_DIMS (ra);
for (; !scm_is_null (args); s++, args = SCM_CDR (args))
{
spec = SCM_CAR (args);
if (scm_is_integer (spec))
{
- if (scm_to_long (spec) < 0)
- scm_misc_error (NULL, s_bad_spec, SCM_EOL);
s->lbnd = 0;
- s->ubnd = scm_to_long (spec) - 1;
- s->inc = 1;
+ s->ubnd = scm_to_ssize_t (spec);
+ if (s->ubnd < 0)
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
+ --s->ubnd;
}
else
{
if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec)))
scm_misc_error (NULL, s_bad_spec, SCM_EOL);
- s->lbnd = scm_to_long (SCM_CAR (spec));
- sp = SCM_CDR (spec);
- if (!scm_is_pair (sp)
- || !scm_is_integer (SCM_CAR (sp))
- || !scm_is_null (SCM_CDR (sp)))
+ s->lbnd = scm_to_ssize_t (SCM_CAR (spec));
+ spec = SCM_CDR (spec);
+ if (!scm_is_pair (spec)
+ || !scm_is_integer (SCM_CAR (spec))
+ || !scm_is_null (SCM_CDR (spec)))
scm_misc_error (NULL, s_bad_spec, SCM_EOL);
- s->ubnd = scm_to_long (SCM_CAR (sp));
- s->inc = 1;
+ s->ubnd = scm_to_ssize_t (SCM_CAR (spec));
+ if (s->ubnd - s->lbnd < -1)
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
}
+ s->inc = 1;
}
return ra;
}
size_t k, rlen = 1;
scm_t_array_dim *s;
SCM ra;
-
+
ra = scm_i_shap2ra (bounds);
SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
if (scm_is_eq (fill, SCM_UNSPECIFIED))
fill = SCM_UNDEFINED;
- SCM_I_ARRAY_V (ra) =
- scm_make_generalized_vector (type, scm_from_size_t (rlen), fill);
+ SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t (rlen), fill));
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ if (0 == s->lbnd)
return SCM_I_ARRAY_V (ra);
+
return ra;
}
#undef FUNC_NAME
scm_t_array_handle h;
void *elts;
size_t sz;
-
+
ra = scm_i_shap2ra (bounds);
SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
}
- SCM_I_ARRAY_V (ra) =
- scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED);
+ SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED));
scm_array_get_handle (ra, &h);
}
else if (sz < 8)
{
- /* byte_len ?= ceil (rlen * sz / 8) */
- if (byte_len != (rlen * sz + 7) / 8)
+ /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
+ units. */
+ if (byte_len != ((rlen * sz + 31) / 32) * 4)
SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
}
else
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))
+ if (0 == s->lbnd)
return SCM_I_ARRAY_V (ra);
return ra;
}
scm_t_array_dim *s;
SCM ra;
scm_t_array_handle h;
-
+
ra = scm_i_shap2ra (bounds);
SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
if (rlen != len)
SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);
- SCM_I_ARRAY_V (ra) = scm_c_make_vector (rlen, SCM_UNDEFINED);
+ SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED));
scm_array_get_handle (ra, &h);
memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
scm_array_handle_release (&h);
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ if (0 == s->lbnd)
return SCM_I_ARRAY_V (ra);
return ra;
}
}
#undef FUNC_NAME
-static void
+static void
scm_i_ra_set_contp (SCM ra)
{
size_t k = SCM_I_ARRAY_NDIM (ra);
if (k)
{
- long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
+ ssize_t inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
while (k--)
{
if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
return;
}
- inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
+ inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
- SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
}
}
if (SCM_I_ARRAYP (oldra))
{
- SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
+ SCM_I_ARRAY_SET_V (ra, SCM_I_ARRAY_V (oldra));
old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
s = scm_array_handle_dims (&old_handle);
k = scm_array_handle_rank (&old_handle);
}
else
{
- SCM_I_ARRAY_V (ra) = oldra;
+ SCM_I_ARRAY_SET_V (ra, oldra);
old_base = old_min = 0;
- old_max = scm_c_generalized_vector_length (oldra) - 1;
+ old_max = scm_c_array_length (oldra) - 1;
}
inds = SCM_EOL;
s = SCM_I_ARRAY_DIMS (ra);
for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
{
- inds = scm_cons (scm_from_long (s[k].lbnd), inds);
+ inds = scm_cons (scm_from_ssize_t (s[k].lbnd), inds);
if (s[k].ubnd < s[k].lbnd)
{
if (1 == SCM_I_ARRAY_NDIM (ra))
ra = scm_make_generalized_vector (scm_array_type (ra),
SCM_INUM0, SCM_UNDEFINED);
else
- SCM_I_ARRAY_V (ra) =
- scm_make_generalized_vector (scm_array_type (ra),
- SCM_INUM0, SCM_UNDEFINED);
+ SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (scm_array_type (ra),
+ SCM_INUM0, SCM_UNDEFINED));
scm_array_handle_release (&old_handle);
return ra;
}
imap = scm_apply_0 (mapfunc, scm_reverse (inds));
i = scm_array_handle_pos (&old_handle, imap);
- SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
+ new_min = new_max = i + old_base;
+ SCM_I_ARRAY_SET_BASE (ra, new_min);
indptr = inds;
k = SCM_I_ARRAY_NDIM (ra);
while (k--)
if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
{
SCM v = SCM_I_ARRAY_V (ra);
- size_t length = scm_c_generalized_vector_length (v);
+ size_t length = scm_c_array_length (v);
if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
return v;
if (s->ubnd < s->lbnd)
/* args are RA . DIMS */
-SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
+SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
(SCM ra, SCM args),
"Return an array sharing contents with @var{ra}, but with\n"
"dimensions arranged in a different order. There must be one\n"
int ndim, i, k;
SCM_VALIDATE_REST_ARGUMENT (args);
- SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
- if (scm_is_generalized_vector (ra))
+ switch (scm_c_array_rank (ra))
{
+ case 0:
+ if (!scm_is_null (args))
+ SCM_WRONG_NUM_ARGS ();
+ return ra;
+ case 1:
/* Make sure that we are called with a single zero as
- arguments.
+ arguments.
*/
if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
SCM_WRONG_NUM_ARGS ();
SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
return ra;
- }
-
- if (SCM_I_ARRAYP (ra))
- {
+ default:
vargs = scm_vector (args);
if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
SCM_WRONG_NUM_ARGS ();
}
ndim++;
res = scm_i_make_array (ndim);
- SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
- SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
+ SCM_I_ARRAY_SET_V (res, SCM_I_ARRAY_V (ra));
+ SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (ra));
for (k = ndim; k--;)
{
SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
r->ubnd = s->ubnd;
if (r->lbnd < s->lbnd)
{
- SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
+ SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (res) + (s->lbnd - r->lbnd) * r->inc);
r->lbnd = s->lbnd;
}
r->inc += s->inc;
scm_i_ra_set_contp (res);
return res;
}
-
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
}
#undef FUNC_NAME
/* attempts to unroll an array into a one-dimensional array.
returns the unrolled array or #f if it can't be done. */
- /* if strict is not SCM_UNDEFINED, return #f if returned array
- wouldn't have contiguous elements. */
+/* if strict is true, return #f if returned array
+ wouldn't have contiguous elements. */
SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
(SCM ra, SCM strict),
"If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
"contiguous in memory.")
#define FUNC_NAME s_scm_array_contents
{
- SCM sra;
-
- if (scm_is_generalized_vector (ra))
- return ra;
-
- if (SCM_I_ARRAYP (ra))
+ if (!scm_is_array (ra))
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+ else if (SCM_I_ARRAYP (ra))
{
+ SCM v;
size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
- if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
+ if (!SCM_I_ARRAY_CONTP (ra))
return SCM_BOOL_F;
for (k = 0; k < ndim; k++)
len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
return SCM_BOOL_F;
}
}
-
- {
- SCM v = SCM_I_ARRAY_V (ra);
- size_t length = scm_c_generalized_vector_length (v);
- if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
- return v;
- }
-
- sra = scm_i_make_array (1);
- SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
- SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
- SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
- SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
- SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
- return sra;
+
+ v = SCM_I_ARRAY_V (ra);
+ if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra)))
+ return v;
+ else
+ {
+ SCM sra = scm_i_make_array (1);
+ SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
+ SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
+ SCM_I_ARRAY_SET_V (sra, v);
+ SCM_I_ARRAY_SET_BASE (sra, SCM_I_ARRAY_BASE (ra));
+ SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
+ return sra;
+ }
}
else
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+ return ra;
}
#undef FUNC_NAME
if (!scm_is_null (lst))
errmsg = "too many elements for array dimension ~a, want ~a";
if (errmsg)
- scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
+ scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_size_t (k),
scm_from_size_t (len)));
}
}
-
+
SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
(SCM type, SCM shape, SCM lst),
else
{
ssize_t i;
- scm_putc ('(', port);
+ scm_putc_unlocked ('(', port);
for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd;
i++, pos += h->dims[dim].inc)
{
scm_i_print_array_dimension (h, dim+1, pos, port, pstate);
if (i < h->dims[dim].ubnd)
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
}
return 1;
}
scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
{
scm_t_array_handle h;
- long i;
+ size_t i;
int print_lbnds = 0, zero_size = 0, print_lens = 0;
scm_array_get_handle (array, &h);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
if (h.ndims != 1 || h.dims[0].lbnd != 0)
scm_intprint (h.ndims, 10, port);
if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
scm_write (scm_array_handle_element_type (&h), port);
-
+
for (i = 0; i < h.ndims; i++)
{
if (h.dims[i].lbnd != 0)
{
if (print_lbnds)
{
- scm_putc ('@', port);
+ scm_putc_unlocked ('@', port);
scm_intprint (h.dims[i].lbnd, 10, port);
}
if (print_lens)
{
- scm_putc (':', port);
+ scm_putc_unlocked (':', port);
scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
10, port);
}
not really the same as Scheme values since they are boxed and
can be modified with array-set!, say.
*/
- scm_putc ('(', port);
+ scm_putc_unlocked ('(', port);
scm_i_print_array_dimension (&h, 0, 0, port, pstate);
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
return 1;
}
else
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
-static SCM
-array_handle_ref (scm_t_array_handle *h, size_t pos)
-{
- return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos);
-}
-
-static void
-array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
-{
- scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val);
-}
-
-/* FIXME: should be handle for vect? maybe not, because of dims */
-static void
-array_get_handle (SCM array, scm_t_array_handle *h)
-{
- scm_t_array_handle vh;
- scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
- h->element_type = vh.element_type;
- h->elements = vh.elements;
- h->writable_elements = vh.writable_elements;
- scm_array_handle_release (&vh);
-
- h->dims = SCM_I_ARRAY_DIMS (array);
- h->ndims = SCM_I_ARRAY_NDIM (array);
- h->base = SCM_I_ARRAY_BASE (array);
-}
-
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_array,
- 0x7f,
- array_handle_ref, array_handle_set,
- array_get_handle)
-
void
scm_init_arrays ()
{
/* internal. */
-typedef struct scm_i_t_array
-{
- SCM v; /* the contents of the array, e.g., a vector or uniform vector. */
- unsigned long base;
-} scm_i_t_array;
-
#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)
#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a)
#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17))
#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))
-#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a))
-#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v)
-#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
-#define SCM_I_ARRAY_DIMS(a) \
- ((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array)))
+#define SCM_I_ARRAY_V(a) SCM_CELL_OBJECT_1 (a)
+#define SCM_I_ARRAY_BASE(a) ((size_t) SCM_CELL_WORD_2 (a))
+#define SCM_I_ARRAY_DIMS(a) ((scm_t_array_dim *) SCM_CELL_OBJECT_LOC (a, 3))
+
+#define SCM_I_ARRAY_SET_V(a, v) SCM_SET_CELL_OBJECT_1(a, v)
+#define SCM_I_ARRAY_SET_BASE(a, base) SCM_SET_CELL_WORD_2(a, base)
SCM_INTERNAL SCM scm_i_make_array (int ndim);
SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate);
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008,
- * 2009, 2010, 2014 Free Software Foundation, Inc.
+ * 2009, 2010, 2011, 2014 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/eval.h"
#include "libguile/throw.h"
/* System asyncs. */
void
-scm_async_click ()
+scm_async_tick (void)
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
SCM asyncs;
}
}
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
- (SCM thunk),
- "This function is deprecated. You can use @var{thunk} directly\n"
- "instead of explicitly creating an async object.\n")
-#define FUNC_NAME s_scm_system_async
-{
- scm_c_issue_deprecation_warning
- ("'system-async' is deprecated. "
- "Use the procedure directly with 'system-async-mark'.");
- return thunk;
-}
-#undef FUNC_NAME
-
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
-
void
scm_i_queue_async_cell (SCM c, scm_i_thread *t)
{
\f
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0,
- (),
- "Unmask signals. The returned value is not specified.")
-#define FUNC_NAME s_scm_unmask_signals
-{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
-
- scm_c_issue_deprecation_warning
- ("'unmask-signals' is deprecated. "
- "Use 'call-with-blocked-asyncs' instead.");
-
- if (t->block_asyncs == 0)
- SCM_MISC_ERROR ("signals already unmasked", SCM_EOL);
- t->block_asyncs = 0;
- scm_async_click ();
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
- (),
- "Mask signals. The returned value is not specified.")
-#define FUNC_NAME s_scm_mask_signals
-{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
-
- scm_c_issue_deprecation_warning
- ("'mask-signals' is deprecated. Use 'call-with-blocked-asyncs' instead.");
-
- if (t->block_asyncs > 0)
- SCM_MISC_ERROR ("signals already masked", SCM_EOL);
- t->block_asyncs = 1;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
-
static void
increase_block (void *data)
{
{
scm_i_thread *t = data;
if (--t->block_asyncs == 0)
- scm_async_click ();
+ scm_async_tick ();
}
void
SCM_CRITICAL_SECTION_END;
}
-void
-scm_async_tick (void)
-{
- SCM_ASYNC_TICK;
-}
-
\f
void
#ifndef SCM_ASYNC_H
#define SCM_ASYNC_H
-/* Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2008, 2009,
+/* Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2008, 2009, 2011
* 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
\f
-SCM_API void scm_async_click (void);
+SCM_API void scm_async_tick (void);
SCM_API void scm_switch (void);
SCM_API SCM scm_async (SCM thunk);
SCM_API SCM scm_async_mark (SCM a);
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_tick (); \
} while (0)
# define scm_i_pthread_mutex_lock_block_asyncs(m) \
SCM_INTERNAL void scm_init_async (void);
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-SCM_DEPRECATED SCM scm_system_async (SCM thunk);
-SCM_DEPRECATED SCM scm_unmask_signals (void);
-SCM_DEPRECATED SCM scm_mask_signals (void);
-
-#endif
-
#endif /* SCM_ASYNC_H */
/*
boot_print_exception (SCM port, SCM frame, SCM key, SCM args)
#define FUNC_NAME "boot-print-exception"
{
- scm_puts ("Throw to key ", port);
+ scm_puts_unlocked ("Throw to key ", port);
scm_write (key, port);
- scm_puts (" with args ", port);
+ scm_puts_unlocked (" with args ", port);
scm_write (args, port);
return SCM_UNSPECIFIED;
}
{
int i;
for (i = 0; i < n; ++i)
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
static void
display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{
int i = 0, n;
- scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (sport);
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (sport);
do
{
pstate->length = print_params[i].length;
{
pstate->level = print_params[i].level - 1;
scm_iprlist (hdr, exp, tlr[0], sport, pstate);
- scm_puts (&tlr[1], sport);
+ scm_puts_unlocked (&tlr[1], sport);
}
else
{
static void
display_application (SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{
- 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_arguments (frame)),
- "]",
+ display_frame_expr ("[", scm_frame_call_representation (frame), "]",
indentation,
sport,
port,
*last_file = file;
- scm_puts ("In ", port);
+ scm_puts_unlocked ("In ", port);
if (scm_is_false (file))
if (scm_is_false (line))
- scm_puts ("unknown file", port);
+ scm_puts_unlocked ("unknown file", port);
else
- scm_puts ("current input", port);
+ scm_puts_unlocked ("current input", port);
else
{
pstate->writingp = 0;
scm_iprin1 (file, port, pstate);
pstate->writingp = 1;
}
- scm_puts (":\n", port);
+ scm_puts_unlocked (":\n", port);
}
static void
if (scm_is_false (file))
{
if (scm_is_false (line))
- scm_putc ('?', port);
+ scm_putc_unlocked ('?', port);
else
- scm_puts ("<stdin>", port);
+ scm_puts_unlocked ("<stdin>", port);
}
else
{
pstate -> writingp = 1;
}
- scm_putc (':', port);
+ scm_putc_unlocked (':', port);
}
else if (scm_is_true (line))
{
}
if (scm_is_false (line))
- scm_puts (" ?", port);
+ scm_puts_unlocked (" ?", port);
else
scm_intprint (scm_to_int (line) + 1, 10, port);
- scm_puts (": ", port);
+ scm_puts_unlocked (": ", port);
}
static void
/* Display an application. */
display_application (frame, nfield + 1 + indentation, sport, port, pstate);
- scm_putc ('\n', port);
+ scm_putc_unlocked ('\n', port);
}
struct display_backtrace_args {
static SCM
error_during_backtrace (void *data, SCM tag, SCM throw_args)
{
- SCM port = PTR2SCM (data);
+ SCM port = SCM_PACK_POINTER (data);
- scm_puts ("Exception thrown while printing backtrace:\n", port);
+ scm_puts_unlocked ("Exception thrown while printing backtrace:\n", port);
scm_print_exception (port, SCM_BOOL_F, tag, throw_args);
return SCM_UNSPECIFIED;
scm_internal_catch (SCM_BOOL_T,
(scm_t_catch_body) display_backtrace_body, &a,
- (scm_t_catch_handler) error_during_backtrace, SCM2PTR (port));
+ (scm_t_catch_handler) error_during_backtrace, SCM_UNPACK_POINTER (port));
return SCM_UNSPECIFIED;
}
highlights = SCM_EOL;
scm_newline (port);
- scm_puts ("Backtrace:\n", port);
+ scm_puts_unlocked ("Backtrace:\n", port);
scm_display_backtrace_with_highlights (stack, port, SCM_BOOL_F, SCM_BOOL_F,
highlights);
scm_newline (port);
#ifndef SCM_BDW_GC_H
#define SCM_BDW_GC_H
-/* Copyright (C) 2006, 2008, 2009, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2008, 2009, 2011, 2012, 2013, 2014 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 <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
-
/* Return true if PTR points to the heap. */
#define SCM_I_IS_POINTER_TO_THE_HEAP(ptr) \
(GC_base (ptr) != NULL)
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 2012, 2013, 2014 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 IS_BITVECTOR(obj) SCM_TYP16_PREDICATE(scm_tc7_bitvector,(obj))
-#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_1(obj))
-#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_2(obj))
+#define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_1(obj))
+#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_2(obj))
+
+scm_t_uint32 *scm_i_bitvector_bits (SCM vec)
+{
+ if (!IS_BITVECTOR (vec))
+ abort ();
+ return BITVECTOR_BITS (vec);
+}
int
scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate)
scm_t_uint32 *bits = BITVECTOR_BITS (vec);
size_t i, j;
- scm_puts ("#*", port);
+ scm_puts_unlocked ("#*", port);
for (i = 0; i < word_len; i++, bit_len -= 32)
{
scm_t_uint32 mask = 1;
for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
- scm_putc ((bits[i] & mask)? '1' : '0', port);
+ scm_putc_unlocked ((bits[i] & mask)? '1' : '0', port);
}
return 1;
bits = scm_gc_malloc_pointerless (sizeof (scm_t_uint32) * word_len,
"bitvector");
- res = scm_double_cell (scm_tc7_bitvector, (scm_t_bits)bits, len, 0);
+ res = scm_double_cell (scm_tc7_bitvector, len, (scm_t_bits)bits, 0);
if (!SCM_UNBNDP (fill))
scm_bitvector_fill_x (res, fill);
return res;
}
-/* FIXME: h->array should be h->vector */
-static SCM
-bitvector_handle_ref (scm_t_array_handle *h, size_t pos)
-{
- return scm_c_bitvector_ref (h->array, pos);
-}
-
-static void
-bitvector_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
-{
- scm_c_bitvector_set_x (h->array, pos, val);
-}
-
-static void
-bitvector_get_handle (SCM bv, scm_t_array_handle *h)
-{
- h->array = bv;
- h->ndims = 1;
- h->dims = &h->dim0;
- h->dim0.lbnd = 0;
- h->dim0.ubnd = BITVECTOR_LENGTH (bv) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_ARRAY_ELEMENT_TYPE_BIT;
- h->elements = h->writable_elements = BITVECTOR_BITS (bv);
-}
-
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_bitvector,
- 0x7f,
- bitvector_handle_ref, bitvector_handle_set,
- bitvector_get_handle)
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector)
void
#ifndef SCM_BITVECTORS_H
#define SCM_BITVECTORS_H
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2014 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
size_t *lenp,
ssize_t *incp);
+SCM_INTERNAL scm_t_uint32 *scm_i_bitvector_bits (SCM vec);
SCM_INTERNAL int scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate);
SCM_INTERNAL SCM scm_i_bitvector_equal_p (SCM vec1, SCM vec2);
SCM_INTERNAL void scm_init_bitvectors (void);
}
#undef FUNC_NAME
+SCM_DEFINE (scm_nil_p, "nil?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is nil, else return @code{#f}.")
+#define FUNC_NAME s_scm_nil_p
+{
+ return scm_from_bool (scm_is_lisp_false (x));
+}
+#undef FUNC_NAME
SCM_DEFINE (scm_boolean_p, "boolean?", 1, 0, 0,
(SCM obj),
#ifndef SCM_BOOLEAN_H
#define SCM_BOOLEAN_H
-/* Copyright (C) 1995,1996,2000, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000, 2006, 2008, 2009, 2010, 2013 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_not (SCM x);
SCM_API SCM scm_boolean_p (SCM obj);
+SCM_API SCM scm_nil_p (SCM obj);
SCM_INTERNAL void scm_init_boolean (void);
-/* Copyright (C) 2009-2014 Free Software Foundation, Inc.
+/* Copyright (C) 2009-2015 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_SET_BYTEVECTOR_FLAGS ((bv), \
(hint) \
| (SCM_BYTEVECTOR_CONTIGUOUS_P (bv) << 8UL))
+#define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \
+ SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
+
#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
(scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
|| scm_i_array_element_type_sizes[element_type] < 8
- || len >= (SCM_I_SIZE_MAX
+ || len >= (((size_t) -1)
/ (scm_i_array_element_type_sizes[element_type]/8))))
/* This would be an internal Guile programming error */
abort ();
contents = scm_gc_malloc_pointerless (SCM_BYTEVECTOR_HEADER_BYTES + c_len,
SCM_GC_BYTEVECTOR);
- ret = PTR2SCM (contents);
+ ret = SCM_PACK_POINTER (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_PARENT (ret, SCM_BOOL_F);
}
return ret;
{
size_t c_len;
- ret = PTR2SCM (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES,
+ ret = SCM_PACK_POINTER (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_CONTENTS (ret, contents);
SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 0);
SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
+ SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F);
}
return ret;
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 ()'. */
+/* Return a bytevector of size LEN made up of CONTENTS. The area
+ pointed to by CONTENTS must be protected from GC somehow: either
+ because it was allocated using `scm_gc_malloc ()', or because it is
+ part of PARENT. */
SCM
-scm_c_take_gc_bytevector (signed char *contents, size_t len)
+scm_c_take_gc_bytevector (signed char *contents, size_t len, SCM parent)
{
- return make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ SCM ret;
+
+ ret = make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ SCM_BYTEVECTOR_SET_PARENT (ret, parent);
+
+ return ret;
}
SCM
scm_c_take_typed_bytevector (signed char *contents, size_t len,
- scm_t_array_element_type element_type)
+ scm_t_array_element_type element_type, SCM parent)
{
- return make_bytevector_from_buffer (len, contents, element_type);
+ SCM ret;
+
+ ret = make_bytevector_from_buffer (len, contents, element_type);
+ SCM_BYTEVECTOR_SET_PARENT (ret, parent);
+
+ return ret;
}
/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
scm_array_get_handle (bv, &h);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
scm_write (scm_array_handle_element_type (&h), port);
- scm_putc ('(', port);
+ scm_putc_unlocked ('(', port);
for (i = h.dims[0].lbnd, ubnd = h.dims[0].ubnd, inc = h.dims[0].inc;
i <= ubnd; i += inc)
{
if (i > 0)
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_write (scm_array_handle_ref (&h, i), port);
}
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
return 1;
}
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;
+ /* Elements of sub-byte size (bitvectors) are addressed in 32-bit
+ units. */
+ byte_len = ((len * sz + 31) / 32) * 4;
else
/* an internal guile error, really */
SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);
/* C_SIZE must have its 3 higher bits set to zero so that \
multiplying it by 8 yields a number that fits in a \
size_t. */ \
- if (SCM_UNLIKELY (c_size == 0 || c_size >= (SCM_I_SIZE_MAX >> 3))) \
+ if (SCM_UNLIKELY (c_size == 0 || c_size >= (SIZE_MAX >> 3))) \
scm_out_of_range (FUNC_NAME, size); \
if (SCM_UNLIKELY (c_index + c_size > c_len)) \
scm_out_of_range (FUNC_NAME, index);
c_size = scm_to_unsigned_integer (size, 1, (size_t) -1); \
\
c_len = SCM_BYTEVECTOR_LENGTH (bv); \
- if (SCM_UNLIKELY (c_len < c_size)) \
+ if (SCM_UNLIKELY (c_len % c_size != 0)) \
+ scm_wrong_type_arg_msg \
+ (FUNC_NAME, 0, size, \
+ "an exact positive integer that divides the bytevector length"); \
+ else if (SCM_UNLIKELY (c_len == 0)) \
lst = SCM_EOL; \
else \
{ \
SCM_VALIDATE_SYMBOL (2, endianness); \
c_size = scm_to_size_t (size); \
\
- if (SCM_UNLIKELY (c_size == 0 || c_size >= (SCM_I_SIZE_MAX >> 3))) \
+ if (SCM_UNLIKELY (c_size == 0 || c_size >= (SIZE_MAX >> 3))) \
scm_out_of_range (FUNC_NAME, size); \
\
bv = make_bytevector (c_len * c_size, SCM_ARRAY_ELEMENT_TYPE_VU8); \
scm_list_1 (utf), err); \
else \
{ \
- str = scm_from_stringn (c_str, c_strlen, "UTF-8", \
- SCM_FAILED_CONVERSION_ERROR); \
+ str = scm_from_utf8_stringn (c_str, c_strlen); \
free (c_str); \
} \
return (str);
c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
- str = scm_from_stringn (c_utf, c_utf_len, "UTF-8",
- SCM_FAILED_CONVERSION_ERROR);
+ str = scm_from_utf8_stringn (c_utf, c_utf_len);
return (str);
}
#undef FUNC_NAME
\f
-/* Bytevectors as generalized vectors & arrays. */
-
-#define COMPLEX_ACCESSOR_PROLOGUE(_type) \
- size_t c_len, c_index; \
- char *c_bv; \
- \
- SCM_VALIDATE_BYTEVECTOR (1, bv); \
- c_index = scm_to_size_t (index); \
- \
- c_len = SCM_BYTEVECTOR_LENGTH (bv); \
- c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
- \
- if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len)) \
- scm_out_of_range (FUNC_NAME, index);
-
-/* Template for native access to complex numbers of type TYPE. */
-#define COMPLEX_NATIVE_REF(_type) \
- SCM result; \
- \
- COMPLEX_ACCESSOR_PROLOGUE (_type); \
- \
- { \
- _type real, imag; \
- \
- memcpy (&real, &c_bv[c_index], sizeof (_type)); \
- memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type)); \
- \
- result = scm_c_make_rectangular (real, imag); \
- } \
- \
- return result;
-
-static SCM
-bytevector_ref_c32 (SCM bv, SCM index)
-#define FUNC_NAME "bytevector_ref_c32"
-{
- COMPLEX_NATIVE_REF (float);
-}
-#undef FUNC_NAME
-
-static SCM
-bytevector_ref_c64 (SCM bv, SCM index)
-#define FUNC_NAME "bytevector_ref_c64"
-{
- COMPLEX_NATIVE_REF (double);
-}
-#undef FUNC_NAME
-
-typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
-
-static const scm_t_bytevector_ref_fn
-bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
-{
- NULL, /* SCM */
- NULL, /* CHAR */
- NULL, /* BIT */
- scm_bytevector_u8_ref, /* VU8 */
- scm_bytevector_u8_ref, /* U8 */
- scm_bytevector_s8_ref,
- scm_bytevector_u16_native_ref,
- scm_bytevector_s16_native_ref,
- scm_bytevector_u32_native_ref,
- scm_bytevector_s32_native_ref,
- scm_bytevector_u64_native_ref,
- scm_bytevector_s64_native_ref,
- scm_bytevector_ieee_single_native_ref,
- scm_bytevector_ieee_double_native_ref,
- bytevector_ref_c32,
- bytevector_ref_c64
-};
-
-static SCM
-bv_handle_ref (scm_t_array_handle *h, size_t index)
-{
- SCM byte_index;
- scm_t_bytevector_ref_fn ref_fn;
-
- ref_fn = bytevector_ref_fns[h->element_type];
- byte_index =
- scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
- return ref_fn (h->array, byte_index);
-}
-
-/* Template for native modification of complex numbers of type TYPE. */
-#define COMPLEX_NATIVE_SET(_type) \
- COMPLEX_ACCESSOR_PROLOGUE (_type); \
- \
- { \
- _type real, imag; \
- real = scm_c_real_part (value); \
- imag = scm_c_imag_part (value); \
- \
- memcpy (&c_bv[c_index], &real, sizeof (_type)); \
- memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type)); \
- } \
- \
- return SCM_UNSPECIFIED;
-
-static SCM
-bytevector_set_c32 (SCM bv, SCM index, SCM value)
-#define FUNC_NAME "bytevector_set_c32"
-{
- COMPLEX_NATIVE_SET (float);
-}
-#undef FUNC_NAME
-
-static SCM
-bytevector_set_c64 (SCM bv, SCM index, SCM value)
-#define FUNC_NAME "bytevector_set_c64"
-{
- COMPLEX_NATIVE_SET (double);
-}
-#undef FUNC_NAME
-
-typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM);
-
-const scm_t_bytevector_set_fn bytevector_set_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] =
-{
- NULL, /* SCM */
- NULL, /* CHAR */
- NULL, /* BIT */
- scm_bytevector_u8_set_x, /* VU8 */
- scm_bytevector_u8_set_x, /* U8 */
- scm_bytevector_s8_set_x,
- scm_bytevector_u16_native_set_x,
- scm_bytevector_s16_native_set_x,
- scm_bytevector_u32_native_set_x,
- scm_bytevector_s32_native_set_x,
- scm_bytevector_u64_native_set_x,
- scm_bytevector_s64_native_set_x,
- scm_bytevector_ieee_single_native_set_x,
- scm_bytevector_ieee_double_native_set_x,
- bytevector_set_c32,
- bytevector_set_c64
-};
-
-static void
-bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val)
-{
- SCM byte_index;
- scm_t_bytevector_set_fn set_fn;
-
- set_fn = bytevector_set_fns[h->element_type];
- byte_index =
- scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
- set_fn (h->array, byte_index, val);
-}
-
-static void
-bytevector_get_handle (SCM v, scm_t_array_handle *h)
-{
- h->array = v;
- h->ndims = 1;
- h->dims = &h->dim0;
- h->dim0.lbnd = 0;
- h->dim0.ubnd = SCM_BYTEVECTOR_TYPED_LENGTH (v) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (v);
- h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v);
-}
-
-\f
/* Initialization. */
void
(scm_t_extension_init_func) scm_init_bytevectors,
NULL);
- {
- scm_t_array_implementation impl;
-
- 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;
- scm_i_register_array_implementation (&impl);
- scm_i_register_vector_constructor
- (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8],
- scm_make_bytevector);
- }
+ scm_i_register_vector_constructor
+ (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8],
+ scm_make_bytevector);
}
void
/* 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_HEADER_SIZE 4U
#define SCM_BYTEVECTOR_LENGTH(_bv) \
((size_t) SCM_CELL_WORD_1 (_bv))
#define SCM_BYTEVECTOR_CONTENTS(_bv) \
((signed char *) SCM_CELL_WORD_2 (_bv))
+#define SCM_BYTEVECTOR_PARENT(_bv) \
+ (SCM_CELL_OBJECT_3 (_bv))
SCM_API SCM scm_endianness_big;
/* Internal API. */
#define SCM_BYTEVECTOR_P(x) \
- (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_bytevector)
+ (SCM_HAS_TYP7 (x, scm_tc7_bytevector))
#define SCM_BYTEVECTOR_FLAGS(_bv) \
(SCM_CELL_TYPE (_bv) >> 7UL)
#define SCM_SET_BYTEVECTOR_FLAGS(_bv, _f) \
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_t_array_element_type, SCM);
SCM_INTERNAL void scm_bootstrap_bytevectors (void);
SCM_INTERNAL void scm_init_bytevectors (void);
SCM_INTERNAL SCM scm_i_native_endianness;
-SCM_INTERNAL SCM scm_c_take_gc_bytevector (signed char *, size_t);
+SCM_INTERNAL SCM scm_c_take_gc_bytevector (signed char *, size_t, SCM);
SCM_INTERNAL int scm_i_print_bytevector (SCM, SCM, scm_print_state *);
/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009,
- * 2010, 2014 Free Software Foundation, Inc.
- *
+ * 2010, 2011, 2014 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
sym = uc_general_category_name (cat);
if (sym != NULL)
- return scm_from_locale_symbol (sym);
+ return scm_from_utf8_symbol (sym);
return SCM_BOOL_F;
}
#undef FUNC_NAME
-/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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/_scm.h"
+#include <assert.h>
#include <string.h>
#include <stdio.h>
#include "libguile/stackchk.h"
#include "libguile/smob.h"
#include "libguile/ports.h"
-#include "libguile/dynwind.h"
+#include "libguile/dynstack.h"
#include "libguile/eval.h"
#include "libguile/vm.h"
#include "libguile/instructions.h"
#define SCM_SET_CONTINUATION_LENGTH(x, n)\
(SCM_CONTREGS (x)->num_stack_items = (n))
#define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf)
-#define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv)
#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)
#define SCM_DFRAME(x) ((SCM_CONTREGS (x))->dframe)
\f
-/* scm_i_make_continuation will return a procedure whose objcode contains an
- instruction to reinstate the continuation. Here, as in gsubr.c and smob.c, we
- define the form of that trampoline function.
+/* scm_i_make_continuation will return a procedure whose code will
+ reinstate the continuation. Here, as in gsubr.c, we define the form
+ of that trampoline function.
*/
-#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
-#define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
-#else
-#define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
-#define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
-#endif
-
-#define OBJCODE_TAG SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0)
-
-#if defined (SCM_ALIGNED) && 0
-#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym) \
-static const type sym[]
-#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
-static SCM_ALIGNED (alignment) const type sym[]
-#define SCM_STATIC_OBJCODE(sym) \
- SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
- SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
- { SCM_PACK (OBJCODE_TAG), SCM_PACK (sym##__bytecode) }, \
- { SCM_BOOL_F, SCM_PACK (0) } \
- }; \
- static const SCM sym = SCM_PACK (sym##__cells); \
- SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
-#else
-#define SCM_STATIC_OBJCODE(sym) \
-static SCM sym; \
-static scm_t_uint8 *sym##_bytecode; \
-SCM_SNARF_INIT(sym##_bytecode = scm_gc_malloc_pointerless (sizeof(sym##_bytecode__unaligned), "partial continuation stub"); \
- memcpy (sym##_bytecode, sym##_bytecode__unaligned, sizeof(sym##_bytecode__unaligned));) \
-SCM_SNARF_INIT(sym = scm_double_cell (OBJCODE_TAG, \
- (scm_t_bits)sym##_bytecode, \
- SCM_UNPACK (SCM_BOOL_F), \
- 0);) \
-static const scm_t_uint8 sym##_bytecode__unaligned[]
-#endif
-
-
-SCM_STATIC_OBJCODE (cont_objcode) = {
- /* This code is the same as in gsubr.c, except we use continuation_call
- instead of subr_call. */
- OBJCODE_HEADER (8, 19),
- /* leave args on the stack */
- /* 0 */ scm_op_object_ref, 0, /* push scm_t_contregs smob */
- /* 2 */ scm_op_continuation_call, /* and longjmp (whee) */
- /* 3 */ scm_op_nop, /* pad to 8 bytes */
- /* 4 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,
- /* 8 */
-
- /* We could put some meta-info to say that this proc is a continuation. Not sure
- how to do that, though. */
- META_HEADER (19),
- /* 0 */ scm_op_make_eol, /* bindings */
- /* 1 */ scm_op_make_eol, /* sources */
- /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 3, /* arity: from ip 0 to ip 3 */
- /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
- /* 7 */ scm_op_make_int8_0, /* 0 optionals */
- /* 8 */ scm_op_make_true, /* and a rest arg */
- /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
- /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */
- /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list */
- /* 18 */ scm_op_return /* and return */
- /* 19 */
-};
-
-
-SCM_STATIC_OBJCODE (call_cc_objcode) = {
- /* Before Scheme's call/cc is compiled, eval.c will use this hand-coded
- call/cc. */
- OBJCODE_HEADER (8, 17),
- /* 0 */ scm_op_assert_nargs_ee, 0, 1, /* assert that nargs==1 */
- /* 3 */ scm_op_local_ref, 0, /* push the proc */
- /* 5 */ scm_op_tail_call_cc, /* and call/cc */
- /* 6 */ scm_op_nop, scm_op_nop, /* pad to 8 bytes */
- /* 8 */
-
- META_HEADER (17),
- /* 0 */ scm_op_make_eol, /* bindings */
- /* 1 */ scm_op_make_eol, /* sources */
- /* 2 */ scm_op_make_int8, 3, scm_op_make_int8, 6, /* arity: from ip 0 to ip 6 */
- /* 6 */ scm_op_make_int8_1, /* the arity is 0 required args */
- /* 7 */ scm_op_list, 0, 3, /* make a list of those 5 vals */
- /* 10 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */
- /* 13 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list */
- /* 16 */ scm_op_return /* and return */
- /* 17 */
-};
-
+static const scm_t_uint32 continuation_stub_code[] =
+ {
+ SCM_PACK_OP_24 (continuation_call, 0)
+ };
static SCM
make_continuation_trampoline (SCM contregs)
{
- SCM ret = scm_make_program (cont_objcode,
- scm_c_make_vector (1, contregs),
- SCM_BOOL_F);
- SCM_SET_CELL_WORD_0 (ret,
- SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_CONTINUATION);
+ SCM ret;
+ scm_t_bits nfree = 1;
+ scm_t_bits flags = SCM_F_PROGRAM_IS_CONTINUATION;
+
+ ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
+ SCM_SET_CELL_WORD_1 (ret, continuation_stub_code);
+ SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, contregs);
return ret;
}
{
scm_t_contregs *continuation = SCM_CONTREGS (obj);
- scm_puts ("#<continuation ", port);
+ scm_puts_unlocked ("#<continuation ", port);
scm_intprint (continuation->num_stack_items, 10, port);
- scm_puts (" @ ", port);
+ scm_puts_unlocked (" @ ", port);
scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
+/* James Clark came up with this neat one instruction fix for
+ * continuations on the SPARC. It flushes the register windows so
+ * that all the state of the process is contained in the stack.
+ */
+
+#if defined (sparc) || defined (__sparc__) || defined (__sparc)
+# define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3")
+#else
+# define SCM_FLUSH_REGISTER_WINDOWS /* empty */
+#endif
+
/* this may return more than once: the first time with the escape
procedure, then subsequently with SCM_UNDEFINED (the vals already having been
placed on the VM stack). */
#define FUNC_NAME "scm_i_make_continuation"
SCM
-scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
+scm_i_make_continuation (int *first, struct scm_vm *vp, SCM vm_cont)
{
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
SCM cont;
+ (stack_size - 1) * sizeof (SCM_STACKITEM),
"continuation");
continuation->num_stack_items = stack_size;
- continuation->dynenv = scm_i_dynwinds ();
continuation->root = thread->continuation_root;
src = thread->continuation_base;
#if ! SCM_STACK_GROWS_UP
#endif
continuation->offset = continuation->stack - src;
memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
- continuation->vm = vm;
+ continuation->vp = vp;
continuation->vm_cont = vm_cont;
SCM_NEWSMOB (cont, tc16_continuation, continuation);
return make_continuation_trampoline (cont);
}
else
- return SCM_UNDEFINED;
+ {
+ scm_gc_after_nonlocal_exit ();
+ return SCM_UNDEFINED;
+ }
}
#undef FUNC_NAME
-static SCM call_cc;
-
-static void
-init_call_cc (void)
-{
- call_cc = scm_make_program (call_cc_objcode, SCM_BOOL_F, SCM_BOOL_F);
-}
-
-SCM
-scm_i_call_with_current_continuation (SCM proc)
-{
- static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
- scm_i_pthread_once (&once, init_call_cc);
-
- return scm_call_1 (call_cc, proc);
-}
-
-SCM
-scm_i_continuation_to_frame (SCM continuation)
+int
+scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame)
{
SCM contregs;
scm_t_contregs *cont;
- contregs = scm_c_vector_ref (scm_program_objects (continuation), 0);
+ contregs = SCM_PROGRAM_FREE_VARIABLE_REF (continuation, 0);
cont = SCM_CONTREGS (contregs);
if (scm_is_true (cont->vm_cont))
{
struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont);
- return scm_c_make_frame (cont->vm_cont,
- data->fp + data->reloc,
- data->sp + data->reloc,
- data->ra,
- data->reloc);
+
+ frame->stack_holder = data;
+ frame->fp_offset = (data->fp + data->reloc) - data->stack_base;
+ frame->sp_offset = (data->sp + data->reloc) - data->stack_base;
+ frame->ip = data->ra;
+
+ return 1;
}
else
- return SCM_BOOL_F;
+ return 0;
}
-SCM
-scm_i_contregs_vm (SCM contregs)
+struct scm_vm *
+scm_i_contregs_vp (SCM contregs)
{
- return SCM_CONTREGS (contregs)->vm;
+ return SCM_CONTREGS (contregs)->vp;
}
SCM
* own frame are overwritten. Thus, memcpy can be used for best performance.
*/
-typedef struct {
- scm_t_contregs *continuation;
- SCM_STACKITEM *dst;
-} copy_stack_data;
-
-static void
-copy_stack (void *data)
-{
- copy_stack_data *d = (copy_stack_data *)data;
- memcpy (d->dst, d->continuation->stack,
- sizeof (SCM_STACKITEM) * d->continuation->num_stack_items);
-#ifdef __ia64__
- SCM_I_CURRENT_THREAD->pending_rbs_continuation = d->continuation;
-#endif
-}
-
static void
copy_stack_and_call (scm_t_contregs *continuation,
SCM_STACKITEM * dst)
{
- long delta;
- copy_stack_data data;
+ scm_t_dynstack *dynstack;
+ scm_t_bits *joint;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+
+ dynstack = SCM_VM_CONT_DATA (continuation->vm_cont)->dynstack;
+
+ joint = scm_dynstack_unwind_fork (&thread->dynstack, dynstack);
+
+ memcpy (dst, continuation->stack,
+ sizeof (SCM_STACKITEM) * continuation->num_stack_items);
+#ifdef __ia64__
+ thread->pending_rbs_continuation = continuation;
+#endif
- delta = scm_ilength (scm_i_dynwinds ()) - scm_ilength (continuation->dynenv);
- data.continuation = continuation;
- data.dst = dst;
- scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);
+ scm_dynstack_wind (&thread->dynstack, joint);
SCM_I_LONGJMP (continuation->jmpbuf, 1);
}
if (should_print_backtrace (tag, stack))
{
- scm_puts ("Backtrace:\n", port);
+ scm_puts_unlocked ("Backtrace:\n", port);
scm_display_backtrace_with_highlights (stack, port,
SCM_BOOL_F, SCM_BOOL_F,
SCM_EOL);
{
/* Print the exception unless TAG is `quit'. */
if (!scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
- print_exception_and_backtrace (PTR2SCM (error_port), tag, args);
+ print_exception_and_backtrace (SCM_PACK_POINTER (error_port), tag, args);
return SCM_UNSPECIFIED;
}
scm_i_with_continuation_barrier (c_body, &c_data,
c_handler, &c_data,
pre_unwind_handler,
- SCM2PTR (scm_current_error_port ()));
+ SCM_UNPACK_POINTER (scm_current_error_port ()));
return c_data.result;
}
return scm_i_with_continuation_barrier (scm_body, &scm_data,
scm_handler, &scm_data,
pre_unwind_handler,
- SCM2PTR (scm_current_error_port ()));
+ SCM_UNPACK_POINTER (scm_current_error_port ()));
}
#undef FUNC_NAME
#ifndef SCM_CONTINUATIONS_H
#define SCM_CONTINUATIONS_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010, 2012, 2013, 2014 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
typedef struct
{
scm_i_jmp_buf jmpbuf;
- SCM dynenv;
#ifdef __ia64__
void *backing_store;
unsigned long backing_store_size;
#endif /* __ia64__ */
size_t num_stack_items; /* size of the saved stack. */
SCM root; /* continuation root identifier. */
- SCM vm; /* vm */
+ struct scm_vm *vp; /* vm */
SCM vm_cont; /* vm's stack and regs */
/* The offset from the live stack location to this copy. This is
\f
-SCM_INTERNAL SCM scm_i_make_continuation (int *first, SCM vm, SCM vm_cont);
+SCM_INTERNAL SCM scm_i_make_continuation (int *first,
+ struct scm_vm *vp,
+ SCM vm_cont);
SCM_INTERNAL void scm_i_check_continuation (SCM cont);
SCM_INTERNAL void scm_i_reinstate_continuation (SCM cont);
-SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
+struct scm_frame;
+SCM_INTERNAL int scm_i_continuation_to_frame (SCM cont,
+ struct scm_frame *frame);
-SCM_INTERNAL SCM scm_i_continuation_to_frame (SCM cont);
-SCM_INTERNAL SCM scm_i_contregs_vm (SCM contregs);
+SCM_INTERNAL struct scm_vm* scm_i_contregs_vp (SCM contregs);
SCM_INTERNAL SCM scm_i_contregs_vm_cont (SCM contregs);
SCM_API void *scm_c_with_continuation_barrier (void *(*func)(void*), void *);
-/* Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * 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 <alloca.h>
-
-#include "libguile/_scm.h"
-#include "libguile/control.h"
-#include "libguile/objcodes.h"
-#include "libguile/instructions.h"
-#include "libguile/vm.h"
-
-\f
-
-
-SCM
-scm_c_make_prompt (SCM k, SCM *fp, SCM *sp, scm_t_uint8 *abort_ip,
- scm_t_uint8 escape_only_p, scm_t_int64 vm_cookie,
- SCM winds)
-{
- scm_t_bits tag;
- struct scm_prompt_registers *regs;
-
- tag = scm_tc7_prompt;
- if (escape_only_p)
- tag |= (SCM_F_PROMPT_ESCAPE<<8);
-
- regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
- regs->fp = fp;
- regs->sp = sp;
- regs->ip = abort_ip;
- regs->cookie = vm_cookie;
-
- return scm_double_cell (tag, SCM_UNPACK (k), (scm_t_bits)regs,
- SCM_UNPACK (winds));
-}
-
-/* Only to be called if the SCM_PROMPT_SETJMP returns 1 */
-SCM
-scm_i_prompt_pop_abort_args_x (SCM vm)
-{
- size_t i, n;
- SCM vals = SCM_EOL;
-
- n = scm_to_size_t (SCM_VM_DATA (vm)->sp[0]);
- for (i = 0; i < n; i++)
- vals = scm_cons (SCM_VM_DATA (vm)->sp[-(i + 1)], vals);
-
- /* The abort did reset the VM's registers, but then these values
- were pushed on; so we need to pop them ourselves. */
- SCM_VM_DATA (vm)->sp -= n + 1;
- /* FIXME NULLSTACK */
-
- return vals;
-}
-
-
-#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
-#define META_HEADER(meta) 0, 0, 0, meta, 0, 0, 0, 0
-#else
-#define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
-#define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
-#endif
-
-#define OBJCODE_TAG SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0)
-
-#if defined (SCM_ALIGNED)
-#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym) \
-static const type sym[]
-#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
-static SCM_ALIGNED (alignment) const type sym[]
-#define SCM_STATIC_OBJCODE(sym) \
- SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
- SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
- { SCM_PACK (OBJCODE_TAG), SCM_PACK (sym##__bytecode) }, \
- { SCM_BOOL_F, SCM_PACK (0) } \
- }; \
- static const SCM sym = SCM_PACK (sym##__cells); \
- SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
-#else
-#define SCM_STATIC_OBJCODE(sym) \
-static SCM sym; \
-static scm_t_uint8 *sym##_bytecode; \
-SCM_SNARF_INIT(sym##_bytecode = scm_gc_malloc_pointerless (sizeof(sym##_bytecode__unaligned), "partial continuation stub"); \
- memcpy (sym##_bytecode, sym##_bytecode__unaligned, sizeof(sym##_bytecode__unaligned));) \
-SCM_SNARF_INIT(sym = scm_double_cell (OBJCODE_TAG, \
- (scm_t_bits)sym##_bytecode, \
- SCM_UNPACK (SCM_BOOL_F), \
- 0);) \
-static const scm_t_uint8 sym##_bytecode__unaligned[]
-#endif
-
-
-SCM_STATIC_OBJCODE (cont_objcode) = {
- /* Like in continuations.c, but with partial-cont-call. */
- OBJCODE_HEADER (8, 19),
- /* leave args on the stack */
- /* 0 */ scm_op_object_ref, 0, /* push scm_vm_cont object */
- /* 2 */ scm_op_object_ref, 1, /* push internal winds */
- /* 4 */ scm_op_partial_cont_call, /* and go! */
- /* 5 */ scm_op_nop, scm_op_nop, scm_op_nop, /* pad to 8 bytes */
- /* 8 */
-
- /* We could put some meta-info to say that this proc is a continuation. Not sure
- how to do that, though. */
- META_HEADER (19),
- /* 0 */ scm_op_make_eol, /* bindings */
- /* 1 */ scm_op_make_eol, /* sources */
- /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 5, /* arity: from ip 0 to ip 7 */
- /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
- /* 7 */ scm_op_make_int8_0, /* 0 optionals */
- /* 8 */ scm_op_make_true, /* and a rest arg */
- /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
- /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */
- /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list */
- /* 18 */ scm_op_return /* and return */
- /* 19 */
-};
-
-
-static SCM
-reify_partial_continuation (SCM vm, SCM prompt, SCM extwinds,
- scm_t_int64 cookie)
-{
- SCM vm_cont, dynwinds, intwinds = SCM_EOL, ret;
- scm_t_uint32 flags;
-
- /* No need to reify if the continuation is never referenced in the handler. */
- if (SCM_PROMPT_ESCAPE_P (prompt))
- return SCM_BOOL_F;
-
- dynwinds = scm_i_dynwinds ();
- while (!scm_is_eq (dynwinds, extwinds))
- {
- intwinds = scm_cons (scm_car (dynwinds), intwinds);
- dynwinds = scm_cdr (dynwinds);
- }
-
- flags = SCM_F_VM_CONT_PARTIAL;
- if (cookie >= 0 && SCM_PROMPT_REGISTERS (prompt)->cookie == cookie)
- flags |= SCM_F_VM_CONT_REWINDABLE;
-
- /* Since non-escape continuations should begin with a thunk application, the
- first bit of the stack should be a frame, with the saved fp equal to the fp
- that was current when the prompt was made. */
- if ((SCM*)SCM_UNPACK (SCM_PROMPT_REGISTERS (prompt)->sp[1])
- != SCM_PROMPT_REGISTERS (prompt)->fp)
- abort ();
-
- /* Capture from the top of the thunk application frame up to the end. Set an
- MVRA only, as the post-abort code is in an MV context. */
- vm_cont = scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt)->sp + 4,
- SCM_VM_DATA (vm)->fp,
- SCM_VM_DATA (vm)->sp,
- NULL,
- SCM_VM_DATA (vm)->ip,
- flags);
-
- ret = scm_make_program (cont_objcode,
- scm_vector (scm_list_2 (vm_cont, intwinds)),
- SCM_BOOL_F);
- SCM_SET_CELL_WORD_0 (ret,
- SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION);
- return ret;
-}
-
-void
-scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie)
-{
- SCM cont, winds, prompt = SCM_BOOL_F;
- long delta;
- size_t i;
-
- /* Search the wind list for an appropriate prompt.
- "Waiter, please bring us the wind list." */
- for (winds = scm_i_dynwinds (), delta = 0;
- scm_is_pair (winds);
- winds = SCM_CDR (winds), delta++)
- {
- SCM elt = SCM_CAR (winds);
- if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), tag))
- {
- prompt = elt;
- break;
- }
- }
-
- /* If we didn't find anything, raise an error. */
- if (scm_is_false (prompt))
- scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
-
- cont = reify_partial_continuation (vm, prompt, winds, cookie);
-
- /* Unwind once more, beyond the prompt. */
- winds = SCM_CDR (winds), delta++;
-
- /* Unwind */
- scm_dowinds (winds, delta);
-
- /* Unwinding may have changed the current thread's VM, so use the
- new one. */
- vm = scm_the_vm ();
-
- /* Restore VM regs */
- SCM_VM_DATA (vm)->fp = SCM_PROMPT_REGISTERS (prompt)->fp;
- SCM_VM_DATA (vm)->sp = SCM_PROMPT_REGISTERS (prompt)->sp;
- SCM_VM_DATA (vm)->ip = SCM_PROMPT_REGISTERS (prompt)->ip;
-
- /* Since we're jumping down, we should always have enough space */
- if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
- abort ();
-
- /* Push vals */
- *(++(SCM_VM_DATA (vm)->sp)) = cont;
- for (i = 0; i < n; i++)
- *(++(SCM_VM_DATA (vm)->sp)) = argv[i];
- *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
-
- /* Jump! */
- SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt)->regs, 1);
-
- /* Shouldn't get here */
- abort ();
-}
-
-SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
- "Abort to the nearest prompt with tag @var{tag}.")
-#define FUNC_NAME s_scm_at_abort
-{
- SCM *argv;
- size_t i;
- long n;
-
- SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
- argv = alloca (sizeof (SCM)*n);
- for (i = 0; i < n; i++, args = scm_cdr (args))
- argv[i] = scm_car (args);
-
- scm_c_abort (scm_the_vm (), tag, n, argv, -1);
-
- /* Oh, what, you're still here? The abort must have been reinstated. Actually,
- that's quite impossible, given that we're already in C-land here, so...
- abort! */
-
- abort ();
-}
-#undef FUNC_NAME
-
-void
-scm_i_prompt_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts ("#<prompt ", port);
- scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
-}
-
-void
-scm_init_control (void)
-{
-#include "libguile/control.x"
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 2010, 2011, 2012, 2013 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 <alloca.h>
+
+#include "libguile/_scm.h"
+#include "libguile/control.h"
+#include "libguile/programs.h"
+#include "libguile/instructions.h"
+#include "libguile/vm.h"
+
+\f
+
+#define PROMPT_ESCAPE_P(p) \
+ (SCM_DYNSTACK_TAG_FLAGS (SCM_DYNSTACK_TAG (p)) \
+ & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
+
+\f
+
+
+/* Only to be called if the SCM_I_SETJMP returns 1 */
+SCM
+scm_i_prompt_pop_abort_args_x (struct scm_vm *vp)
+{
+ size_t i, n;
+ SCM vals = SCM_EOL;
+
+ n = scm_to_size_t (vp->sp[0]);
+ for (i = 0; i < n; i++)
+ vals = scm_cons (vp->sp[-(i + 1)], vals);
+
+ /* The abort did reset the VM's registers, but then these values
+ were pushed on; so we need to pop them ourselves. */
+ vp->sp -= n + 1;
+ /* FIXME NULLSTACK */
+
+ return vals;
+}
+
+
+static const scm_t_uint32 compose_continuation_code[] =
+ {
+ SCM_PACK_OP_24 (compose_continuation, 0)
+ };
+
+
+static SCM
+make_partial_continuation (SCM vm_cont)
+{
+ scm_t_bits nfree = 1;
+ scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION;
+ SCM ret;
+
+ ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
+ SCM_SET_CELL_WORD_1 (ret, compose_continuation_code);
+ SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vm_cont);
+
+ return ret;
+}
+
+static SCM
+reify_partial_continuation (struct scm_vm *vp,
+ SCM *saved_fp,
+ SCM *saved_sp,
+ scm_t_uint32 *saved_ip,
+ scm_i_jmp_buf *saved_registers,
+ scm_t_dynstack *dynstack,
+ scm_i_jmp_buf *current_registers)
+{
+ SCM vm_cont;
+ scm_t_uint32 flags;
+ SCM *bottom_fp;
+
+ flags = SCM_F_VM_CONT_PARTIAL;
+ /* If we are aborting to a prompt that has the same registers as those
+ of the abort, it means there are no intervening C frames on the
+ stack, and so the continuation can be relocated elsewhere on the
+ stack: it is rewindable. */
+ if (saved_registers && saved_registers == current_registers)
+ flags |= SCM_F_VM_CONT_REWINDABLE;
+
+ /* Walk the stack down until we find the first frame after saved_fp.
+ We will save the stack down to that frame. It used to be that we
+ could determine the stack bottom in O(1) time, but that's no longer
+ the case, since the thunk application doesn't occur where the
+ prompt is saved. */
+ for (bottom_fp = vp->fp;
+ SCM_FRAME_DYNAMIC_LINK (bottom_fp) > saved_fp;
+ bottom_fp = SCM_FRAME_DYNAMIC_LINK (bottom_fp));
+
+ if (SCM_FRAME_DYNAMIC_LINK (bottom_fp) != saved_fp)
+ abort();
+
+ /* Capture from the top of the thunk application frame up to the end. */
+ vm_cont = scm_i_vm_capture_stack (&SCM_FRAME_LOCAL (bottom_fp, 0),
+ vp->fp,
+ vp->sp,
+ vp->ip,
+ dynstack,
+ flags);
+
+ return make_partial_continuation (vm_cont);
+}
+
+void
+scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
+ scm_i_jmp_buf *current_registers)
+{
+ SCM cont;
+ scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
+ scm_t_bits *prompt;
+ scm_t_dynstack_prompt_flags flags;
+ scm_t_ptrdiff fp_offset, sp_offset;
+ SCM *fp, *sp;
+ scm_t_uint32 *ip;
+ scm_i_jmp_buf *registers;
+ size_t i;
+
+ prompt = scm_dynstack_find_prompt (dynstack, tag,
+ &flags, &fp_offset, &sp_offset, &ip,
+ ®isters);
+
+ if (!prompt)
+ scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
+
+ fp = vp->stack_base + fp_offset;
+ sp = vp->stack_base + sp_offset;
+
+ /* Only reify if the continuation referenced in the handler. */
+ if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
+ cont = SCM_BOOL_F;
+ else
+ {
+ scm_t_dynstack *captured;
+
+ captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
+ cont = reify_partial_continuation (vp, fp, sp, ip, registers, captured,
+ current_registers);
+ }
+
+ /* Unwind. */
+ scm_dynstack_unwind (dynstack, prompt);
+
+ /* Restore VM regs */
+ vp->fp = fp;
+ vp->sp = sp;
+ vp->ip = ip;
+
+ /* Since we're jumping down, we should always have enough space. */
+ if (vp->sp + n + 1 >= vp->stack_limit)
+ abort ();
+
+ /* Push vals */
+ *(++(vp->sp)) = cont;
+ for (i = 0; i < n; i++)
+ *(++(vp->sp)) = argv[i];
+ if (flags & SCM_F_DYNSTACK_PROMPT_PUSH_NARGS)
+ *(++(vp->sp)) = scm_from_size_t (n+1); /* +1 for continuation */
+
+ /* Jump! */
+ SCM_I_LONGJMP (*registers, 1);
+
+ /* Shouldn't get here */
+ abort ();
+}
+
+SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,
+ (SCM tag, SCM args),
+ "Abort to the nearest prompt with tag @var{tag}, yielding the\n"
+ "values in the list, @var{args}.")
+#define FUNC_NAME s_scm_abort_to_prompt_star
+{
+ SCM *argv;
+ size_t i;
+ long n;
+
+ SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
+ argv = alloca (sizeof (SCM)*n);
+ for (i = 0; i < n; i++, args = scm_cdr (args))
+ argv[i] = scm_car (args);
+
+ scm_c_abort (scm_the_vm (), tag, n, argv, NULL);
+
+ /* Oh, what, you're still here? The abort must have been reinstated. Actually,
+ that's quite impossible, given that we're already in C-land here, so...
+ abort! */
+
+ abort ();
+}
+#undef FUNC_NAME
+
+void
+scm_init_control (void)
+{
+#include "libguile/control.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
-/* Copyright (C) 2010, 2011 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public 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_CONTROL_H
-#define SCM_CONTROL_H
-
-
-#define SCM_F_PROMPT_ESCAPE 0x1
-
-#define SCM_PROMPT_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_prompt)
-#define SCM_PROMPT_FLAGS(x) (SCM_CELL_WORD ((x), 0) >> 8)
-#define SCM_PROMPT_ESCAPE_P(x) (SCM_PROMPT_FLAGS (x) & SCM_F_PROMPT_ESCAPE)
-#define SCM_PROMPT_TAG(x) (SCM_CELL_OBJECT ((x), 1))
-#define SCM_PROMPT_REGISTERS(x) ((struct scm_prompt_registers*)SCM_CELL_WORD ((x), 2))
-#define SCM_PROMPT_DYNWINDS(x) (SCM_CELL_OBJECT ((x), 3))
-
-#define SCM_PROMPT_SETJMP(p) (SCM_I_SETJMP (SCM_PROMPT_REGISTERS (p)->regs))
-
-struct scm_prompt_registers
-{
- scm_t_uint8 *ip;
- SCM *sp;
- SCM *fp;
- scm_t_int64 cookie;
- scm_i_jmp_buf regs;
-};
-
-
-SCM_INTERNAL SCM scm_c_make_prompt (SCM k, SCM *fp, SCM *sp,
- scm_t_uint8 *abort_ip,
- scm_t_uint8 escape_only_p,
- scm_t_int64 vm_cookie,
- SCM winds);
-SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM vm);
-
-SCM_INTERNAL void scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
- scm_t_int64 cookie) SCM_NORETURN;
-SCM_INTERNAL SCM scm_at_abort (SCM tag, SCM args) SCM_NORETURN;
-
-
-SCM_INTERNAL void scm_i_prompt_print (SCM exp, SCM port, scm_print_state *pstate);
-SCM_INTERNAL void scm_init_control (void);
-
-
-#endif /* SCM_CONTROL_H */
+/* Copyright (C) 2010, 2011, 2012, 2013 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_CONTROL_H
+#define SCM_CONTROL_H
+
+#include "libguile/vm.h"
+
+
+SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (struct scm_vm *vp);
+
+SCM_INTERNAL void scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
+ scm_i_jmp_buf *registers) SCM_NORETURN;
+SCM_INTERNAL SCM scm_abort_to_prompt_star (SCM tag, SCM args) SCM_NORETURN;
+
+
+SCM_INTERNAL void scm_init_control (void);
+
+
+#endif /* SCM_CONTROL_H */
/* Debugging extensions for Guile
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013 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_dynwind_critical_section (SCM_BOOL_F);
ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
-#ifdef STACK_CHECKING
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-#endif
scm_dynwind_end ();
return ans;
}
#undef FUNC_NAME
-\f
-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);
- while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
- proc = SCM_STRUCT_PROCEDURE (proc);
- return scm_procedure_property (proc, scm_sym_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
#ifndef SCM_DEBUG_H
#define SCM_DEBUG_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2012
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2012,2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
SCM_API SCM scm_local_eval (SCM exp, SCM env);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
-SCM_API SCM scm_procedure_source (SCM proc);
-SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_debug_options (SCM setting);
SCM_INTERNAL void scm_init_debug (void);
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 */
/*
-/* This file contains definitions for deprecated features. When you
- deprecate something, move it here when that is feasible.
-*/
-
-/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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 <math.h>
-#include <stdio.h>
-#include <string.h>
-
-#include <arpa/inet.h>
-
-#define SCM_BUILDING_DEPRECATED_CODE
-
-#include "libguile/_scm.h"
-#include "libguile/async.h"
-#include "libguile/arrays.h"
-#include "libguile/array-map.h"
-#include "libguile/generalized-arrays.h"
-#include "libguile/bytevectors.h"
-#include "libguile/bitvectors.h"
-#include "libguile/deprecated.h"
-#include "libguile/deprecation.h"
-#include "libguile/snarf.h"
-#include "libguile/validate.h"
-#include "libguile/strings.h"
-#include "libguile/srfi-13.h"
-#include "libguile/modules.h"
-#include "libguile/eval.h"
-#include "libguile/smob.h"
-#include "libguile/procprop.h"
-#include "libguile/vectors.h"
-#include "libguile/hashtab.h"
-#include "libguile/struct.h"
-#include "libguile/variable.h"
-#include "libguile/fluids.h"
-#include "libguile/ports.h"
-#include "libguile/eq.h"
-#include "libguile/read.h"
-#include "libguile/r6rs-ports.h"
-#include "libguile/strports.h"
-#include "libguile/smob.h"
-#include "libguile/alist.h"
-#include "libguile/keywords.h"
-#include "libguile/socket.h"
-#include "libguile/feature.h"
-#include "libguile/uniform.h"
-
-
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-/* From print.c: Internal symbol names of isyms. Deprecated in guile 1.7.0 on
- * 2004-04-22. */
-char *scm_isymnames[] =
-{
- "#@<deprecated>"
-};
-
-
-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);
-
-SCM
-scm_wta (SCM arg, const char *pos, const char *s_subr)
-{
- if (!s_subr || !*s_subr)
- s_subr = NULL;
- if ((~0x1fL) & (long) pos)
- {
- /* error string supplied. */
- scm_misc_error (s_subr, pos, scm_list_1 (arg));
- }
- else
- {
- /* numerical error code. */
- scm_t_bits error = (scm_t_bits) pos;
-
- switch (error)
- {
- case SCM_ARGn:
- scm_wrong_type_arg (s_subr, 0, arg);
- case SCM_ARG1:
- scm_wrong_type_arg (s_subr, 1, arg);
- case SCM_ARG2:
- scm_wrong_type_arg (s_subr, 2, arg);
- case SCM_ARG3:
- scm_wrong_type_arg (s_subr, 3, arg);
- case SCM_ARG4:
- scm_wrong_type_arg (s_subr, 4, arg);
- case SCM_ARG5:
- scm_wrong_type_arg (s_subr, 5, arg);
- case SCM_ARG6:
- scm_wrong_type_arg (s_subr, 6, arg);
- case SCM_ARG7:
- scm_wrong_type_arg (s_subr, 7, arg);
- case SCM_WNA:
- scm_wrong_num_args (arg);
- case SCM_OUTOFRANGE:
- scm_out_of_range (s_subr, arg);
- case SCM_NALLOC:
- scm_memory_error (s_subr);
- default:
- /* this shouldn't happen. */
- scm_misc_error (s_subr, "Unknown error", SCM_EOL);
- }
- }
- return SCM_UNSPECIFIED;
-}
-
-/* Module registry
- */
-
-/* We can't use SCM objects here. One should be able to call
- SCM_REGISTER_MODULE from a C++ constructor for a static
- object. This happens before main and thus before libguile is
- initialized. */
-
-struct moddata {
- struct moddata *link;
- char *module_name;
- void *init_func;
-};
-
-static struct moddata *registered_mods = NULL;
-
-void
-scm_register_module_xxx (char *module_name, void *init_func)
-{
- struct moddata *md;
-
- scm_c_issue_deprecation_warning
- ("`scm_register_module_xxx' is deprecated. Use extensions instead.");
-
- /* XXX - should we (and can we) DEFER_INTS here? */
-
- for (md = registered_mods; md; md = md->link)
- if (!strcmp (md->module_name, module_name))
- {
- md->init_func = init_func;
- return;
- }
-
- md = (struct moddata *) malloc (sizeof (struct moddata));
- if (md == NULL)
- {
- fprintf (stderr,
- "guile: can't register module (%s): not enough memory",
- module_name);
- return;
- }
-
- md->module_name = module_name;
- md->init_func = init_func;
- md->link = registered_mods;
- registered_mods = md;
-}
-
-SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0,
- (),
- "Return a list of the object code modules that have been imported into\n"
- "the current Guile process. Each element of the list is a pair whose\n"
- "car is the name of the module, and whose cdr is the function handle\n"
- "for that module's initializer function. The name is the string that\n"
- "has been passed to scm_register_module_xxx.")
-#define FUNC_NAME s_scm_registered_modules
-{
- SCM res;
- struct moddata *md;
-
- res = SCM_EOL;
- for (md = registered_mods; md; md = md->link)
- res = scm_cons (scm_cons (scm_from_locale_string (md->module_name),
- scm_from_ulong ((unsigned long) md->init_func)),
- res);
- return res;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0,
- (),
- "Destroy the list of modules registered with the current Guile process.\n"
- "The return value is unspecified. @strong{Warning:} this function does\n"
- "not actually unlink or deallocate these modules, but only destroys the\n"
- "records of which modules have been loaded. It should therefore be used\n"
- "only by module bookkeeping operations.")
-#define FUNC_NAME s_scm_clear_registered_modules
-{
- struct moddata *md1, *md2;
-
- SCM_CRITICAL_SECTION_START;
-
- for (md1 = registered_mods; md1; md1 = md2)
- {
- md2 = md1->link;
- free (md1);
- }
- registered_mods = NULL;
-
- SCM_CRITICAL_SECTION_END;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-void
-scm_remember (SCM *ptr)
-{
- scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
- "Use the `scm_remember_upto_here*' family of functions instead.");
-}
-
-SCM
-scm_protect_object (SCM obj)
-{
- scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
- "Use `scm_gc_protect_object' instead.");
- return scm_gc_protect_object (obj);
-}
-
-SCM
-scm_unprotect_object (SCM obj)
-{
- scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
- "Use `scm_gc_unprotect_object' instead.");
- return scm_gc_unprotect_object (obj);
-}
-
-SCM_SYMBOL (scm_sym_app, "app");
-SCM_SYMBOL (scm_sym_modules, "modules");
-static SCM module_prefix = SCM_BOOL_F;
-static SCM make_modules_in_var;
-static SCM beautify_user_module_x_var;
-static SCM try_module_autoload_var;
-
-static void
-init_module_stuff ()
-{
- if (scm_is_false (module_prefix))
- {
- 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 =
- scm_c_lookup ("beautify-user-module!");
- try_module_autoload_var = scm_c_lookup ("try-module-autoload");
- }
-}
-
-static SCM
-scm_module_full_name (SCM name)
-{
- init_module_stuff ();
- if (scm_is_eq (SCM_CAR (name), scm_sym_app))
- return name;
- else
- return scm_append (scm_list_2 (module_prefix, name));
-}
-
-SCM
-scm_make_module (SCM name)
-{
- init_module_stuff ();
- scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. "
- "Use `scm_c_define_module instead.");
-
- return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var),
- scm_the_root_module (),
- scm_module_full_name (name));
-}
-
-SCM
-scm_ensure_user_module (SCM module)
-{
- init_module_stuff ();
- scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. "
- "Use `scm_c_define_module instead.");
-
- scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var), module);
- return SCM_UNSPECIFIED;
-}
-
-SCM
-scm_load_scheme_module (SCM name)
-{
- init_module_stuff ();
- scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. "
- "Use `scm_c_resolve_module instead.");
-
- return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var), name);
-}
-
-/* This is implemented in C solely for SCM_COERCE_OUTPORT ... */
-
-static void
-maybe_close_port (void *data, SCM port)
-{
- SCM except_set = PTR2SCM (data);
-
- while (!scm_is_null (except_set))
- {
- SCM p = SCM_COERCE_OUTPORT (SCM_CAR (except_set));
- if (scm_is_eq (p, port))
- return;
- except_set = SCM_CDR (except_set);
- }
-
- scm_close_port (port);
-}
-
-SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1,
- (SCM ports),
- "[DEPRECATED] Close all open file ports used by the interpreter\n"
- "except for those supplied as arguments. This procedure\n"
- "was intended to be used before an exec call to close file descriptors\n"
- "which are not needed in the new process. However it has the\n"
- "undesirable side effect of flushing buffers, so it's deprecated.\n"
- "Use port-for-each instead.")
-#define FUNC_NAME s_scm_close_all_ports_except
-{
- SCM p;
- SCM_VALIDATE_REST_ARGUMENT (ports);
-
- for (p = ports; !scm_is_null (p); p = SCM_CDR (p))
- SCM_VALIDATE_OPPORT (SCM_ARG1, SCM_COERCE_OUTPORT (SCM_CAR (p)));
-
- scm_c_port_for_each (maybe_close_port, SCM2PTR (ports));
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_variable_set_name_hint, "variable-set-name-hint!", 2, 0, 0,
- (SCM var, SCM hint),
- "Do not use this function.")
-#define FUNC_NAME s_scm_variable_set_name_hint
-{
- SCM_VALIDATE_VARIABLE (1, var);
- SCM_VALIDATE_SYMBOL (2, hint);
- scm_c_issue_deprecation_warning
- ("'variable-set-name-hint!' is deprecated. Do not use it.");
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0,
- (SCM name),
- "Do not use this function.")
-#define FUNC_NAME s_scm_builtin_variable
-{
- SCM_VALIDATE_SYMBOL (1,name);
- scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. "
- "Use module system operations instead.");
- return scm_sym2var (name, SCM_BOOL_F, SCM_BOOL_T);
-}
-#undef FUNC_NAME
-
-SCM
-scm_makstr (size_t len, int dummy)
-{
- scm_c_issue_deprecation_warning
- ("'scm_makstr' is deprecated. Use 'scm_c_make_string' instead.");
- return scm_c_make_string (len, SCM_UNDEFINED);
-}
-
-SCM
-scm_makfromstr (const char *src, size_t len, int dummy SCM_UNUSED)
-{
- scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. "
- "Use `scm_from_locale_stringn' instead.");
-
- return scm_from_locale_stringn (src, len);
-}
-
-SCM
-scm_internal_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
-{
- scm_c_issue_deprecation_warning ("`scm_internal_with_fluids' is deprecated. "
- "Use `scm_c_with_fluids' instead.");
-
- return scm_c_with_fluids (fluids, values, cproc, cdata);
-}
-
-SCM
-scm_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_gsubr' is deprecated. Use `scm_c_define_gsubr' instead.");
-
- return scm_c_define_gsubr (name, req, opt, rst, fcn);
-}
-
-SCM
-scm_make_gsubr_with_generic (const char *name,
- int req, int opt, int rst,
- SCM (*fcn)(), SCM *gf)
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_gsubr_with_generic' is deprecated. "
- "Use `scm_c_define_gsubr_with_generic' instead.");
-
- return scm_c_define_gsubr_with_generic (name, req, opt, rst, fcn, gf);
-}
-
-SCM
-scm_create_hook (const char *name, int n_args)
-{
- scm_c_issue_deprecation_warning
- ("'scm_create_hook' is deprecated. "
- "Use 'scm_make_hook' and 'scm_c_define' instead.");
- {
- SCM hook = scm_make_hook (scm_from_int (n_args));
- scm_c_define (name, hook);
- return hook;
- }
-}
-
-SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{memq}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_memq
-{
- scm_c_issue_deprecation_warning
- ("'sloppy-memq' is deprecated. Use 'memq' instead.");
-
- for(; scm_is_pair (lst); lst = SCM_CDR(lst))
- {
- if (scm_is_eq (SCM_CAR (lst), x))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_sloppy_memv, "sloppy-memv", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{memv}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_memv
-{
- scm_c_issue_deprecation_warning
- ("'sloppy-memv' is deprecated. Use 'memv' instead.");
-
- for(; scm_is_pair (lst); lst = SCM_CDR(lst))
- {
- if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x)))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{member}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_member
-{
- scm_c_issue_deprecation_warning
- ("'sloppy-member' is deprecated. Use 'member' instead.");
-
- for(; scm_is_pair (lst); lst = SCM_CDR(lst))
- {
- if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-
-SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
-
-SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0,
- (SCM port),
- "Read a form from @var{port} (standard input by default), and evaluate it\n"
- "(memoizing it in the process) in the top-level environment. If no data\n"
- "is left to be read from @var{port}, an @code{end-of-file} error is\n"
- "signalled.")
-#define FUNC_NAME s_scm_read_and_eval_x
-{
- SCM form;
-
- scm_c_issue_deprecation_warning
- ("'read-and-eval!' is deprecated. Use 'read' and 'eval' instead.");
-
- form = scm_read (port);
- if (SCM_EOF_OBJECT_P (form))
- scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
- return scm_eval_x (form, scm_current_module ());
-}
-#undef FUNC_NAME
-
-/* Call thunk(closure) underneath a top-level error handler.
- * If an error occurs, pass the exitval through err_filter and return it.
- * If no error occurs, return the value of thunk.
- */
-
-#ifdef _UNICOS
-typedef int setjmp_type;
-#else
-typedef long setjmp_type;
-#endif
-
-struct cce_handler_data {
- SCM (*err_filter) ();
- void *closure;
-};
-
-static SCM
-invoke_err_filter (void *d, SCM tag, SCM args)
-{
- struct cce_handler_data *data = (struct cce_handler_data *)d;
- return data->err_filter (SCM_BOOL_F, data->closure);
-}
-
-SCM
-scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure)
-{
- scm_c_issue_deprecation_warning
- ("'scm_call_catching_errors' is deprecated. "
- "Use 'scm_internal_catch' instead.");
-
- {
- struct cce_handler_data data;
- data.err_filter = err_filter;
- data.closure = closure;
- return scm_internal_catch (SCM_BOOL_T,
- (scm_t_catch_body)thunk, closure,
- (scm_t_catch_handler)invoke_err_filter, &data);
- }
-}
-
-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_c_issue_deprecation_warning
- ("'scm_make_smob_type_mfpe' is deprecated. "
- "Use 'scm_make_smob_type' plus 'scm_set_smob_*' instead.");
-
- {
- long answer = scm_make_smob_type (name, size);
- scm_set_smob_mfpe (answer, mark, free, print, equalp);
- return answer;
- }
-}
-
-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_c_issue_deprecation_warning
- ("'scm_set_smob_mfpe' is deprecated. "
- "Use 'scm_set_smob_mark' instead, for example.");
-
- if (mark) scm_set_smob_mark (tc, mark);
- if (free) scm_set_smob_free (tc, free);
- if (print) scm_set_smob_print (tc, print);
- 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)
-{
- scm_c_issue_deprecation_warning
- ("scm_read_0str is deprecated. Use scm_c_read_string instead.");
-
- return scm_c_read_string (expr);
-}
-
-SCM
-scm_eval_0str (const char *expr)
-{
- scm_c_issue_deprecation_warning
- ("scm_eval_0str is deprecated. Use scm_c_eval_string instead.");
-
- return scm_c_eval_string (expr);
-}
-
-SCM
-scm_strprint_obj (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("scm_strprint_obj is deprecated. Use scm_object_to_string instead.");
- return scm_object_to_string (obj, SCM_UNDEFINED);
-}
-
-char *
-scm_i_object_chars (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_CHARS is deprecated. See the manual for alternatives.");
- if (SCM_STRINGP (obj))
- return SCM_STRING_CHARS (obj);
- if (SCM_SYMBOLP (obj))
- return SCM_SYMBOL_CHARS (obj);
- abort ();
-}
-
-long
-scm_i_object_length (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_LENGTH is deprecated. "
- "Use scm_c_string_length instead, for example, or see the manual.");
- if (SCM_STRINGP (obj))
- return SCM_STRING_LENGTH (obj);
- if (SCM_SYMBOLP (obj))
- return SCM_SYMBOL_LENGTH (obj);
- if (SCM_VECTORP (obj))
- return SCM_VECTOR_LENGTH (obj);
- abort ();
-}
-
-SCM
-scm_sym2ovcell_soft (SCM sym, SCM obarray)
-{
- SCM lsym, z;
- size_t hash = scm_i_symbol_hash (sym) % SCM_VECTOR_LENGTH (obarray);
-
- scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. "
- "Use hashtables instead.");
-
- SCM_CRITICAL_SECTION_START;
- for (lsym = SCM_VECTOR_REF (obarray, hash);
- SCM_NIMP (lsym);
- lsym = SCM_CDR (lsym))
- {
- z = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (z), sym))
- {
- SCM_CRITICAL_SECTION_END;
- return z;
- }
- }
- SCM_CRITICAL_SECTION_END;
- return SCM_BOOL_F;
-}
-
-
-SCM
-scm_sym2ovcell (SCM sym, SCM obarray)
-#define FUNC_NAME "scm_sym2ovcell"
-{
- SCM answer;
-
- scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. "
- "Use hashtables instead.");
-
- answer = scm_sym2ovcell_soft (sym, obarray);
- if (scm_is_true (answer))
- return answer;
- SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym));
- return SCM_UNSPECIFIED; /* not reached */
-}
-#undef FUNC_NAME
-
-
-/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
-
- OBARRAY should be a vector of lists, indexed by the name's hash
- value, modulo OBARRAY's length. Each list has the form
- ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
- value associated with that symbol (in the current module? in the
- system module?)
-
- To "intern" a symbol means: if OBARRAY already contains a symbol by
- that name, return its (SYMBOL . VALUE) pair; otherwise, create a
- new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
- appropriate list of the OBARRAY, and return the pair.
-
- If softness is non-zero, don't create a symbol if it isn't already
- in OBARRAY; instead, just return #f.
-
- If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
- return (SYMBOL . SCM_UNDEFINED). */
-
-
-static SCM
-intern_obarray_soft (SCM symbol, SCM obarray, unsigned int softness)
-{
- size_t raw_hash = scm_i_symbol_hash (symbol);
- size_t hash;
- SCM lsym;
-
- if (scm_is_false (obarray))
- {
- if (softness)
- return SCM_BOOL_F;
- else
- return scm_cons (symbol, SCM_UNDEFINED);
- }
-
- hash = raw_hash % SCM_VECTOR_LENGTH (obarray);
-
- for (lsym = SCM_VECTOR_REF(obarray, hash);
- SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
- {
- SCM a = SCM_CAR (lsym);
- SCM z = SCM_CAR (a);
- if (scm_is_eq (z, symbol))
- return a;
- }
-
- if (softness)
- {
- return SCM_BOOL_F;
- }
- else
- {
- SCM cell = scm_cons (symbol, SCM_UNDEFINED);
- SCM slot = SCM_VECTOR_REF (obarray, hash);
-
- SCM_VECTOR_SET (obarray, hash, scm_cons (cell, slot));
-
- return cell;
- }
-}
-
-
-SCM
-scm_intern_obarray_soft (const char *name, size_t len, SCM obarray,
- unsigned int softness)
-{
- SCM symbol = scm_from_locale_symboln (name, len);
-
- scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
- "Use hashtables instead.");
-
- return intern_obarray_soft (symbol, obarray, softness);
-}
-
-SCM
-scm_intern_obarray (const char *name,size_t len,SCM obarray)
-{
- scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. "
- "Use hashtables instead.");
-
- return scm_intern_obarray_soft (name, len, obarray, 0);
-}
-
-/* Lookup the value of the symbol named by the nul-terminated string
- NAME in the current module. */
-SCM
-scm_symbol_value0 (const char *name)
-{
- scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. "
- "Use `scm_lookup' instead.");
-
- return scm_variable_ref (scm_c_lookup (name));
-}
-
-SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0,
- (SCM o, SCM s, SCM softp),
- "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
- "@var{string}.\n\n"
- "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
- "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
- "symbol table; merely return the pair (@var{symbol}\n"
- ". @var{#<undefined>}).\n\n"
- "The @var{soft?} argument determines whether new symbol table entries\n"
- "should be created when the specified symbol is not already present in\n"
- "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
- "new entries should not be added for symbols not already present in the\n"
- "table; instead, simply return @code{#f}.")
-#define FUNC_NAME s_scm_string_to_obarray_symbol
-{
- SCM vcell;
- SCM answer;
- int softness;
-
- SCM_VALIDATE_STRING (2, s);
- SCM_ASSERT (scm_is_bool (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME);
-
- scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. "
- "Use hashtables instead.");
-
- softness = (!SCM_UNBNDP (softp) && scm_is_true(softp));
- /* iron out some screwy calling conventions */
- if (scm_is_false (o))
- {
- /* nothing interesting to do here. */
- return scm_string_to_symbol (s);
- }
- else if (scm_is_eq (o, SCM_BOOL_T))
- o = SCM_BOOL_F;
-
- vcell = intern_obarray_soft (scm_string_to_symbol (s), o, softness);
- if (scm_is_false (vcell))
- return vcell;
- answer = SCM_CAR (vcell);
- return answer;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0,
- (SCM o, SCM s),
- "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
- "unspecified initial value. The symbol table is not modified if a symbol\n"
- "with this name is already present.")
-#define FUNC_NAME s_scm_intern_symbol
-{
- size_t hval;
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- return SCM_UNSPECIFIED;
-
- scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_VECTOR (1,o);
- hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
- /* If the symbol is already interned, simply return. */
- SCM_CRITICAL_SECTION_START;
- {
- SCM lsym;
- SCM sym;
- for (lsym = SCM_VECTOR_REF (o, hval);
- SCM_NIMP (lsym);
- lsym = SCM_CDR (lsym))
- {
- sym = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (sym), s))
- {
- SCM_CRITICAL_SECTION_END;
- return SCM_UNSPECIFIED;
- }
- }
- SCM_VECTOR_SET (o, hval,
- scm_acons (s, SCM_UNDEFINED,
- SCM_VECTOR_REF (o, hval)));
- }
- SCM_CRITICAL_SECTION_END;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
- (SCM o, SCM s),
- "Remove the symbol with name @var{string} from @var{obarray}. This\n"
- "function returns @code{#t} if the symbol was present and @code{#f}\n"
- "otherwise.")
-#define FUNC_NAME s_scm_unintern_symbol
-{
- size_t hval;
-
- scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- return SCM_BOOL_F;
- SCM_VALIDATE_VECTOR (1,o);
- hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
- SCM_CRITICAL_SECTION_START;
- {
- SCM lsym_follow;
- SCM lsym;
- SCM sym;
- for (lsym = SCM_VECTOR_REF (o, hval), lsym_follow = SCM_BOOL_F;
- SCM_NIMP (lsym);
- lsym_follow = lsym, lsym = SCM_CDR (lsym))
- {
- sym = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (sym), s))
- {
- /* Found the symbol to unintern. */
- if (scm_is_false (lsym_follow))
- SCM_VECTOR_SET (o, hval, lsym);
- else
- SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
- SCM_CRITICAL_SECTION_END;
- return SCM_BOOL_T;
- }
- }
- }
- SCM_CRITICAL_SECTION_END;
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0,
- (SCM o, SCM s),
- "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
- "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
- "use the global symbol table. If @var{string} is not interned in\n"
- "@var{obarray}, an error is signalled.")
-#define FUNC_NAME s_scm_symbol_binding
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- return scm_variable_ref (scm_lookup (s));
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell (s, o);
- return SCM_CDR(vcell);
-}
-#undef FUNC_NAME
-
-#if 0
-SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0,
- (SCM o, SCM s),
- "Return @code{#t} if @var{obarray} contains a symbol with name\n"
- "@var{string}, and @code{#f} otherwise.")
-#define FUNC_NAME s_scm_symbol_interned_p
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- {
- SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F);
- if (var != SCM_BOOL_F)
- return SCM_BOOL_T;
- return SCM_BOOL_F;
- }
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell_soft (s, o);
- return (SCM_NIMP(vcell)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-#undef FUNC_NAME
-#endif
-
-SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0,
- (SCM o, SCM s),
- "Return @code{#t} if @var{obarray} contains a symbol with name\n"
- "@var{string} bound to a defined value. This differs from\n"
- "@var{symbol-interned?} in that the mere mention of a symbol\n"
- "usually causes it to be interned; @code{symbol-bound?}\n"
- "determines whether a symbol has been given any meaningful\n"
- "value.")
-#define FUNC_NAME s_scm_symbol_bound_p
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- {
- SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F);
- if (SCM_VARIABLEP(var) && !SCM_UNBNDP(SCM_VARIABLE_REF(var)))
- return SCM_BOOL_T;
- return SCM_BOOL_F;
- }
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell_soft (s, o);
- return scm_from_bool (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell)));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0,
- (SCM o, SCM s, SCM v),
- "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
- "it to @var{value}. An error is signalled if @var{string} is not present\n"
- "in @var{obarray}.")
-#define FUNC_NAME s_scm_symbol_set_x
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. "
- "Use the module system instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- {
- scm_define (s, v);
- return SCM_UNSPECIFIED;
- }
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell (s, o);
- SCM_SETCDR (vcell, v);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-#define MAX_PREFIX_LENGTH 30
-
-static int gentemp_counter;
-
-SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0,
- (SCM prefix, SCM obarray),
- "Create a new symbol with a name unique in an obarray.\n"
- "The name is constructed from an optional string @var{prefix}\n"
- "and a counter value. The default prefix is @code{t}. The\n"
- "@var{obarray} is specified as a second optional argument.\n"
- "Default is the system obarray where all normal symbols are\n"
- "interned. The counter is increased by 1 at each\n"
- "call. There is no provision for resetting the counter.")
-#define FUNC_NAME s_scm_gentemp
-{
- char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN];
- char *name = buf;
- int n_digits;
- size_t len;
-
- scm_c_issue_deprecation_warning ("`gentemp' is deprecated. "
- "Use `gensym' instead.");
-
- if (SCM_UNBNDP (prefix))
- {
- name[0] = 't';
- len = 1;
- }
- else
- {
- SCM_VALIDATE_STRING (1, prefix);
- len = scm_i_string_length (prefix);
- name = scm_to_locale_stringn (prefix, &len);
- name = scm_realloc (name, len + SCM_INTBUFLEN);
- }
-
- if (SCM_UNBNDP (obarray))
- return scm_gensym (prefix);
- else
- SCM_ASSERT ((scm_is_vector (obarray) || SCM_I_WVECTP (obarray)),
- obarray,
- SCM_ARG2,
- FUNC_NAME);
- do
- n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]);
- while (scm_is_true (scm_intern_obarray_soft (name,
- len + n_digits,
- obarray,
- 1)));
- {
- SCM vcell = scm_intern_obarray_soft (name,
- len + n_digits,
- obarray,
- 0);
- if (name != buf)
- free (name);
- return SCM_CAR (vcell);
- }
-}
-#undef FUNC_NAME
-
-SCM
-scm_i_makinum (scm_t_signed_bits val)
-{
- scm_c_issue_deprecation_warning
- ("SCM_MAKINUM is deprecated. Use scm_from_int or similar instead.");
- return SCM_I_MAKINUM (val);
-}
-
-int
-scm_i_inump (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_INUMP is deprecated. Use scm_is_integer or similar instead.");
- return SCM_I_INUMP (obj);
-}
-
-scm_t_signed_bits
-scm_i_inum (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_INUM is deprecated. Use scm_to_int or similar instead.");
- return scm_to_intmax (obj);
-}
-
-char *
-scm_c_string2str (SCM obj, char *str, size_t *lenp)
-{
- scm_c_issue_deprecation_warning
- ("scm_c_string2str is deprecated. Use scm_to_locale_stringbuf or similar instead.");
-
- if (str == NULL)
- {
- char *result = scm_to_locale_string (obj);
- if (lenp)
- *lenp = scm_i_string_length (obj);
- return result;
- }
- else
- {
- /* Pray that STR is large enough.
- */
- size_t len = scm_to_locale_stringbuf (obj, str, SCM_I_SIZE_MAX);
- str[len] = '\0';
- if (lenp)
- *lenp = len;
- return str;
- }
-}
-
-char *
-scm_c_substring2str (SCM obj, char *str, size_t start, size_t len)
-{
- scm_c_issue_deprecation_warning
- ("scm_c_substring2str is deprecated. Use scm_substring plus scm_to_locale_stringbuf instead.");
-
- if (start)
- obj = scm_substring (obj, scm_from_size_t (start), SCM_UNDEFINED);
-
- scm_to_locale_stringbuf (obj, str, len);
- return str;
-}
-
-/* Converts the given Scheme symbol OBJ into a C string, containing a copy
- of OBJ's content with a trailing null byte. If LENP is non-NULL, set
- *LENP to the string's length.
-
- When STR is non-NULL it receives the copy and is returned by the function,
- otherwise new memory is allocated and the caller is responsible for
- freeing it via free(). If out of memory, NULL is returned.
-
- Note that Scheme symbols may contain arbitrary data, including null
- characters. This means that null termination is not a reliable way to
- determine the length of the returned value. However, the function always
- copies the complete contents of OBJ, and sets *LENP to the length of the
- scheme symbol (if LENP is non-null). */
-char *
-scm_c_symbol2str (SCM obj, char *str, size_t *lenp)
-{
- return scm_c_string2str (scm_symbol_to_string (obj), str, lenp);
-}
-
-double
-scm_truncate (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_truncate is deprecated. Use scm_c_truncate instead.");
- return scm_c_truncate (x);
-}
-
-double
-scm_round (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_round is deprecated. Use scm_c_round instead.");
- 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)
-{
- scm_c_issue_deprecation_warning
- ("SCM_SYMBOL_CHARS is deprecated. Use scm_symbol_to_string.");
-
- return (char *)scm_i_symbol_chars (sym);
-}
-
-size_t
-scm_i_deprecated_symbol_length (SCM sym)
-{
- scm_c_issue_deprecation_warning
- ("SCM_SYMBOL_LENGTH is deprecated. Use scm_symbol_to_string.");
- return scm_i_symbol_length (sym);
-}
-
-int
-scm_i_keywordp (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_KEYWORDP is deprecated. Use scm_is_keyword instead.");
- return scm_is_keyword (obj);
-}
-
-SCM
-scm_i_keywordsym (SCM keyword)
-{
- scm_c_issue_deprecation_warning
- ("SCM_KEYWORDSYM is deprecated. See scm_keyword_to_symbol instead.");
- return scm_keyword_dash_symbol (keyword);
-}
-
-int
-scm_i_vectorp (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTORP is deprecated. Use scm_is_vector instead.");
- return SCM_I_IS_VECTOR (x);
-}
-
-unsigned long
-scm_i_vector_length (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead.");
- return SCM_I_VECTOR_LENGTH (x);
-}
-
-const SCM *
-scm_i_velts (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VELTS is deprecated. Use scm_vector_elements instead.");
- return SCM_I_VECTOR_ELTS (x);
-}
-
-SCM *
-scm_i_writable_velts (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_WRITABLE_VELTS is deprecated. "
- "Use scm_vector_writable_elements instead.");
- return SCM_I_VECTOR_WELTS (x);
-}
-
-SCM
-scm_i_vector_ref (SCM x, size_t idx)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTOR_REF is deprecated. "
- "Use scm_c_vector_ref or scm_vector_elements instead.");
- return scm_c_vector_ref (x, idx);
-}
-
-void
-scm_i_vector_set (SCM x, size_t idx, SCM val)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTOR_SET is deprecated. "
- "Use scm_c_vector_set_x or scm_vector_writable_elements instead.");
- scm_c_vector_set_x (x, idx, val);
-}
-
-SCM
-scm_vector_equal_p (SCM x, SCM y)
-{
- scm_c_issue_deprecation_warning
- ("scm_vector_euqal_p is deprecated. "
- "Use scm_equal_p instead.");
- return scm_equal_p (x, y);
-}
-
-SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
- (SCM uvec, SCM port_or_fd, SCM start, SCM end),
- "Fill the elements of @var{uvec} by reading\n"
- "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
- "The optional arguments @var{start} (inclusive) and @var{end}\n"
- "(exclusive) allow a specified region to be read,\n"
- "leaving the remainder of the vector unchanged.\n\n"
- "When @var{port-or-fdes} is a port, all specified elements\n"
- "of @var{uvec} are attempted to be read, potentially blocking\n"
- "while waiting for more input or end-of-file.\n"
- "When @var{port-or-fd} is an integer, a single call to\n"
- "read(2) is made.\n\n"
- "An error is signalled when the last element has only\n"
- "been partially filled before reaching end-of-file or in\n"
- "the single call to read(2).\n\n"
- "@code{uniform-vector-read!} returns the number of elements\n"
- "read.\n\n"
- "@var{port-or-fdes} may be omitted, in which case it defaults\n"
- "to the value returned by @code{(current-input-port)}.")
-#define FUNC_NAME s_scm_uniform_vector_read_x
-{
- SCM result;
- size_t c_width, c_start, c_end;
-
- SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
-
- scm_c_issue_deprecation_warning
- ("`uniform-vector-read!' is deprecated. Use `get-bytevector-n!' from\n"
- "`(rnrs io ports)' instead.");
-
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_input_port ();
-
- c_width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
-
- c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start);
- c_start *= c_width;
-
- c_end = SCM_UNBNDP (end) ? SCM_BYTEVECTOR_LENGTH (uvec)
- : scm_to_size_t (end) * c_width;
-
- result = scm_get_bytevector_n_x (port_or_fd, uvec,
- scm_from_size_t (c_start),
- scm_from_size_t (c_end - c_start));
-
- if (SCM_EOF_OBJECT_P (result))
- result = SCM_INUM0;
-
- return result;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
- (SCM uvec, SCM port_or_fd, SCM start, SCM end),
- "Write the elements of @var{uvec} as raw bytes to\n"
- "@var{port-or-fdes}, in the host byte order.\n\n"
- "The optional arguments @var{start} (inclusive)\n"
- "and @var{end} (exclusive) allow\n"
- "a specified region to be written.\n\n"
- "When @var{port-or-fdes} is a port, all specified elements\n"
- "of @var{uvec} are attempted to be written, potentially blocking\n"
- "while waiting for more room.\n"
- "When @var{port-or-fd} is an integer, a single call to\n"
- "write(2) is made.\n\n"
- "An error is signalled when the last element has only\n"
- "been partially written in the single call to write(2).\n\n"
- "The number of objects actually written is returned.\n"
- "@var{port-or-fdes} may be\n"
- "omitted, in which case it defaults to the value returned by\n"
- "@code{(current-output-port)}.")
-#define FUNC_NAME s_scm_uniform_vector_write
-{
- size_t c_width, c_start, c_end;
-
- SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
-
- scm_c_issue_deprecation_warning
- ("`uniform-vector-write' is deprecated. Use `put-bytevector' from\n"
- "`(rnrs io ports)' instead.");
-
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_output_port ();
-
- port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
-
- c_width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
-
- c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start);
- c_start *= c_width;
-
- c_end = SCM_UNBNDP (end) ? SCM_BYTEVECTOR_LENGTH (uvec) : scm_to_size_t (end);
- c_end *= c_width;
-
- return scm_put_bytevector (port_or_fd, uvec,
- scm_from_size_t (c_start),
- scm_from_size_t (c_end - c_start));
-}
-#undef FUNC_NAME
-
-static SCM
-scm_ra2contig (SCM ra, int copy)
-{
- SCM ret;
- long inc = 1;
- size_t k, len = 1;
- for (k = SCM_I_ARRAY_NDIM (ra); k--;)
- len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
- k = SCM_I_ARRAY_NDIM (ra);
- if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc)))
- {
- if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
- return ra;
- if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
- 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
- 0 == len % SCM_LONG_BIT))
- return ra;
- }
- ret = scm_i_make_array (k);
- SCM_I_ARRAY_BASE (ret) = 0;
- while (k--)
- {
- SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
- SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
- SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
- inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
- }
- SCM_I_ARRAY_V (ret) =
- scm_make_generalized_vector (scm_array_type (ra), scm_from_size_t (inc),
- SCM_UNDEFINED);
- if (copy)
- scm_array_copy_x (ra, ret);
- return ret;
-}
-
-SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
- (SCM ura, SCM port_or_fd, SCM start, SCM end),
- "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
- "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
- "binary objects from @var{port-or-fdes}.\n"
- "If an end of file is encountered,\n"
- "the objects up to that point are put into @var{ura}\n"
- "(starting at the beginning) and the remainder of the array is\n"
- "unchanged.\n\n"
- "The optional arguments @var{start} and @var{end} allow\n"
- "a specified region of a vector (or linearized array) to be read,\n"
- "leaving the remainder of the vector unchanged.\n\n"
- "@code{uniform-array-read!} returns the number of objects read.\n"
- "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
- "returned by @code{(current-input-port)}.")
-#define FUNC_NAME s_scm_uniform_array_read_x
-{
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_input_port ();
-
- if (scm_is_uniform_vector (ura))
- {
- return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
- }
- else if (SCM_I_ARRAYP (ura))
- {
- size_t base, vlen, cstart, cend;
- SCM cra, ans;
-
- cra = scm_ra2contig (ura, 0);
- base = SCM_I_ARRAY_BASE (cra);
- vlen = SCM_I_ARRAY_DIMS (cra)->inc *
- (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
-
- cstart = 0;
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- cstart = scm_to_unsigned_integer (start, 0, vlen);
- if (!SCM_UNBNDP (end))
- cend = scm_to_unsigned_integer (end, cstart, vlen);
- }
-
- ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
- scm_from_size_t (base + cstart),
- scm_from_size_t (base + cend));
-
- if (!scm_is_eq (cra, ura))
- scm_array_copy_x (cra, ura);
- return ans;
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, ura, "array");
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
- (SCM ura, SCM port_or_fd, SCM start, SCM end),
- "Writes all elements of @var{ura} as binary objects to\n"
- "@var{port-or-fdes}.\n\n"
- "The optional arguments @var{start}\n"
- "and @var{end} allow\n"
- "a specified region of a vector (or linearized array) to be written.\n\n"
- "The number of objects actually written is returned.\n"
- "@var{port-or-fdes} may be\n"
- "omitted, in which case it defaults to the value returned by\n"
- "@code{(current-output-port)}.")
-#define FUNC_NAME s_scm_uniform_array_write
-{
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_output_port ();
-
- if (scm_is_uniform_vector (ura))
- {
- return scm_uniform_vector_write (ura, port_or_fd, start, end);
- }
- else if (SCM_I_ARRAYP (ura))
- {
- size_t base, vlen, cstart, cend;
- SCM cra, ans;
-
- cra = scm_ra2contig (ura, 1);
- base = SCM_I_ARRAY_BASE (cra);
- vlen = SCM_I_ARRAY_DIMS (cra)->inc *
- (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
-
- cstart = 0;
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- cstart = scm_to_unsigned_integer (start, 0, vlen);
- if (!SCM_UNBNDP (end))
- cend = scm_to_unsigned_integer (end, cstart, vlen);
- }
-
- ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
- scm_from_size_t (base + cstart),
- scm_from_size_t (base + cend));
-
- return ans;
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, ura, "array");
-}
-#undef FUNC_NAME
-
-SCM
-scm_i_cur_inp (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_cur_inp is deprecated. Use scm_current_input_port instead.");
- return scm_current_input_port ();
-}
-
-SCM
-scm_i_cur_outp (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_cur_outp is deprecated. Use scm_current_output_port instead.");
- return scm_current_output_port ();
-}
-
-SCM
-scm_i_cur_errp (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_cur_errp is deprecated. Use scm_current_error_port instead.");
- return scm_current_error_port ();
-}
-
-SCM
-scm_i_cur_loadp (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_cur_loadp is deprecated. Use scm_current_load_port instead.");
- return scm_current_load_port ();
-}
-
-SCM
-scm_i_progargs (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_progargs is deprecated. Use scm_program_arguments instead.");
- return scm_program_arguments ();
-}
-
-SCM
-scm_i_deprecated_dynwinds (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_dynwinds is deprecated. Do not use it.");
- return scm_i_dynwinds ();
-}
-
-SCM_STACKITEM *
-scm_i_stack_base (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_stack_base is deprecated. Do not use it.");
- return SCM_I_CURRENT_THREAD->base;
-}
-
-int
-scm_i_fluidp (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_FLUIDP is deprecated. Use scm_is_fluid instead.");
- 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 ()
-{
- scm_c_issue_deprecation_warning
- ("SCM_DEFER_INTS etc are deprecated. "
- "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)
-{
- scm_c_issue_deprecation_warning
- ("scm_guard is deprecated. Use scm_call_1 instead.");
-
- return scm_call_1 (guardian, obj);
-}
-
-SCM
-scm_get_one_zombie (SCM guardian)
-{
- scm_c_issue_deprecation_warning
- ("scm_guard is deprecated. Use scm_call_0 instead.");
-
- return scm_call_0 (guardian);
-}
-
-SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0,
- (SCM guardian),
- "Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.")
-#define FUNC_NAME s_scm_guardian_destroyed_p
-{
- scm_c_issue_deprecation_warning
- ("'guardian-destroyed?' is deprecated.");
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_guardian_greedy_p, "guardian-greedy?", 1, 0, 0,
- (SCM guardian),
- "Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.")
-#define FUNC_NAME s_scm_guardian_greedy_p
-{
- scm_c_issue_deprecation_warning
- ("'guardian-greedy?' is deprecated.");
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0,
- (SCM guardian),
- "Destroys @var{guardian}, by making it impossible to put any more\n"
- "objects in it or get any objects from it. It also unguards any\n"
- "objects guarded by @var{guardian}.")
-#define FUNC_NAME s_scm_destroy_guardian_x
-{
- scm_c_issue_deprecation_warning
- ("'destroy-guardian!' is deprecated and ineffective.");
- return SCM_UNSPECIFIED;
-}
-#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;
-}
-
-int
-scm_i_subr_p (SCM x)
-{
- scm_c_issue_deprecation_warning ("`scm_subr_p' is deprecated. Use SCM_PRIMITIVE_P instead.");
- return SCM_PRIMITIVE_P (x);
-}
-
-\f
-
-SCM
-scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
-{
- scm_c_issue_deprecation_warning
- ("`scm_internal_lazy_catch' is no longer supported. Instead this call will\n"
- "dispatch to `scm_c_with_throw_handler'. Your handler will be invoked from\n"
- "within the dynamic context of the corresponding `throw'.\n"
- "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
- "Please modify your program to use `scm_c_with_throw_handler' directly,\n"
- "and adapt it (if necessary) to expect to be within the dynamic context\n"
- "of the throw.");
- return scm_c_with_throw_handler (tag, body, body_data, handler, handler_data, 0);
-}
-
-SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
- (SCM key, SCM thunk, SCM handler),
- "This behaves exactly like @code{catch}, except that it does\n"
- "not unwind the stack before invoking @var{handler}.\n"
- "If the @var{handler} procedure returns normally, Guile\n"
- "rethrows the same exception again to the next innermost catch,\n"
- "lazy-catch or throw handler. If the @var{handler} exits\n"
- "non-locally, that exit determines the continuation.")
-#define FUNC_NAME s_scm_lazy_catch
-{
- struct scm_body_thunk_data c;
-
- SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
- key, SCM_ARG1, FUNC_NAME);
-
- c.tag = key;
- c.body_proc = thunk;
-
- scm_c_issue_deprecation_warning
- ("`lazy-catch' is no longer supported. Instead this call will dispatch\n"
- "to `with-throw-handler'. Your handler will be invoked from within the\n"
- "dynamic context of the corresponding `throw'.\n"
- "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
- "Please modify your program to use `with-throw-handler' directly, and\n"
- "adapt it (if necessary) to expect to be within the dynamic context of\n"
- "the throw.");
-
- return scm_c_with_throw_handler (key,
- scm_body_thunk, &c,
- scm_handle_by_proc, &handler, 0);
-}
-#undef FUNC_NAME
-
-
-\f
-
-
-SCM
-scm_raequal (SCM ra0, SCM ra1)
-{
- return scm_array_equal_p (ra0, ra1);
-}
-
-
-\f
-
-
-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"
- "just like @code{dynamic-call}, but pass it some arguments and\n"
- "return its return value. The C function is expected to take\n"
- "two arguments and return an @code{int}, just like @code{main}:\n"
- "@smallexample\n"
- "int c_func (int argc, char **argv);\n"
- "@end smallexample\n\n"
- "The parameter @var{args} must be a list of strings and is\n"
- "converted into an array of @code{char *}. The array is passed\n"
- "in @var{argv} and its size in @var{argc}. The return value is\n"
- "converted to a Scheme number and returned from the call to\n"
- "@code{dynamic-args-call}.")
-#define FUNC_NAME s_scm_dynamic_args_call
-{
- int (*fptr) (int argc, char **argv);
- int result, argc;
- char **argv;
-
- if (scm_is_string (func))
- {
-#if HAVE_MODULES
- func = scm_dynamic_func (func, dobj);
-#else
- scm_misc_error ("dynamic-args-call",
- "dynamic-func not available to resolve ~S",
- scm_list_1 (func));
-#endif
- }
- SCM_VALIDATE_POINTER (SCM_ARG1, func);
-
- fptr = SCM_POINTER_VALUE (func);
-
- argv = scm_i_allocate_string_pointers (args);
- for (argc = 0; argv[argc]; argc++)
- ;
- result = (*fptr) (argc, argv);
-
- return scm_from_int (result);
-}
-#undef FUNC_NAME
-
-
-\f
-
-
-int
-scm_badargsp (SCM formals, SCM args)
-{
- scm_c_issue_deprecation_warning
- ("`scm_badargsp' is deprecated. Copy it into your project if you need it.");
-
- 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
-
-/* scm_internal_stack_catch
- Use this one if you want debugging information to be stored in
- the-last-stack on error. */
-
-static SCM
-ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args)
-{
- /* In the stack */
- scm_fluid_set_x (scm_variable_ref
- (scm_c_module_lookup
- (scm_c_resolve_module ("ice-9 save-stack"),
- "the-last-stack")),
- scm_make_stack (SCM_BOOL_T, SCM_EOL));
- /* Throw the error */
- return scm_throw (tag, throw_args);
-}
-
-struct cwss_data
-{
- SCM tag;
- scm_t_catch_body body;
- void *data;
-};
-
-static SCM
-cwss_body (void *data)
-{
- struct cwss_data *d = data;
- return scm_c_with_throw_handler (d->tag, d->body, d->data, ss_handler, NULL, 0);
-}
-
-SCM
-scm_internal_stack_catch (SCM tag,
- scm_t_catch_body body,
- void *body_data,
- scm_t_catch_handler handler,
- void *handler_data)
-{
- struct cwss_data d;
- d.tag = tag;
- d.body = body;
- d.data = body_data;
- scm_c_issue_deprecation_warning
- ("`scm_internal_stack_catch' is deprecated. Talk to guile-devel if you see this message.");
- return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
-}
-
-\f
-
-SCM
-scm_short2num (short x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_short2num' is deprecated. Use scm_from_short instead.");
- return scm_from_short (x);
-}
-
-SCM
-scm_ushort2num (unsigned short x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_ushort2num' is deprecated. Use scm_from_ushort instead.");
- return scm_from_ushort (x);
-}
-
-SCM
-scm_int2num (int x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_int2num' is deprecated. Use scm_from_int instead.");
- return scm_from_int (x);
-}
-
-SCM
-scm_uint2num (unsigned int x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_uint2num' is deprecated. Use scm_from_uint instead.");
- return scm_from_uint (x);
-}
-
-SCM
-scm_long2num (long x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_long2num' is deprecated. Use scm_from_long instead.");
- return scm_from_long (x);
-}
-
-SCM
-scm_ulong2num (unsigned long x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_ulong2num' is deprecated. Use scm_from_ulong instead.");
- return scm_from_ulong (x);
-}
-
-SCM
-scm_size2num (size_t x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_size2num' is deprecated. Use scm_from_size_t instead.");
- return scm_from_size_t (x);
-}
-
-SCM
-scm_ptrdiff2num (ptrdiff_t x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_ptrdiff2num' is deprecated. Use scm_from_ssize_t instead.");
- return scm_from_ssize_t (x);
-}
-
-short
-scm_num2short (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2short' is deprecated. Use scm_to_short instead.");
- return scm_to_short (x);
-}
-
-unsigned short
-scm_num2ushort (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2ushort' is deprecated. Use scm_to_ushort instead.");
- return scm_to_ushort (x);
-}
-
-int
-scm_num2int (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2int' is deprecated. Use scm_to_int instead.");
- return scm_to_int (x);
-}
-
-unsigned int
-scm_num2uint (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2uint' is deprecated. Use scm_to_uint instead.");
- return scm_to_uint (x);
-}
-
-long
-scm_num2long (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2long' is deprecated. Use scm_to_long instead.");
- return scm_to_long (x);
-}
-
-unsigned long
-scm_num2ulong (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2ulong' is deprecated. Use scm_to_ulong instead.");
- return scm_to_ulong (x);
-}
-
-size_t
-scm_num2size (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2size' is deprecated. Use scm_to_size_t instead.");
- return scm_to_size_t (x);
-}
-
-ptrdiff_t
-scm_num2ptrdiff (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2ptrdiff' is deprecated. Use scm_to_ssize_t instead.");
- return scm_to_ssize_t (x);
-}
-
-#if SCM_SIZEOF_LONG_LONG != 0
-
-SCM
-scm_long_long2num (long long x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_long_long2num' is deprecated. Use scm_from_long_long instead.");
- return scm_from_long_long (x);
-}
-
-SCM
-scm_ulong_long2num (unsigned long long x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_ulong_long2num' is deprecated. Use scm_from_ulong_long instead.");
- return scm_from_ulong_long (x);
-}
-
-long long
-scm_num2long_long (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2long_long' is deprecated. Use scm_to_long_long instead.");
- return scm_to_long_long (x);
-}
-
-unsigned long long
-scm_num2ulong_long (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2ulong_long' is deprecated. Use scm_from_ulong_long instead.");
- return scm_to_ulong_long (x);
-}
-
-#endif
-
-SCM
-scm_make_real (double x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_real' is deprecated. Use scm_from_double instead.");
- return scm_from_double (x);
-}
-
-double
-scm_num2dbl (SCM a, const char *why)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2dbl' is deprecated. Use scm_to_double instead.");
- return scm_to_double (a);
-}
-
-SCM
-scm_float2num (float n)
-{
- scm_c_issue_deprecation_warning
- ("`scm_float2num' is deprecated. Use scm_from_double instead.");
- return scm_from_double ((double) n);
-}
-
-SCM
-scm_double2num (double n)
-{
- scm_c_issue_deprecation_warning
- ("`scm_double2num' is deprecated. Use scm_from_double instead.");
- return scm_from_double (n);
-}
-
-SCM
-scm_make_complex (double x, double y)
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_complex' is deprecated. Use scm_c_make_rectangular instead.");
- return scm_c_make_rectangular (x, y);
-}
-
-SCM
-scm_mem2symbol (const char *mem, size_t len)
-{
- scm_c_issue_deprecation_warning
- ("`scm_mem2symbol' is deprecated. Use scm_from_locale_symboln instead.");
- return scm_from_locale_symboln (mem, len);
-}
-
-SCM
-scm_mem2uninterned_symbol (const char *mem, size_t len)
-{
- scm_c_issue_deprecation_warning
- ("`scm_mem2uninterned_symbol' is deprecated. "
- "Use scm_make_symbol and scm_from_locale_symboln instead.");
- return scm_make_symbol (scm_from_locale_stringn (mem, len));
-}
-
-SCM
-scm_str2symbol (const char *str)
-{
- scm_c_issue_deprecation_warning
- ("`scm_str2symbol' is deprecated. Use scm_from_locale_symbol instead.");
- return scm_from_locale_symbol (str);
-}
-
-
-/* This function must only be applied to memory obtained via malloc,
- since the GC is going to apply `free' to it when the string is
- dropped.
-
- Also, s[len] must be `\0', since we promise that strings are
- null-terminated. Perhaps we could handle non-null-terminated
- strings by claiming they're shared substrings of a string we just
- made up. */
-SCM
-scm_take_str (char *s, size_t len)
-{
- scm_c_issue_deprecation_warning
- ("`scm_take_str' is deprecated. Use scm_take_locale_stringn instead.");
- return scm_take_locale_stringn (s, len);
-}
-
-/* `s' must be a malloc'd string. See scm_take_str. */
-SCM
-scm_take0str (char *s)
-{
- scm_c_issue_deprecation_warning
- ("`scm_take0str' is deprecated. Use scm_take_locale_string instead.");
- return scm_take_locale_string (s);
-}
-
-SCM
-scm_mem2string (const char *src, size_t len)
-{
- scm_c_issue_deprecation_warning
- ("`scm_mem2string' is deprecated. Use scm_from_locale_stringn instead.");
- return scm_from_locale_stringn (src, len);
-}
-
-SCM
-scm_str2string (const char *src)
-{
- scm_c_issue_deprecation_warning
- ("`scm_str2string' is deprecated. Use scm_from_locale_string instead.");
- return scm_from_locale_string (src);
-}
-
-SCM
-scm_makfrom0str (const char *src)
-{
- scm_c_issue_deprecation_warning
- ("`scm_makfrom0str' is deprecated."
- "Use scm_from_locale_string instead, but check for NULL first.");
- if (!src) return SCM_BOOL_F;
- return scm_from_locale_string (src);
-}
-
-SCM
-scm_makfrom0str_opt (const char *src)
-{
- scm_c_issue_deprecation_warning
- ("`scm_makfrom0str_opt' is deprecated."
- "Use scm_from_locale_string instead, but check for NULL first.");
- return scm_makfrom0str (src);
-}
-
-
-SCM
-scm_allocate_string (size_t len)
-{
- scm_c_issue_deprecation_warning
- ("`scm_allocate_string' is deprecated. Use scm_c_make_string instead.");
- return scm_i_make_string (len, NULL, 0);
-}
-
-SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0,
- (SCM symbol),
- "Make a keyword object from a @var{symbol} that starts with a dash.")
-#define FUNC_NAME s_scm_make_keyword_from_dash_symbol
-{
- SCM dash_string, non_dash_symbol;
-
- scm_c_issue_deprecation_warning
- ("`scm_make_keyword_from_dash_symbol' is deprecated. Don't use dash symbols.");
-
- SCM_ASSERT (scm_is_symbol (symbol)
- && (scm_i_symbol_ref (symbol, 0) == '-'),
- symbol, SCM_ARG1, FUNC_NAME);
-
- dash_string = scm_symbol_to_string (symbol);
- non_dash_symbol =
- scm_string_to_symbol (scm_c_substring (dash_string,
- 1,
- scm_c_string_length (dash_string)));
-
- return scm_symbol_to_keyword (non_dash_symbol);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0,
- (SCM keyword),
- "Return the dash symbol for @var{keyword}.\n"
- "This is the inverse of @code{make-keyword-from-dash-symbol}.")
-#define FUNC_NAME s_scm_keyword_dash_symbol
-{
- SCM symbol = scm_keyword_to_symbol (keyword);
- SCM parts = scm_list_2 (scm_from_locale_string ("-"),
- scm_symbol_to_string (symbol));
- scm_c_issue_deprecation_warning
- ("`scm_keyword_dash_symbol' is deprecated. Don't use dash symbols.");
-
- return scm_string_to_symbol (scm_string_append (parts));
-}
-#undef FUNC_NAME
-
-SCM
-scm_c_make_keyword (const char *s)
-{
- scm_c_issue_deprecation_warning
- ("`scm_c_make_keyword' is deprecated. Use scm_from_locale_keyword instead.");
- return scm_from_locale_keyword (s);
-}
-
-unsigned int
-scm_thread_sleep (unsigned int t)
-{
- scm_c_issue_deprecation_warning
- ("`scm_thread_sleep' is deprecated. Use scm_std_sleep instead.");
- return scm_std_sleep (t);
-}
-
-unsigned long
-scm_thread_usleep (unsigned long t)
-{
- scm_c_issue_deprecation_warning
- ("`scm_thread_usleep' is deprecated. Use scm_std_usleep instead.");
- return scm_std_usleep (t);
-}
-
-#ifdef HAVE_SYS_SELECT_H
-int scm_internal_select (int fds,
- fd_set *rfds,
- fd_set *wfds,
- fd_set *efds,
- struct timeval *timeout)
-{
- scm_c_issue_deprecation_warning
- ("`scm_internal_select' is deprecated. Use scm_std_select instead.");
- return scm_std_select (fds, rfds, wfds, efds, timeout);
-}
-#endif /* HAVE_SYS_SELECT_H */
-
-\f
-
-#ifdef HAVE_CUSERID
-
-# if !HAVE_DECL_CUSERID
-extern char *cuserid (char *);
-# endif
-
-SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
- (void),
- "Return a string containing a user name associated with the\n"
- "effective user id of the process. Return @code{#f} if this\n"
- "information cannot be obtained.")
-#define FUNC_NAME s_scm_cuserid
-{
- char buf[L_cuserid];
- char * p;
-
- scm_c_issue_deprecation_warning
- ("`cuserid' is deprecated. Use `(passwd:name (getpwuid (geteuid)))' instead.");
-
- p = cuserid (buf);
- if (!p || !*p)
- return SCM_BOOL_F;
- return scm_from_locale_string (p);
-}
-#undef FUNC_NAME
-#endif /* HAVE_CUSERID */
-
-\f
-
-/* {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"
- "@code{primitive-property-ref} and @code{primitive-property-set!}.\n"
- "See @code{primitive-property-ref} for the significance of\n"
- "@var{not_found_proc}.")
-#define FUNC_NAME s_scm_primitive_make_property
-{
- scm_c_issue_deprecation_warning
- ("`primitive-make-property' is deprecated. Use object properties.");
-
- if (!scm_is_false (not_found_proc))
- SCM_VALIDATE_PROC (SCM_ARG1, not_found_proc);
- return scm_cons (not_found_proc, SCM_EOL);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
- (SCM prop, SCM obj),
- "Return the property @var{prop} of @var{obj}.\n"
- "\n"
- "When no value has yet been associated with @var{prop} and\n"
- "@var{obj}, the @var{not-found-proc} from @var{prop} is used. A\n"
- "call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made\n"
- "and the result set as the property value. If\n"
- "@var{not-found-proc} is @code{#f} then @code{#f} is the\n"
- "property value.")
-#define FUNC_NAME s_scm_primitive_property_ref
-{
- SCM alist;
-
- scm_c_issue_deprecation_warning
- ("`primitive-property-ref' is deprecated. Use object properties.");
-
- SCM_VALIDATE_CONS (SCM_ARG1, prop);
-
- alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
- if (scm_is_pair (alist))
- {
- SCM assoc = scm_assq (prop, alist);
- if (scm_is_true (assoc))
- return SCM_CDR (assoc);
- }
-
- if (scm_is_false (SCM_CAR (prop)))
- return SCM_BOOL_F;
- else
- {
- SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
- scm_hashq_set_x (properties_whash, obj,
- scm_acons (prop, val, alist));
- return val;
- }
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0,
- (SCM prop, SCM obj, SCM val),
- "Set the property @var{prop} of @var{obj} to @var{val}.")
-#define FUNC_NAME s_scm_primitive_property_set_x
-{
- SCM alist, assoc;
-
- scm_c_issue_deprecation_warning
- ("`primitive-property-set!' is deprecated. Use object properties.");
-
- SCM_VALIDATE_CONS (SCM_ARG1, prop);
- alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
- assoc = scm_assq (prop, alist);
- if (scm_is_pair (assoc))
- SCM_SETCDR (assoc, val);
- else
- scm_hashq_set_x (properties_whash, obj,
- scm_acons (prop, val, alist));
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0,
- (SCM prop, SCM obj),
- "Remove any value associated with @var{prop} and @var{obj}.")
-#define FUNC_NAME s_scm_primitive_property_del_x
-{
- SCM alist;
-
- scm_c_issue_deprecation_warning
- ("`primitive-property-del!' is deprecated. Use object properties.");
-
- SCM_VALIDATE_CONS (SCM_ARG1, prop);
- alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
- if (scm_is_pair (alist))
- scm_hashq_set_x (properties_whash, obj, scm_assq_remove_x (alist, prop));
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-\f
-
-SCM
-scm_whash_get_handle (SCM whash, SCM key)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- return scm_hashq_get_handle (whash, key);
-}
-
-int
-SCM_WHASHFOUNDP (SCM h)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- return scm_is_true (h);
-}
-
-SCM
-SCM_WHASHREF (SCM whash, SCM handle)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- return SCM_CDR (handle);
-}
-
-void
-SCM_WHASHSET (SCM whash, SCM handle, SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- SCM_SETCDR (handle, obj);
-}
-
-SCM
-scm_whash_create_handle (SCM whash, SCM key)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- return scm_hashq_create_handle_x (whash, key, SCM_UNSPECIFIED);
-}
-
-SCM
-scm_whash_lookup (SCM whash, SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- return scm_hashq_ref (whash, obj, SCM_BOOL_F);
-}
-
-void
-scm_whash_insert (SCM whash, SCM key, SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- scm_hashq_set_x (whash, key, obj);
-}
-
-\f
-
-SCM scm_struct_table = SCM_BOOL_F;
-
-SCM
-scm_struct_create_handle (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("`scm_struct_create_handle' is deprecated, and has no effect.");
-
- return scm_cons (obj, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
-}
-
-\f
-
-SCM
-scm_internal_dynamic_wind (scm_t_guard before,
- scm_t_inner inner,
- scm_t_guard after,
- void *inner_data,
- void *guard_data)
-{
- SCM ans;
-
- scm_c_issue_deprecation_warning
- ("`scm_internal_dynamic_wind' is deprecated. "
- "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
-
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
- ans = inner (inner_data);
- scm_dynwind_end ();
- return ans;
-}
-
-\f
-
-SCM
-scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
-{
- scm_c_issue_deprecation_warning
- ("scm_immutable_cell is deprecated. Use scm_cell instead.");
-
- return scm_cell (car, cdr);
-}
-
-SCM
-scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
- scm_t_bits ccr, scm_t_bits cdr)
-{
- scm_c_issue_deprecation_warning
- ("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
-
- return scm_double_cell (car, cbr, ccr, cdr);
-}
-
-\f
-
-
-scm_t_bits
-scm_i_deprecated_asrtgo (scm_t_bits condition)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ASRTGO is deprecated. Use `if (!condition) goto label;' directly.");
-
- return condition;
-}
-
-
-\f
-
-
-/* scm_sym2var
- *
- * looks up the variable bound to SYM according to PROC. PROC should be
- * a `eval closure' of some module.
- *
- * When no binding exists, and DEFINEP is true, create a new binding
- * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
- * false and no binding exists.
- *
- * When PROC is `#f', it is ignored and the binding is searched for in
- * the scm_pre_modules_obarray (a `eq' hash table).
- */
-
-SCM
-scm_sym2var (SCM sym, SCM proc, SCM definep)
-#define FUNC_NAME "scm_sym2var"
-{
- SCM var;
-
- if (scm_is_true (definep))
- scm_c_issue_deprecation_warning
- ("scm_sym2var is deprecated. Use scm_define or scm_module_define\n"
- "to define variables. In some rare cases you may need\n"
- "scm_module_ensure_local_variable.");
- else
- scm_c_issue_deprecation_warning
- ("scm_sym2var is deprecated. Use scm_module_variable to look up\n"
- "variables.");
-
- if (SCM_NIMP (proc))
- {
- if (SCM_EVAL_CLOSURE_P (proc))
- {
- /* Bypass evaluator in the standard case. */
- var = scm_eval_closure_lookup (proc, sym, definep);
- }
- else
- var = scm_call_2 (proc, sym, definep);
- }
- else
- {
- if (scm_is_false (definep))
- var = scm_module_variable (scm_the_root_module (), sym);
- else
- var = scm_module_ensure_local_variable (scm_the_root_module (), sym);
- }
-
- if (scm_is_true (var) && !SCM_VARIABLEP (var))
- SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
-
- return var;
-}
-#undef FUNC_NAME
-
-SCM
-scm_lookup_closure_module (SCM proc)
-{
- scm_c_issue_deprecation_warning
- ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
- "the manual, for replacements.");
-
- if (scm_is_false (proc))
- return scm_the_root_module ();
- else if (SCM_EVAL_CLOSURE_P (proc))
- return SCM_PACK (SCM_SMOB_DATA (proc));
- else
- /* FIXME: The `module' property is no longer set on eval closures, as it
- introduced 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 this
- function, which has 1 caller), we no longer extend
- `set-module-eval-closure!' to set the `module' property. */
- abort ();
-}
-
-SCM
-scm_module_lookup_closure (SCM module)
-{
- scm_c_issue_deprecation_warning
- ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
- "the manual, for replacements.");
-
- if (scm_is_false (module))
- return SCM_BOOL_F;
- else
- return SCM_MODULE_EVAL_CLOSURE (module);
-}
-
-SCM
-scm_current_module_lookup_closure ()
-{
- scm_c_issue_deprecation_warning
- ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
- "the manual, for replacements.");
-
- if (scm_module_system_booted_p)
- return scm_module_lookup_closure (scm_current_module ());
- else
- return SCM_BOOL_F;
-}
-
-scm_t_bits scm_tc16_eval_closure;
-
-#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<0)
-#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
- (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. */
-SCM
-scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
-{
- SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
-
- scm_c_issue_deprecation_warning
- ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
- "the manual, for replacements.");
-
- if (scm_is_true (definep))
- {
- if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
- return SCM_BOOL_F;
- return scm_module_ensure_local_variable (module, sym);
- }
- else
- return scm_module_variable (module, sym);
-}
-
-SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
- (SCM module),
- "Return an eval closure for the module @var{module}.")
-#define FUNC_NAME s_scm_standard_eval_closure
-{
- scm_c_issue_deprecation_warning
- ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
- "the manual, for replacements.");
-
- SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_standard_interface_eval_closure,
- "standard-interface-eval-closure", 1, 0, 0,
- (SCM module),
- "Return a interface eval closure for the module @var{module}. "
- "Such a closure does not allow new bindings to be added.")
-#define FUNC_NAME s_scm_standard_interface_eval_closure
-{
- scm_c_issue_deprecation_warning
- ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
- "the manual, for replacements.");
-
- SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | (SCM_F_EVAL_CLOSURE_INTERFACE<<16),
- SCM_UNPACK (module));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_eval_closure_module,
- "eval-closure-module", 1, 0, 0,
- (SCM eval_closure),
- "Return the module associated with this eval closure.")
-/* the idea is that eval closures are really not the way to do things, they're
- superfluous given our module system. this function lets mmacros migrate away
- from eval closures. */
-#define FUNC_NAME s_scm_eval_closure_module
-{
- scm_c_issue_deprecation_warning
- ("Eval closures are deprecated. See \"Accessing Modules From C\" in\n"
- "the manual, for replacements.");
-
- SCM_MAKE_VALIDATE_MSG (SCM_ARG1, eval_closure, EVAL_CLOSURE_P,
- "eval-closure");
- return SCM_SMOB_OBJECT (eval_closure);
-}
-#undef FUNC_NAME
-
-
-\f
-
-SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
- (SCM handle),
- "Return the vtable tag of the structure @var{handle}.")
-#define FUNC_NAME s_scm_struct_vtable_tag
-{
- SCM_VALIDATE_VTABLE (1, handle);
- scm_c_issue_deprecation_warning
- ("struct-vtable-tag is deprecated. What were you doing with it anyway?");
-
- return scm_from_unsigned_integer
- (((scm_t_bits)SCM_STRUCT_DATA (handle)) >> 3);
-}
-#undef FUNC_NAME
-
-
-\f
-
-SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a vector, string,\n"
- "bitvector, or uniform numeric vector.")
-#define FUNC_NAME s_scm_generalized_vector_p
-{
- scm_c_issue_deprecation_warning
- ("generalized-vector? is deprecated. Use array? and check the "
- "array-rank instead.");
- return scm_from_bool (scm_is_generalized_vector (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0,
- (SCM v),
- "Return the length of the generalized vector @var{v}.")
-#define FUNC_NAME s_scm_generalized_vector_length
-{
- scm_c_issue_deprecation_warning
- ("generalized-vector-length is deprecated. Use array-length instead.");
- return scm_from_size_t (scm_c_generalized_vector_length (v));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
- (SCM v, SCM idx),
- "Return the element at index @var{idx} of the\n"
- "generalized vector @var{v}.")
-#define FUNC_NAME s_scm_generalized_vector_ref
-{
- scm_c_issue_deprecation_warning
- ("generalized-vector-ref is deprecated. Use array-ref instead.");
- return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
- (SCM v, SCM idx, SCM val),
- "Set the element at index @var{idx} of the\n"
- "generalized vector @var{v} to @var{val}.")
-#define FUNC_NAME s_scm_generalized_vector_set_x
-{
- scm_c_issue_deprecation_warning
- ("generalized-vector-set! is deprecated. Use array-set! instead. "
- "Note the change in argument order!");
- scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
- (SCM v),
- "Return a new list whose elements are the elements of the\n"
- "generalized vector @var{v}.")
-#define FUNC_NAME s_scm_generalized_vector_to_list
-{
- /* FIXME: This duplicates `array_to_list'. */
- SCM ret = SCM_EOL;
- long inc;
- ssize_t pos, i;
- scm_t_array_handle h;
-
- scm_c_issue_deprecation_warning
- ("generalized-vector->list is deprecated. Use array->list instead.");
-
- scm_generalized_vector_get_handle (v, &h);
-
- i = h.dims[0].ubnd - h.dims[0].lbnd + 1;
- inc = h.dims[0].inc;
- pos = (i - 1) * inc;
-
- for (; i > 0; i--, pos -= inc)
- ret = scm_cons (h.impl->vref (&h, h.base + pos), ret);
-
- scm_array_handle_release (&h);
- return ret;
-}
-#undef FUNC_NAME
-
-
-\f
-
-extern SCM
-scm_c_program_source (SCM program, size_t ip)
-{
- scm_c_issue_deprecation_warning
- ("scm_c_program_source is deprecated. Use scm_program_source instead.");
-
- return scm_program_source (program, scm_from_size_t (ip), SCM_UNBOUND);
-}
-
-
-\f
-
-SCM_DEFINE (scm_gc_live_object_stats, "gc-live-object-stats", 0, 0, 0,
- (),
- "Return an alist of statistics of the current live objects. ")
-#define FUNC_NAME s_scm_gc_live_object_stats
-{
- scm_c_issue_deprecation_warning
- ("gc-live-object-stats is deprecated. There is no replacement,\n"
- "unfortunately.");
-
- return SCM_EOL;
-}
-#undef FUNC_NAME
-
-
-\f
-
-SCM_DEFINE (scm_htons, "htons", 1, 0, 0,
- (SCM value),
- "Convert a 16 bit quantity from host to network byte ordering.\n"
- "@var{value} is packed into 2 bytes, which are then converted\n"
- "and returned as a new integer.")
-#define FUNC_NAME s_scm_htons
-{
- scm_c_issue_deprecation_warning
- ("htons is deprecated. Use bytevector-u16-set! and bytevector-u16-ref "
- "with big endianness.");
-
- return scm_from_ushort (htons (scm_to_ushort (value)));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_ntohs, "ntohs", 1, 0, 0,
- (SCM value),
- "Convert a 16 bit quantity from network to host byte ordering.\n"
- "@var{value} is packed into 2 bytes, which are then converted\n"
- "and returned as a new integer.")
-#define FUNC_NAME s_scm_ntohs
-{
- scm_c_issue_deprecation_warning
- ("ntohs is deprecated. Use bytevector-u16-set! and bytevector-u16-ref "
- "with big endianness.");
-
- return scm_from_ushort (ntohs (scm_to_ushort (value)));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0,
- (SCM value),
- "Convert a 32 bit quantity from host to network byte ordering.\n"
- "@var{value} is packed into 4 bytes, which are then converted\n"
- "and returned as a new integer.")
-#define FUNC_NAME s_scm_htonl
-{
- scm_c_issue_deprecation_warning
- ("htonl is deprecated. Use bytevector-u32-set! and bytevector-u32-ref "
- "with big endianness.");
-
- return scm_from_ulong (htonl (scm_to_uint32 (value)));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0,
- (SCM value),
- "Convert a 32 bit quantity from network to host byte ordering.\n"
- "@var{value} is packed into 4 bytes, which are then converted\n"
- "and returned as a new integer.")
-#define FUNC_NAME s_scm_ntohl
-{
- scm_c_issue_deprecation_warning
- ("ntohl is deprecated. Use bytevector-u32-set! and bytevector-u32-ref "
- "with big endianness.");
-
- return scm_from_ulong (ntohl (scm_to_uint32 (value)));
-}
-#undef FUNC_NAME
-
-
-\f
-
-void
-scm_i_init_deprecated ()
-{
- properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
- scm_struct_table = scm_make_hash_table (SCM_UNDEFINED);
- scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
- scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
-
-#include "libguile/deprecated.x"
-}
-
-#endif
+/* This file contains definitions for deprecated features. When you
+ deprecate something, move it here when that is feasible.
+*/
+
+/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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
+
+#define SCM_BUILDING_DEPRECATED_CODE
+
+#include "libguile/_scm.h"
+#include "libguile/deprecation.h"
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+\f
+
+SCM
+scm_internal_dynamic_wind (scm_t_guard before,
+ scm_t_inner inner,
+ scm_t_guard after,
+ void *inner_data,
+ void *guard_data)
+{
+ SCM ans;
+
+ scm_c_issue_deprecation_warning
+ ("`scm_internal_dynamic_wind' is deprecated. "
+ "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
+ ans = inner (inner_data);
+ scm_dynwind_end ();
+ return ans;
+}
+
+\f
+
+SCM
+scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_immutable_cell is deprecated. Use scm_cell instead.");
+
+ return scm_cell (car, cdr);
+}
+
+SCM
+scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
+
+ return scm_double_cell (car, cbr, ccr, cdr);
+}
+
+
+\f
+
+SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
+void
+scm_memory_error (const char *subr)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_memory_error is deprecated. Use scm_report_out_of_memory to raise "
+ "an exception, or abort() to cause the program to exit.");
+
+ fprintf (stderr, "FATAL: memory error in %s\n", subr);
+ abort ();
+}
+
+
+\f
+
+void
+scm_i_init_deprecated ()
+{
+#include "libguile/deprecated.x"
+}
+
+#endif
-/* This file contains definitions for deprecated features. When you
- deprecate something, move it here when that is feasible.
-*/
-
-#ifndef SCM_DEPRECATED_H
-#define SCM_DEPRECATED_H
-
-/* Copyright (C) 2003,2004, 2005, 2006, 2007, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#include "libguile/__scm.h"
-#include "libguile/strings.h"
-#include "libguile/eval.h"
-#include "libguile/throw.h"
-#include "libguile/iselect.h"
-
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-/* From eval.h: Macros for handling ilocs. These were deprecated in guile
- * 1.7.0 on 2004-04-22. */
-#define SCM_IFRINC (0x00000100L)
-#define SCM_ICDR (0x00080000L)
-#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))
-
-
-/* From tags.h: Macros to access internal symbol names of isyms. Deprecated
- * in guile 1.7.0 on 2004-04-22. */
-SCM_API char *scm_isymnames[];
-#define SCM_ISYMNUM(n) 0
-#define SCM_ISYMCHARS(n) "#@<deprecated>"
-
-
-/* From tags.h: Macro checking for two tc16 types that are allocated to differ
- * only in the 's'-bit. Deprecated in guile 1.7.0 on 2003-09-21. */
-#define SCM_TYP16S(x) (0xfeff & SCM_CELL_TYPE (x))
-
-
-/* From numbers.h: Macros checking for types, but avoiding a redundant check
- * for !SCM_IMP. These were deprecated in guile 1.7.0 on 2003-09-06. */
-#define SCM_SLOPPY_INEXACTP(x) (SCM_TYP16S (x) == scm_tc16_real)
-#define SCM_SLOPPY_REALP(x) (SCM_TYP16 (x) == scm_tc16_real)
-#define SCM_SLOPPY_COMPLEXP(x) (SCM_TYP16 (x) == scm_tc16_complex)
-
-
-/* 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_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_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_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))))
-#define SCM_SETOR_CAR(x, y)\
- (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) | (y))))
-#define SCM_SETAND_CDR(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) (0)
-#define SCM_NFREEP(x) (1)
-#define SCM_GCTYP16(x) SCM_TYP16 (x)
-#define SCM_GCCDR(x) SCM_CDR (x)
-SCM_DEPRECATED void scm_remember (SCM * ptr);
-
-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_DEPRECATED SCM scm_close_all_ports_except (SCM ports);
-
-#define scm_rstate scm_t_rstate
-#define scm_rng scm_t_rng
-
-#define SCM_SLOPPY_CONSP(x) ((1 & SCM_CELL_TYPE (x)) == 0)
-#define SCM_SLOPPY_NCONSP(x) (!SCM_SLOPPY_CONSP(x))
-
-#define scm_tc7_ssymbol scm_tc7_symbol
-#define scm_tc7_msymbol scm_tc7_symbol
-#define scm_tcs_symbols scm_tc7_symbol
-
-SCM_DEPRECATED SCM scm_makstr (size_t len, int);
-SCM_DEPRECATED SCM scm_makfromstr (const char *src, size_t len, int);
-
-SCM_DEPRECATED SCM scm_variable_set_name_hint (SCM var, SCM hint);
-SCM_DEPRECATED SCM scm_builtin_variable (SCM name);
-
-SCM_DEPRECATED SCM scm_internal_with_fluids (SCM fluids, SCM vals,
- SCM (*cproc)(void *),
- void *cdata);
-
-SCM_DEPRECATED SCM scm_make_gsubr (const char *name,
- int req, int opt, int rst,
- scm_t_subr fcn);
-SCM_DEPRECATED SCM scm_make_gsubr_with_generic (const char *name,
- int req,
- int opt,
- int rst,
- scm_t_subr fcn,
- SCM *gf);
-
-SCM_DEPRECATED SCM scm_create_hook (const char* name, int n_args);
-
-
-/* Deprecated 13-05-2011 because it's better just to scm_dynwind_begin.
- That also avoids the temptation to stuff pointers in an SCM. */
-
-typedef SCM (*scm_t_inner) (void *);
-SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before,
- scm_t_inner inner,
- scm_t_guard after,
- void *inner_data,
- void *guard_data);
-
-#define SCM_LIST0 SCM_EOL
-#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)
-#define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL)
-#define SCM_LIST3(e0, e1, e2) scm_cons ((e0), SCM_LIST2 ((e1), (e2)))
-#define SCM_LIST4(e0, e1, e2, e3)\
- scm_cons2 ((e0), (e1), SCM_LIST2 ((e2), (e3)))
-#define SCM_LIST5(e0, e1, e2, e3, e4)\
- scm_cons ((e0), SCM_LIST4 ((e1), (e2), (e3), (e4)))
-#define SCM_LIST6(e0, e1, e2, e3, e4, e5)\
- scm_cons2 ((e0), (e1), SCM_LIST4 ((e2), (e3), (e4), (e5)))
-#define SCM_LIST7(e0, e1, e2, e3, e4, e5, e6)\
- scm_cons ((e0), SCM_LIST6 ((e1), (e2), (e3), (e4), (e5), (e6)))
-#define SCM_LIST8(e0, e1, e2, e3, e4, e5, e6, e7)\
- scm_cons2 ((e0), (e1), SCM_LIST6 ((e2), (e3), (e4), (e5), (e6), (e7)))
-#define SCM_LIST9(e0, e1, e2, e3, e4, e5, e6, e7, e8)\
- scm_cons ((e0),\
- SCM_LIST8 ((e1), (e2), (e3), (e4), (e5), (e6), (e7), (e8)))
-
-#define scm_listify scm_list_n
-
-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_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_DEPRECATED SCM scm_call_catching_errors (scm_t_subr thunk,
- scm_t_subr 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_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_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_DEPRECATED SCM scm_intern_obarray (const char *name, size_t len, SCM obarray);
-SCM_DEPRECATED SCM scm_symbol_value0 (const char *name);
-
-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_DEPRECATED SCM scm_symbol_interned_p (SCM o, SCM s);
-#endif
-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_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_array scm_t_array
-#define scm_array_dim scm_t_array_dim
-#define SCM_FUNC_NAME (scm_makfrom0str (FUNC_NAME))
-
-#define SCM_WTA(pos, scm) \
- do { scm_wta (scm, (char *) pos, FUNC_NAME); } while (0)
-
-#define RETURN_SCM_WTA(pos, scm) \
- do { return scm_wta (scm, (char *) pos, FUNC_NAME); } while (0)
-
-#define SCM_VALIDATE_NUMBER_COPY(pos, z, cvar) \
- do { \
- if (SCM_I_INUMP (z)) \
- cvar = (double) SCM_I_INUM (z); \
- else if (SCM_REALP (z)) \
- cvar = SCM_REAL_VALUE (z); \
- else if (SCM_BIGP (z)) \
- cvar = scm_i_big2dbl (z); \
- else \
- { \
- cvar = 0.0; \
- SCM_WRONG_TYPE_ARG (pos, z); \
- } \
- } while (0)
-
-#define SCM_VALIDATE_NUMBER_DEF_COPY(pos, number, def, cvar) \
- do { \
- if (SCM_UNBNDP (number)) \
- cvar = def; \
- else \
- SCM_VALIDATE_NUMBER_COPY(pos, number, cvar); \
- } while (0)
-
-#define SCM_VALIDATE_OPDIR(pos, port) SCM_MAKE_VALIDATE (pos, port, OPDIRP)
-
-/* Deprecated because we can not safely cast a SCM* to a scm_t_bits*
- */
-
-#define SCM_CELL_WORD_LOC(x, n) ((scm_t_bits*)SCM_CELL_OBJECT_LOC((x),(n)))
-
-/* Users shouldn't know about INUMs.
- */
-
-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)
-#define SCM_INUMP(x) scm_i_inump(x)
-#define SCM_NINUMP(x) (!SCM_INUMP(x))
-
-#define SCM_VALIDATE_INUM(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, INUMP, "exact integer")
-
-#define SCM_VALIDATE_INUM_COPY(pos, k, cvar) \
- do { \
- SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
- cvar = SCM_I_INUM (k); \
- } while (0)
-
-#define SCM_VALIDATE_BIGINT(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, BIGP, "bignum")
-
-#define SCM_VALIDATE_INUM_MIN(pos, k, min) \
- do { \
- SCM_ASSERT (SCM_I_INUMP(k), k, pos, FUNC_NAME); \
- SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \
- } while (0)
-
-#define SCM_VALIDATE_INUM_MIN_COPY(pos, k, min, cvar) \
- do { \
- SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
- SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \
- cvar = SCM_INUM (k); \
- } while (0)
-
-#define SCM_VALIDATE_INUM_MIN_DEF_COPY(pos, k, min, default, cvar) \
- do { \
- if (SCM_UNBNDP (k)) \
- k = SCM_I_MAKINUM (default); \
- SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
- SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \
- cvar = SCM_INUM (k); \
- } while (0)
-
-#define SCM_VALIDATE_INUM_DEF(pos, k, default) \
- do { \
- if (SCM_UNBNDP (k)) \
- k = SCM_I_MAKINUM (default); \
- else SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
- } while (0)
-
-#define SCM_VALIDATE_INUM_DEF_COPY(pos, k, default, cvar) \
- do { \
- if (SCM_UNBNDP (k)) \
- { \
- k = SCM_I_MAKINUM (default); \
- cvar = default; \
- } \
- else \
- { \
- SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
- cvar = SCM_INUM (k); \
- } \
- } while (0)
-
-/* [low, high) */
-#define SCM_VALIDATE_INUM_RANGE(pos, k, low, high) \
- do { SCM_ASSERT(SCM_I_INUMP(k), k, pos, FUNC_NAME); \
- SCM_ASSERT_RANGE(pos, k, \
- (SCM_I_INUM (k) >= low && \
- SCM_I_INUM (k) < high)); \
- } while (0)
-
-#define SCM_VALIDATE_INUM_RANGE_COPY(pos, k, low, high, cvar) \
- do { \
- SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \
- SCM_ASSERT_RANGE (pos, k, low <= SCM_INUM (k) && SCM_INUM (k) < high); \
- cvar = SCM_INUM (k); \
- } while (0)
-
-#define SCM_STRING_COERCE_0TERMINATION_X(x) (x)
-
-/* XXX - buggy interface, STR might not be large enough.
-
- Converts the given Scheme string OBJ into a C string, containing a copy
- of OBJ's content with a trailing null byte. If LENP is non-NULL, set
- *LENP to the string's length.
-
- When STR is non-NULL it receives the copy and is returned by the function,
- otherwise new memory is allocated and the caller is responsible for
- freeing it via free(). If out of memory, NULL is returned.
-
- Note that Scheme strings may contain arbitrary data, including null
- characters. This means that null termination is not a reliable way to
- determine the length of the returned value. However, the function always
- copies the complete contents of OBJ, and sets *LENP to the length of the
- scheme string (if LENP is non-null).
-*/
-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.
-
- Copy LEN characters at START from the Scheme string OBJ to memory
- at STR. START is an index into OBJ; zero means the beginning of
- the string. STR has already been allocated by the caller.
-
- If START + LEN is off the end of OBJ, silently truncate the source
- region to fit the string. If truncation occurs, the corresponding
- area of STR is left unchanged.
-*/
-SCM_DEPRECATED char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len);
-
-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_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_DEPRECATED double scm_asinh (double x);
-SCM_DEPRECATED double scm_acosh (double x);
-SCM_DEPRECATED double scm_atanh (double x);
-SCM_DEPRECATED SCM scm_sys_atan2 (SCM z1, SCM z2);
-
-/* Deprecated because we don't want people to access the internal
- representation of strings directly.
-*/
-
-#define SCM_VALIDATE_STRING_COPY(pos, str, cvar) \
- do { \
- SCM_ASSERT (SCM_STRINGP (str), str, pos, FUNC_NAME); \
- cvar = SCM_STRING_CHARS(str); \
- } while (0)
-
-/* validate a string and optional start/end arguments which default to
- 0/string-len. this is unrelated to the old shared substring
- support, so please do not deprecate it :) */
-#define SCM_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
- pos_start, start, c_start,\
- pos_end, end, c_end) \
- do {\
- SCM_VALIDATE_STRING_COPY (pos_str, str, c_str);\
- c_start = SCM_UNBNDP(start)? 0 : scm_to_size_t (start);\
- c_end = SCM_UNBNDP(end)? SCM_STRING_LENGTH(str) : scm_to_size_t (end);\
- SCM_ASSERT_RANGE (pos_start, start,\
- 0 <= c_start \
- && (size_t) c_start <= SCM_STRING_LENGTH (str));\
- SCM_ASSERT_RANGE (pos_end, end,\
- c_start <= c_end \
- && (size_t) c_end <= SCM_STRING_LENGTH (str));\
- } while (0)
-
-/* Deprecated because we don't want people to access the internals of
- symbols directly.
-*/
-
-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)
-
-/* Deprecated because the macros used to evaluate the arguments more
- than once and because the symbol of a keyword now has no dash.
-*/
-
-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)
-
-/* Deprecated because we don't want to hand out unprotected pointers
- to arrays, vectors, etc. */
-
-#define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1)
-
-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)
-#define SCM_VELTS(x) scm_i_velts(x)
-#define SCM_WRITABLE_VELTS(x) scm_i_writable_velts(x)
-#define SCM_VECTOR_REF(x,y) scm_i_vector_ref(x,y)
-#define SCM_VECTOR_SET(x,y,z) scm_i_vector_set(x,y,z)
-
-typedef scm_i_t_array scm_t_array;
-
-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_ARRAY_CONTP(a) scm_i_array_contp(a)
-#define SCM_ARRAY_MEM(a) scm_i_array_mem(a)
-#define SCM_ARRAY_V(a) scm_i_array_v(a)
-#define SCM_ARRAY_BASE(a) scm_i_array_base(a)
-#define SCM_ARRAY_DIMS(a) scm_i_array_dims(a)
-
-SCM_DEPRECATED SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd,
- SCM start, SCM end);
-SCM_DEPRECATED SCM scm_uniform_vector_write (SCM v, SCM port_or_fd,
- SCM start, SCM end);
-SCM_DEPRECATED SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
- SCM start, SCM end);
-SCM_DEPRECATED SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
- SCM start, SCM end);
-
-/* Deprecated because they should not be lvalues and we want people to
- use the official interfaces.
- */
-
-#define scm_cur_inp scm_i_cur_inp ()
-#define scm_cur_outp scm_i_cur_outp ()
-#define scm_cur_errp scm_i_cur_errp ()
-#define scm_cur_loadp scm_i_cur_loadp ()
-#define scm_progargs scm_i_progargs ()
-#define scm_dynwinds scm_i_deprecated_dynwinds ()
-#define scm_stack_base scm_i_stack_base ()
-
-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_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
- code, and that had to be avoided when the heap was not in a
- consistent state etc. And since the scheme code could do a stack
- swapping new continuation etc, signals had to be deferred around
- various C library functions which were not safe or not known to be
- safe to swap away, which was a lot of stuff.
-
- These days signals are implemented with asyncs and don't directly
- run scheme code in the handler, but hold it until an SCM_TICK etc
- where it will be safe. This means interrupt protection is not
- needed and SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END is
- something of an anachronism.
-
- What past SCM_CRITICAL_SECTION_START usage also did though was
- indicate code that was not reentrant, ie. could not be reentered by
- signal handler code. The present definitions are a mutex lock,
- affording that reentrancy protection against the new guile 1.8
- free-running posix threads.
-
- One big problem with the present defintions though is that code which
- throws an error from within a DEFER/ALLOW region will leave the
- defer_mutex locked and hence hang other threads that attempt to enter a
- similar DEFER/ALLOW region.
-*/
-
-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_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_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
-
-/* Deprecated 2010-01-05, use SCM_PRIMITIVE_P instead */
-SCM_DEPRECATED int scm_i_subr_p (SCM x);
-#define scm_subr_p(x) (scm_i_subr_p (x))
-
-\f
-
-/* Deprecated 2010-01-31, use with-throw-handler instead */
-SCM_DEPRECATED SCM scm_lazy_catch (SCM tag, SCM thunk, SCM handler);
-SCM_DEPRECATED SCM scm_internal_lazy_catch (SCM tag,
- scm_t_catch_body body,
- void *body_data,
- scm_t_catch_handler handler,
- void *handler_data);
-
-\f
-
-/* Deprecated 2010-03-31, use array-equal? instead */
-SCM_DEPRECATED SCM scm_raequal (SCM ra0, SCM ra1);
-
-/* Deprecated 2010-04-01, use the dynamic FFI instead */
-SCM_DEPRECATED SCM scm_dynamic_args_call (SCM symb, SCM dobj, SCM args);
-
-/* Deprecated 2010-05-12, no replacement */
-SCM_DEPRECATED int scm_badargsp (SCM formals, SCM args);
-
-/* Deprecated 2010-06-19, use call-with-error-handling instead */
-SCM_DEPRECATED SCM scm_internal_stack_catch (SCM tag,
- scm_t_catch_body body,
- void *body_data,
- scm_t_catch_handler handler,
- void *handler_data);
-
-\f
-
-/* These functions were "discouraged" in 1.8, and now are deprecated. */
-
-/* scm_to_int, scm_from_int are the official functions to do the job,
- but there is nothing wrong with using scm_num2int, etc.
-
- These could be trivially defined via macros, but we leave them as
- functions since existing code may take their addresses.
-*/
-
-SCM_DEPRECATED SCM scm_short2num (short n);
-SCM_DEPRECATED SCM scm_ushort2num (unsigned short n);
-SCM_DEPRECATED SCM scm_int2num (int n);
-SCM_DEPRECATED SCM scm_uint2num (unsigned int n);
-SCM_DEPRECATED SCM scm_long2num (long n);
-SCM_DEPRECATED SCM scm_ulong2num (unsigned long n);
-SCM_DEPRECATED SCM scm_size2num (size_t n);
-SCM_DEPRECATED SCM scm_ptrdiff2num (scm_t_ptrdiff n);
-SCM_DEPRECATED short scm_num2short (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED unsigned short scm_num2ushort (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED int scm_num2int (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED unsigned int scm_num2uint (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED long scm_num2long (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED unsigned long scm_num2ulong (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED scm_t_ptrdiff scm_num2ptrdiff (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED size_t scm_num2size (SCM num, unsigned long int pos,
- const char *s_caller);
-#if SCM_SIZEOF_LONG_LONG != 0
-SCM_DEPRECATED SCM scm_long_long2num (long long sl);
-SCM_DEPRECATED SCM scm_ulong_long2num (unsigned long long sl);
-SCM_DEPRECATED long long scm_num2long_long (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED unsigned long long scm_num2ulong_long (SCM num, unsigned long int pos,
- const char *s_caller);
-#endif
-
-SCM_DEPRECATED SCM scm_make_real (double x);
-SCM_DEPRECATED double scm_num2dbl (SCM a, const char * why);
-SCM_DEPRECATED SCM scm_float2num (float n);
-SCM_DEPRECATED SCM scm_double2num (double n);
-
-/* The next two are implemented in numbers.c since they use features
- only available there.
-*/
-SCM_DEPRECATED float scm_num2float (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED double scm_num2double (SCM num, unsigned long int pos,
- const char *s_caller);
-
-SCM_DEPRECATED SCM scm_make_complex (double x, double y);
-
-/* Discouraged because they don't make the encoding explicit.
- */
-
-SCM_DEPRECATED SCM scm_mem2symbol (const char *mem, size_t len);
-SCM_DEPRECATED SCM scm_mem2uninterned_symbol (const char *mem, size_t len);
-SCM_DEPRECATED SCM scm_str2symbol (const char *str);
-
-SCM_DEPRECATED SCM scm_take_str (char *s, size_t len);
-SCM_DEPRECATED SCM scm_take0str (char *s);
-SCM_DEPRECATED SCM scm_mem2string (const char *src, size_t len);
-SCM_DEPRECATED SCM scm_str2string (const char *src);
-SCM_DEPRECATED SCM scm_makfrom0str (const char *src);
-SCM_DEPRECATED SCM scm_makfrom0str_opt (const char *src);
-
-/* Discouraged because scm_c_make_string has a better name and is more
- consistent with make-string.
- */
-SCM_DEPRECATED SCM scm_allocate_string (size_t len);
-
-/* Discouraged because they are just strange.
- */
-
-SCM_DEPRECATED SCM scm_make_keyword_from_dash_symbol (SCM symbol);
-SCM_DEPRECATED SCM scm_keyword_dash_symbol (SCM keyword);
-
-/* Discouraged because it does not state what encoding S is in.
- */
-
-SCM_DEPRECATED SCM scm_c_make_keyword (const char *s);
-
-SCM_DEPRECATED unsigned int scm_thread_sleep (unsigned int);
-SCM_DEPRECATED unsigned long scm_thread_usleep (unsigned long);
-SCM_DEPRECATED int scm_internal_select (int fds,
- fd_set *rfds,
- fd_set *wfds,
- fd_set *efds,
- struct timeval *timeout);
-\f
-/* Deprecated because the cuserid call is deprecated.
- */
-SCM_DEPRECATED SCM scm_cuserid (void);
-
-\f
-
-/* Deprecated because it's yet another property interface.
- */
-SCM_DEPRECATED SCM scm_primitive_make_property (SCM not_found_proc);
-SCM_DEPRECATED SCM scm_primitive_property_ref (SCM prop, SCM obj);
-SCM_DEPRECATED SCM scm_primitive_property_set_x (SCM prop, SCM obj, SCM val);
-SCM_DEPRECATED SCM scm_primitive_property_del_x (SCM prop, SCM obj);
-
-\f
-
-/* {The old whash table interface}
- * Deprecated, as the hash table interface is sufficient, and accessing
- * handles of weak hash tables is no longer supported.
- */
-
-#define scm_whash_handle SCM
-
-SCM_DEPRECATED SCM scm_whash_get_handle (SCM whash, SCM key);
-SCM_DEPRECATED int SCM_WHASHFOUNDP (SCM h);
-SCM_DEPRECATED SCM SCM_WHASHREF (SCM whash, SCM handle);
-SCM_DEPRECATED void SCM_WHASHSET (SCM whash, SCM handle, SCM obj);
-SCM_DEPRECATED SCM scm_whash_create_handle (SCM whash, SCM key);
-SCM_DEPRECATED SCM scm_whash_lookup (SCM whash, SCM obj);
-SCM_DEPRECATED void scm_whash_insert (SCM whash, SCM key, SCM obj);
-
-
-\f
-
-/* No need for a table for names, and the struct->class mapping is
- maintained by GOOPS now. */
-#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_DEPRECATED SCM scm_struct_table;
-SCM_DEPRECATED SCM scm_struct_create_handle (SCM obj);
-
-
-\f
-
-/* Deprecated 26-05-2011, as the GC_STUBBORN API doesn't do anything any
- more. */
-SCM_DEPRECATED SCM scm_immutable_cell (scm_t_bits car, scm_t_bits cdr);
-SCM_DEPRECATED SCM scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
- scm_t_bits ccr, scm_t_bits cdr);
-
-\f
-
-SCM_DEPRECATED scm_t_bits scm_i_deprecated_asrtgo (scm_t_bits condition);
-
-/* Deprecated 08-01-2012, as it's undocumented and unused. */
-#define SCM_ASRTGO(_cond, _label) \
- do { if (!scm_i_deprecated_asrtgo(_cond)) goto _label; } while (0)
-
-\f
-
-/* Deprecated 23-05-2012, as as it's undocumented, poorly named, and
- adequately replaced by scm_module_variable /
- scm_ensure_module_variable / scm_define / scm_module_define. */
-SCM_DEPRECATED SCM scm_sym2var (SCM sym, SCM thunk, SCM definep);
-
-\f
-
-/* Eval closure deprecation, 23-05-2012. */
-#define SCM_TOP_LEVEL_LOOKUP_CLOSURE (scm_current_module_lookup_closure())
-
-SCM_DEPRECATED SCM scm_lookup_closure_module (SCM proc);
-SCM_DEPRECATED SCM scm_module_lookup_closure (SCM module);
-SCM_DEPRECATED SCM scm_current_module_lookup_closure (void);
-
-SCM_DEPRECATED scm_t_bits scm_tc16_eval_closure;
-
-#define SCM_EVAL_CLOSURE_P(x) SCM_TYP16_PREDICATE (scm_tc16_eval_closure, x)
-
-SCM_DEPRECATED SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep);
-SCM_DEPRECATED SCM scm_standard_eval_closure (SCM module);
-SCM_DEPRECATED SCM scm_standard_interface_eval_closure (SCM module);
-SCM_DEPRECATED SCM scm_eval_closure_module (SCM eval_closure);
-
-\f
-
-SCM_DEPRECATED SCM scm_struct_vtable_tag (SCM handle);
-
-\f
-
-#ifdef UCHAR_MAX
-# define SCM_CHAR_CODE_LIMIT (UCHAR_MAX + 1L)
-#else
-# define SCM_CHAR_CODE_LIMIT 256L
-#endif
-
-\f
-
-SCM_DEPRECATED SCM scm_generalized_vector_p (SCM v);
-SCM_DEPRECATED SCM scm_generalized_vector_length (SCM v);
-SCM_DEPRECATED SCM scm_generalized_vector_ref (SCM v, SCM idx);
-SCM_DEPRECATED SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val);
-SCM_DEPRECATED SCM scm_generalized_vector_to_list (SCM v);
-
-\f
-
-SCM_DEPRECATED SCM scm_c_program_source (SCM program, size_t ip);
-
-\f
-
-SCM_DEPRECATED SCM scm_gc_live_object_stats (void);
-
-\f
-
-SCM_DEPRECATED SCM scm_htons (SCM in);
-SCM_DEPRECATED SCM scm_ntohs (SCM in);
-SCM_DEPRECATED SCM scm_htonl (SCM in);
-SCM_DEPRECATED SCM scm_ntohl (SCM in);
-
-\f
-
-void scm_i_init_deprecated (void);
-
-#endif
-
-#endif /* SCM_DEPRECATED_H */
+/* This file contains definitions for deprecated features. When you
+ deprecate something, move it here when that is feasible.
+*/
+
+#ifndef SCM_DEPRECATED_H
+#define SCM_DEPRECATED_H
+
+/* Copyright (C) 2003,2004, 2005, 2006, 2007, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#include "libguile/__scm.h"
+#include "libguile/strings.h"
+#include "libguile/eval.h"
+#include "libguile/throw.h"
+#include "libguile/iselect.h"
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+/* Deprecated 13-05-2011 because it's better just to scm_dynwind_begin.
+ That also avoids the temptation to stuff pointers in an SCM. */
+
+typedef SCM (*scm_t_inner) (void *);
+SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before,
+ scm_t_inner inner,
+ scm_t_guard after,
+ void *inner_data,
+ void *guard_data);
+
+
+/* Deprecated 15-05-2011 because it's better to be explicit with the
+ `return'. Code is more readable that way. */
+#define SCM_WTA_DISPATCH_0(gf, subr) \
+ return scm_wta_dispatch_0 ((gf), (subr))
+#define SCM_WTA_DISPATCH_1(gf, a1, pos, subr) \
+ return scm_wta_dispatch_1 ((gf), (a1), (pos), (subr))
+#define SCM_WTA_DISPATCH_2(gf, a1, a2, pos, subr) \
+ return scm_wta_dispatch_2 ((gf), (a1), (a2), (pos), (subr))
+#define SCM_WTA_DISPATCH_N(gf, args, pos, subr) \
+ return scm_wta_dispatch_n ((gf), (args), (pos), (subr))
+
+/* Deprecated 15-05-2011 because this idiom is not very readable. */
+#define SCM_GASSERT0(cond, gf, subr) \
+ if (SCM_UNLIKELY (!(cond))) \
+ return scm_wta_dispatch_0 ((gf), (subr))
+#define SCM_GASSERT1(cond, gf, a1, pos, subr) \
+ if (SCM_UNLIKELY (!(cond))) \
+ return scm_wta_dispatch_1 ((gf), (a1), (pos), (subr))
+#define SCM_GASSERT2(cond, gf, a1, a2, pos, subr) \
+ if (SCM_UNLIKELY (!(cond))) \
+ return scm_wta_dispatch_2 ((gf), (a1), (a2), (pos), (subr))
+#define SCM_GASSERTn(cond, gf, args, pos, subr) \
+ if (SCM_UNLIKELY (!(cond))) \
+ return scm_wta_dispatch_n ((gf), (args), (pos), (subr))
+
+/* Deprecated 15-05-2011 because this is a one-off macro that does
+ strange things. */
+#define SCM_WTA_DISPATCH_1_SUBR(subr, a1, pos) \
+ return (SCM_UNPACK ((*SCM_SUBR_GENERIC (subr))) \
+ ? scm_call_1 ((*SCM_SUBR_GENERIC (subr)), (a1)) \
+ : (scm_i_wrong_type_arg_symbol (SCM_SUBR_NAME (subr), (pos), (a1)), SCM_UNSPECIFIED))
+
+#define SCM_LIST0 SCM_EOL
+#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)
+#define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL)
+#define SCM_LIST3(e0, e1, e2) scm_cons ((e0), SCM_LIST2 ((e1), (e2)))
+#define SCM_LIST4(e0, e1, e2, e3)\
+ scm_cons2 ((e0), (e1), SCM_LIST2 ((e2), (e3)))
+#define SCM_LIST5(e0, e1, e2, e3, e4)\
+ scm_cons ((e0), SCM_LIST4 ((e1), (e2), (e3), (e4)))
+#define SCM_LIST6(e0, e1, e2, e3, e4, e5)\
+ scm_cons2 ((e0), (e1), SCM_LIST4 ((e2), (e3), (e4), (e5)))
+#define SCM_LIST7(e0, e1, e2, e3, e4, e5, e6)\
+ scm_cons ((e0), SCM_LIST6 ((e1), (e2), (e3), (e4), (e5), (e6)))
+#define SCM_LIST8(e0, e1, e2, e3, e4, e5, e6, e7)\
+ scm_cons2 ((e0), (e1), SCM_LIST6 ((e2), (e3), (e4), (e5), (e6), (e7)))
+#define SCM_LIST9(e0, e1, e2, e3, e4, e5, e6, e7, e8)\
+ scm_cons ((e0),\
+ SCM_LIST8 ((e1), (e2), (e3), (e4), (e5), (e6), (e7), (e8)))
+
+#define SCM_CHAR_CODE_LIMIT SCM_CHAR_CODE_LIMIT__GONE__REPLACE_WITH__256L
+#define SCM_OPDIRP SCM_OPDIRP__GONE__REPLACE_WITH__SCM_DIRP_and_SCM_DIR_OPEN_P
+#define SCM_PROCEDURE SCM_PROCEDURE__GONE__REPLACE_WITH__scm_procedure
+#define SCM_PROCEDURE_WITH_SETTER_P SCM_PROCEDURE_WITH_SETTER_P__GONE__REPLACE_WITH__scm_is_true__scm_procedure_with_setter_p
+#define SCM_SETTER SCM_SETTER__GONE__REPLACE_WITH__scm_setter
+#define SCM_THREAD_SWITCHING_CODE SCM_THREAD_SWITCHING_CODE__GONE__REMOVE_FROM_YOUR_CODE
+#define SCM_VALIDATE_NUMBER_COPY SCM_VALIDATE_NUMBER_COPY__GONE__REPLACE_WITH__SCM_VALIDATE_DOUBLE_COPY
+#define SCM_VALIDATE_NUMBER_DEF_COPY SCM_VALIDATE_NUMBER_DEF_COPY__GONE__REPLACE_WITH__SCM_UNBNDP_and_SCM_VALIDATE_DOUBLE_COPY
+#define SCM_VALIDATE_OPDIR SCM_VALIDATE_OPDIR__GONE
+#define SCM_VALIDATE_STRING_COPY SCM_VALIDATE_STRING_COPY__GONE
+#define SCM_VALIDATE_SUBSTRING_SPEC_COPY SCM_VALIDATE_SUBSTRING_SPEC_COPY__GONE
+#define scm_array scm_array__GONE__REPLACE_WITH__scm_t_array
+#define scm_array_dim scm_array_dim__GONE__REPLACE_WITH__scm_t_array_dim
+#define scm_async_click scm_async_click__GONE__REPLACE_WITH__scm_async_tick
+#define scm_call_generic_0 scm_call_generic_0__GONE__REPLACE_WITH__scm_call_0
+#define scm_call_generic_1 scm_call_generic_1__GONE__REPLACE_WITH__scm_call_1
+#define scm_call_generic_2 scm_call_generic_2__GONE__REPLACE_WITH__scm_call_2
+#define scm_call_generic_3 scm_call_generic_3__GONE__REPLACE_WITH__scm_call_3
+#define scm_apply_generic scm_apply_generic__GONE__REPLACE_WITH__scm_apply_0
+#define scm_fport scm_fport__GONE__REPLACE_WITH__scm_t_fport
+#define scm_listify scm_listify__GONE__REPLACE_WITH__scm_list_n
+#define scm_option scm_option__GONE__REPLACE_WITH__scm_t_option
+#define scm_port scm_port__GONE__REPLACE_WITH__scm_t_port
+#define scm_port_rw_active scm_port_rw_active__GONE__REPLACE_WITH__scm_t_port_rw_active
+#define scm_ptob_descriptor scm_ptob_descriptor__GONE__REPLACE_WITH__scm_t_ptob_descriptor
+#define scm_rng scm_rng__GONE__REPLACE_WITH__scm_t_rng
+#define scm_rstate scm_rstate__GONE__REPLACE_WITH__scm_t_rstate
+#define scm_sizet scm_sizet__GONE__REPLACE_WITH__size_t
+#define scm_srcprops scm_srcprops__GONE__REPLACE_WITH__scm_t_srcprops
+#define scm_srcprops_chunk scm_srcprops_chunk__GONE__REPLACE_WITH__scm_t_srcprops_chunk
+#define scm_struct_i_flags scm_struct_i_flags__GONE__REPLACE_WITH__scm_vtable_index_flags
+#define scm_struct_i_free scm_struct_i_free__GONE__REPLACE_WITH__scm_vtable_index_instance_finalize
+#define scm_subr_entry scm_subr_entry__GONE__REPLACE_WITH__scm_t_subr_entry
+#define scm_substring_move_left_x scm_substring_move_left_x__GONE__REPLACE_WITH__scm_substring_move_x
+#define scm_substring_move_right_x scm_substring_move_right_x__GONE__REPLACE_WITH__scm_substring_move_x
+#define scm_vtable_index_printer scm_vtable_index_printer__GONE__REPLACE_WITH__scm_vtable_index_instance_printer
+#define scm_vtable_index_vtable scm_vtable_index_vtable__GONE__REPLACE_WITH__scm_vtable_index_self
+
+#ifndef BUILDING_LIBGUILE
+#define SCM_ASYNC_TICK SCM_ASYNC_TICK__GONE__REPLACE_WITH__scm_async_tick
+#endif
+
+
+\f
+
+/* Deprecated 26-05-2011, as the GC_STUBBORN API doesn't do anything any
+ more. */
+SCM_DEPRECATED SCM scm_immutable_cell (scm_t_bits car, scm_t_bits cdr);
+SCM_DEPRECATED SCM scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr);
+
+\f
+
+SCM_DEPRECATED SCM scm_memory_alloc_key;
+SCM_DEPRECATED void scm_memory_error (const char *subr) SCM_NORETURN;
+
+\f
+
+void scm_i_init_deprecated (void);
+
+#endif
+
+#endif /* SCM_DEPRECATED_H */
fprintf (stderr, "%s\n", msg);
else
{
- scm_puts (msg, scm_current_warning_port ());
+ scm_puts_unlocked (msg, scm_current_warning_port ());
scm_newline (scm_current_warning_port ());
}
}
static int
dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<dynamic-object ", port);
+ scm_puts_unlocked ("#<dynamic-object ", port);
scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
if (DYNL_HANDLE (exp) == NULL)
- scm_puts (" (unlinked)", port);
- scm_putc ('>', port);
+ scm_puts_unlocked (" (unlinked)", port);
+ scm_putc_unlocked ('>', port);
return 1;
}
--- /dev/null
+/* Copyright (C) 2012, 2013 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 <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/control.h"
+#include "libguile/eval.h"
+#include "libguile/fluids.h"
+#include "libguile/dynstack.h"
+
+
+\f
+
+#define PROMPT_WORDS 5
+#define PROMPT_KEY(top) (SCM_PACK ((top)[0]))
+#define PROMPT_FP(top) ((scm_t_ptrdiff) ((top)[1]))
+#define PROMPT_SP(top) ((scm_t_ptrdiff) ((top)[2]))
+#define PROMPT_IP(top) ((scm_t_uint32 *) ((top)[3]))
+#define PROMPT_JMPBUF(top) ((scm_i_jmp_buf *) ((top)[4]))
+
+#define WINDER_WORDS 2
+#define WINDER_PROC(top) ((scm_t_guard) ((top)[0]))
+#define WINDER_DATA(top) ((void *) ((top)[1]))
+
+#define DYNWIND_WORDS 2
+#define DYNWIND_ENTER(top) (SCM_PACK ((top)[0]))
+#define DYNWIND_LEAVE(top) (SCM_PACK ((top)[1]))
+
+#define WITH_FLUID_WORDS 2
+#define WITH_FLUID_FLUID(top) (SCM_PACK ((top)[0]))
+#define WITH_FLUID_VALUE_BOX(top) (SCM_PACK ((top)[1]))
+
+
+\f
+
+static void
+copy_scm_t_bits (scm_t_bits *dst, scm_t_bits *src, size_t n)
+{
+ size_t i;
+
+ for (i = 0; i < n; i++)
+ dst[i] = src[i];
+}
+
+static void
+clear_scm_t_bits (scm_t_bits *items, size_t n)
+{
+ size_t i;
+
+ for (i = 0; i < n; i++)
+ items[i] = 0;
+}
+
+/* Ensure space for N additional words. */
+static void
+dynstack_ensure_space (scm_t_dynstack *dynstack, size_t n)
+{
+ size_t capacity = SCM_DYNSTACK_CAPACITY (dynstack);
+ size_t height = SCM_DYNSTACK_HEIGHT (dynstack);
+
+ n += SCM_DYNSTACK_HEADER_LEN;
+
+ if (capacity < height + n)
+ {
+ scm_t_bits *new_base;
+
+ while (capacity < height + n)
+ capacity = (capacity < 4) ? 8 : (capacity * 2);
+
+ new_base = scm_gc_malloc (capacity * sizeof(scm_t_bits), "dynstack");
+
+ copy_scm_t_bits (new_base, dynstack->base, height);
+ clear_scm_t_bits (dynstack->base, height);
+
+ dynstack->base = new_base;
+ dynstack->top = new_base + height;
+ dynstack->limit = new_base + capacity;
+ }
+}
+
+static inline scm_t_bits *
+push_dynstack_entry_unchecked (scm_t_dynstack *dynstack,
+ scm_t_dynstack_item_type type,
+ scm_t_bits flags, size_t len)
+{
+ scm_t_bits *ret = dynstack->top;
+
+ SCM_DYNSTACK_SET_TAG (dynstack->top, SCM_MAKE_DYNSTACK_TAG (type, flags, len));
+ dynstack->top += SCM_DYNSTACK_HEADER_LEN + len;
+ SCM_DYNSTACK_SET_PREV_OFFSET (dynstack->top, SCM_DYNSTACK_HEADER_LEN + len);
+
+ return ret;
+}
+
+static inline scm_t_bits *
+push_dynstack_entry (scm_t_dynstack *dynstack,
+ scm_t_dynstack_item_type type,
+ scm_t_bits flags, size_t len)
+{
+ if (SCM_UNLIKELY (!SCM_DYNSTACK_HAS_SPACE (dynstack, len)))
+ dynstack_ensure_space (dynstack, len);
+ return push_dynstack_entry_unchecked (dynstack, type, flags, len);
+}
+
+void
+scm_dynstack_push_frame (scm_t_dynstack *dynstack,
+ scm_t_dynstack_frame_flags flags)
+{
+ push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_FRAME, flags, 0);
+}
+
+void
+scm_dynstack_push_rewinder (scm_t_dynstack *dynstack,
+ scm_t_dynstack_winder_flags flags,
+ scm_t_guard proc, void *data)
+{
+ scm_t_bits *words;
+
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_REWINDER, flags,
+ WINDER_WORDS);
+ words[0] = (scm_t_bits) proc;
+ words[1] = (scm_t_bits) data;
+}
+
+void
+scm_dynstack_push_unwinder (scm_t_dynstack *dynstack,
+ scm_t_dynstack_winder_flags flags,
+ scm_t_guard proc, void *data)
+{
+ scm_t_bits *words;
+
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_UNWINDER, flags,
+ WINDER_WORDS);
+ words[0] = (scm_t_bits) proc;
+ words[1] = (scm_t_bits) data;
+}
+
+/* The fluid is stored on the stack, but the value has to be stored on the heap,
+ so that all continuations that capture this dynamic scope capture the same
+ binding. */
+void
+scm_dynstack_push_fluid (scm_t_dynstack *dynstack, SCM fluid, SCM value,
+ SCM dynamic_state)
+{
+ scm_t_bits *words;
+ SCM value_box;
+
+ if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)))
+ scm_wrong_type_arg ("with-fluid*", 0, fluid);
+
+ value_box = scm_make_variable (value);
+
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_WITH_FLUID, 0,
+ WITH_FLUID_WORDS);
+ words[0] = SCM_UNPACK (fluid);
+ words[1] = SCM_UNPACK (value_box);
+
+ /* Go ahead and swap them. */
+ scm_swap_fluid (fluid, value_box, dynamic_state);
+}
+
+void
+scm_dynstack_push_prompt (scm_t_dynstack *dynstack,
+ scm_t_dynstack_prompt_flags flags,
+ SCM key,
+ scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
+ scm_t_uint32 *ip, scm_i_jmp_buf *registers)
+{
+ scm_t_bits *words;
+
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_PROMPT, flags,
+ PROMPT_WORDS);
+ words[0] = SCM_UNPACK (key);
+ words[1] = (scm_t_bits) fp_offset;
+ words[2] = (scm_t_bits) sp_offset;
+ words[3] = (scm_t_bits) ip;
+ words[4] = (scm_t_bits) registers;
+}
+
+void
+scm_dynstack_push_dynwind (scm_t_dynstack *dynstack, SCM enter, SCM leave)
+{
+ scm_t_bits *words;
+
+ words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNWIND, 0,
+ DYNWIND_WORDS);
+ words[0] = SCM_UNPACK (enter);
+ words[1] = SCM_UNPACK (leave);
+}
+
+static inline scm_t_bits
+dynstack_pop (scm_t_dynstack *dynstack, scm_t_bits **words)
+{
+ scm_t_bits *prev = SCM_DYNSTACK_PREV (dynstack->top);
+ scm_t_bits tag;
+
+ if (SCM_UNLIKELY (!prev))
+ abort ();
+
+ SCM_DYNSTACK_SET_PREV_OFFSET (dynstack->top, 0);
+ dynstack->top = prev;
+
+ tag = SCM_DYNSTACK_TAG (dynstack->top);
+ SCM_DYNSTACK_SET_TAG (dynstack->top, 0);
+ *words = dynstack->top;
+
+ return tag;
+}
+
+void
+scm_dynstack_pop (scm_t_dynstack *dynstack)
+{
+ scm_t_bits tag, *words;
+ tag = dynstack_pop (dynstack, &words);
+ clear_scm_t_bits (words, SCM_DYNSTACK_TAG_LEN (tag));
+}
+
+scm_t_dynstack *
+scm_dynstack_capture_all (scm_t_dynstack *dynstack)
+{
+ return scm_dynstack_capture (dynstack, SCM_DYNSTACK_FIRST (dynstack));
+}
+
+scm_t_dynstack *
+scm_dynstack_capture (scm_t_dynstack *dynstack, scm_t_bits *item)
+{
+ char *mem;
+ scm_t_dynstack *ret;
+ size_t len;
+
+ assert (item >= SCM_DYNSTACK_FIRST (dynstack));
+ assert (item <= dynstack->top);
+
+ len = dynstack->top - item + SCM_DYNSTACK_HEADER_LEN;
+ mem = scm_gc_malloc (sizeof (*ret) + len * sizeof(scm_t_bits), "dynstack");
+ ret = (scm_t_dynstack *) mem;
+ ret->base = (scm_t_bits *) (mem + sizeof (*ret));
+ ret->limit = ret->base + len;
+ ret->top = ret->base + len;
+
+ copy_scm_t_bits (ret->base, item - SCM_DYNSTACK_HEADER_LEN, len);
+ SCM_DYNSTACK_SET_PREV_OFFSET (SCM_DYNSTACK_FIRST (ret), 0);
+
+ return ret;
+}
+
+void
+scm_dynstack_wind_1 (scm_t_dynstack *dynstack, scm_t_bits *item)
+{
+ scm_t_bits tag = SCM_DYNSTACK_TAG (item);
+ scm_t_dynstack_item_type type = SCM_DYNSTACK_TAG_TYPE (tag);
+ scm_t_bits flags = SCM_DYNSTACK_TAG_FLAGS (tag);
+ size_t len = SCM_DYNSTACK_TAG_LEN (tag);
+
+ switch (type)
+ {
+ case SCM_DYNSTACK_TYPE_FRAME:
+ if (!(flags & SCM_F_DYNSTACK_FRAME_REWINDABLE))
+ scm_misc_error ("scm_dynstack_wind_1",
+ "cannot invoke continuation from this context",
+ SCM_EOL);
+ break;
+
+ case SCM_DYNSTACK_TYPE_UNWINDER:
+ break;
+
+ case SCM_DYNSTACK_TYPE_REWINDER:
+ WINDER_PROC (item) (WINDER_DATA (item));
+ break;
+
+ case SCM_DYNSTACK_TYPE_WITH_FLUID:
+ scm_swap_fluid (WITH_FLUID_FLUID (item),
+ WITH_FLUID_VALUE_BOX (item),
+ SCM_I_CURRENT_THREAD->dynamic_state);
+ break;
+
+ case SCM_DYNSTACK_TYPE_PROMPT:
+ /* see vm_reinstate_partial_continuation */
+ break;
+
+ case SCM_DYNSTACK_TYPE_DYNWIND:
+ scm_call_0 (DYNWIND_ENTER (item));
+ break;
+
+ case SCM_DYNSTACK_TYPE_NONE:
+ default:
+ abort ();
+ }
+
+ {
+ scm_t_bits *words = push_dynstack_entry (dynstack, type, flags, len);
+
+ copy_scm_t_bits (words, item, len);
+ }
+}
+
+scm_t_bits
+scm_dynstack_unwind_1 (scm_t_dynstack *dynstack)
+{
+ scm_t_bits tag;
+ scm_t_bits *words;
+ scm_t_dynstack_item_type type;
+
+ tag = dynstack_pop (dynstack, &words);
+
+ type = SCM_DYNSTACK_TAG_TYPE (tag);
+
+ switch (type)
+ {
+ case SCM_DYNSTACK_TYPE_FRAME:
+ break;
+
+ case SCM_DYNSTACK_TYPE_UNWINDER:
+ WINDER_PROC (words) (WINDER_DATA (words));
+ clear_scm_t_bits (words, WINDER_WORDS);
+ break;
+
+ case SCM_DYNSTACK_TYPE_REWINDER:
+ clear_scm_t_bits (words, WINDER_WORDS);
+ break;
+
+ case SCM_DYNSTACK_TYPE_WITH_FLUID:
+ scm_swap_fluid (WITH_FLUID_FLUID (words),
+ WITH_FLUID_VALUE_BOX (words),
+ SCM_I_CURRENT_THREAD->dynamic_state);
+ clear_scm_t_bits (words, WITH_FLUID_WORDS);
+ break;
+
+ case SCM_DYNSTACK_TYPE_PROMPT:
+ /* we could invalidate the prompt */
+ clear_scm_t_bits (words, PROMPT_WORDS);
+ break;
+
+ case SCM_DYNSTACK_TYPE_DYNWIND:
+ {
+ SCM proc = DYNWIND_LEAVE (words);
+ clear_scm_t_bits (words, DYNWIND_WORDS);
+ scm_call_0 (proc);
+ }
+ break;
+
+ case SCM_DYNSTACK_TYPE_NONE:
+ default:
+ abort ();
+ }
+
+ return tag;
+}
+
+void
+scm_dynstack_wind (scm_t_dynstack *dynstack, scm_t_bits *item)
+{
+ for (; SCM_DYNSTACK_TAG (item); item = SCM_DYNSTACK_NEXT (item))
+ scm_dynstack_wind_1 (dynstack, item);
+}
+
+void
+scm_dynstack_unwind (scm_t_dynstack *dynstack, scm_t_bits *base)
+{
+ while (dynstack->top > base)
+ scm_dynstack_unwind_1 (dynstack);
+}
+
+static int
+same_entries (scm_t_bits *walk_a, scm_t_bits *next_a,
+ scm_t_bits *walk_b, scm_t_bits *next_b)
+{
+ if (SCM_DYNSTACK_TAG (walk_a) != SCM_DYNSTACK_TAG (walk_b))
+ return 0;
+
+ if (next_a - walk_a != next_b - walk_b)
+ return 0;
+
+ assert (SCM_DYNSTACK_PREV_OFFSET (next_a) == next_a - walk_a);
+ assert (SCM_DYNSTACK_PREV_OFFSET (next_b) == next_b - walk_b);
+
+ while (walk_a != next_a)
+ if (*(walk_a++) != *(walk_b++))
+ return 0;
+
+ return 1;
+}
+
+static ptrdiff_t
+shared_prefix_length (scm_t_dynstack *a, scm_t_dynstack *b)
+{
+ scm_t_bits *walk_a, *next_a, *walk_b, *next_b;
+
+ walk_a = SCM_DYNSTACK_FIRST (a);
+ walk_b = SCM_DYNSTACK_FIRST (b);
+
+ next_a = SCM_DYNSTACK_NEXT (walk_a);
+ next_b = SCM_DYNSTACK_NEXT (walk_b);
+
+ while (next_a && next_b && same_entries (walk_a, next_a, walk_b, next_b))
+ {
+ walk_a = next_a;
+ walk_b = next_b;
+
+ next_a = SCM_DYNSTACK_NEXT (walk_a);
+ next_b = SCM_DYNSTACK_NEXT (walk_b);
+ }
+
+ return walk_a - a->base;
+}
+
+scm_t_bits *
+scm_dynstack_unwind_fork (scm_t_dynstack *dynstack, scm_t_dynstack *branch)
+{
+ ptrdiff_t join_height;
+
+ join_height = shared_prefix_length (dynstack, branch);
+
+ scm_dynstack_unwind (dynstack, dynstack->base + join_height);
+
+ return branch->base + join_height;
+}
+
+scm_t_bits*
+scm_dynstack_find_prompt (scm_t_dynstack *dynstack, SCM key,
+ scm_t_dynstack_prompt_flags *flags,
+ scm_t_ptrdiff *fp_offset, scm_t_ptrdiff *sp_offset,
+ scm_t_uint32 **ip, scm_i_jmp_buf **registers)
+{
+ scm_t_bits *walk;
+
+ for (walk = SCM_DYNSTACK_PREV (dynstack->top); walk;
+ walk = SCM_DYNSTACK_PREV (walk))
+ {
+ scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
+
+ if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT
+ && scm_is_eq (PROMPT_KEY (walk), key))
+ {
+ if (flags)
+ *flags = SCM_DYNSTACK_TAG_FLAGS (tag);
+ if (fp_offset)
+ *fp_offset = PROMPT_FP (walk);
+ if (sp_offset)
+ *sp_offset = PROMPT_SP (walk);
+ if (ip)
+ *ip = PROMPT_IP (walk);
+ if (registers)
+ *registers = PROMPT_JMPBUF (walk);
+ return walk;
+ }
+ }
+
+ return NULL;
+}
+
+void
+scm_dynstack_wind_prompt (scm_t_dynstack *dynstack, scm_t_bits *item,
+ scm_t_ptrdiff reloc, scm_i_jmp_buf *registers)
+{
+ scm_t_bits tag = SCM_DYNSTACK_TAG (item);
+
+ if (SCM_DYNSTACK_TAG_TYPE (tag) != SCM_DYNSTACK_TYPE_PROMPT)
+ abort ();
+
+ scm_dynstack_push_prompt (dynstack,
+ SCM_DYNSTACK_TAG_FLAGS (tag),
+ PROMPT_KEY (item),
+ PROMPT_FP (item) + reloc,
+ PROMPT_SP (item) + reloc,
+ PROMPT_IP (item),
+ registers);
+}
+
+void
+scm_dynstack_unwind_frame (scm_t_dynstack *dynstack)
+{
+ /* Unwind up to and including the next frame entry. */
+ while (1)
+ {
+ scm_t_bits tag, *words;
+
+ tag = dynstack_pop (dynstack, &words);
+
+ switch (SCM_DYNSTACK_TAG_TYPE (tag))
+ {
+ case SCM_DYNSTACK_TYPE_FRAME:
+ return;
+ case SCM_DYNSTACK_TYPE_REWINDER:
+ clear_scm_t_bits (words, WINDER_WORDS);
+ continue;
+ case SCM_DYNSTACK_TYPE_UNWINDER:
+ {
+ scm_t_guard proc = WINDER_PROC (words);
+ void *data = WINDER_DATA (words);
+ clear_scm_t_bits (words, WINDER_WORDS);
+ if (SCM_DYNSTACK_TAG_FLAGS (tag) & SCM_F_DYNSTACK_WINDER_EXPLICIT)
+ proc (data);
+ continue;
+ }
+ default:
+ /* We should only see winders. */
+ abort ();
+ }
+ }
+}
+
+/* This function must not allocate. */
+void
+scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, SCM dynamic_state)
+{
+ scm_t_bits tag, *words;
+ size_t len;
+
+ tag = dynstack_pop (dynstack, &words);
+ len = SCM_DYNSTACK_TAG_LEN (tag);
+
+ assert (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_WITH_FLUID);
+ assert (len == WITH_FLUID_WORDS);
+
+ scm_swap_fluid (WITH_FLUID_FLUID (words), WITH_FLUID_VALUE_BOX (words),
+ dynamic_state);
+ clear_scm_t_bits (words, len);
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_DYNSTACK_H
+#define SCM_DYNSTACK_H
+
+/* Copyright (C) 2012, 2013 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
+
+typedef struct
+{
+ scm_t_bits *base;
+ scm_t_bits *top;
+ scm_t_bits *limit;
+} scm_t_dynstack;
+
+\f
+
+/* Items on the dynstack are preceded by two-word headers, giving the
+ offset of the preceding item (or 0 if there is none) and the type,
+ flags, and length of the following dynstack entry, in words. In
+ addition, there is a "null header" at the top of the stack,
+ indicating the length of the previous item, but with a tag of zero.
+
+ For example, consider an empty dynstack, with a capacity of 6 words:
+
+ +----------+----------+ +
+ |prev=0 |tag=0 | |
+ +----------+----------+ +
+ ^base ^top limit^
+
+ Now we evaluate (dynamic-wind enter thunk leave). That will result
+ in a dynstack of:
+
+ / the len=2 words \
+ +----------+----------+----------+----------+----------+----------+
+ |prev=0 |tag:len=2 |enter |leave |prev=4 |tag=0 |
+ +----------+----------+----------+----------+----------+----------+
+ ^base top,limit^
+
+ The tag is a combination of the type of the dynstack item, some flags
+ associated with the item, and the length of the item. See
+ SCM_MAKE_DYNSTACK_TAG below for the details.
+
+ This arrangement makes it possible to have variable-length dynstack
+ items, and yet be able to traverse them forwards or backwards. */
+
+#define SCM_DYNSTACK_HEADER_LEN 2
+
+#define SCM_DYNSTACK_PREV_OFFSET(top) ((top)[-2])
+#define SCM_DYNSTACK_SET_PREV_OFFSET(top, offset) (top)[-2] = (offset)
+
+#define SCM_DYNSTACK_TAG(top) ((top)[-1])
+#define SCM_DYNSTACK_SET_TAG(top, tag) (top)[-1] = (tag)
+
+typedef enum {
+ SCM_DYNSTACK_TYPE_NONE = 0,
+ SCM_DYNSTACK_TYPE_FRAME,
+ SCM_DYNSTACK_TYPE_UNWINDER,
+ SCM_DYNSTACK_TYPE_REWINDER,
+ SCM_DYNSTACK_TYPE_WITH_FLUID,
+ SCM_DYNSTACK_TYPE_PROMPT,
+ SCM_DYNSTACK_TYPE_DYNWIND,
+} scm_t_dynstack_item_type;
+
+#define SCM_DYNSTACK_TAG_TYPE_MASK 0xf
+#define SCM_DYNSTACK_TAG_FLAGS_MASK 0xf0
+#define SCM_DYNSTACK_TAG_FLAGS_SHIFT 4
+#define SCM_DYNSTACK_TAG_LEN_SHIFT 8
+
+#define SCM_MAKE_DYNSTACK_TAG(type, flags, len) \
+ ((type) | (flags) | ((len) << SCM_DYNSTACK_TAG_LEN_SHIFT))
+
+#define SCM_DYNSTACK_TAG_TYPE(tag) \
+ ((tag) & SCM_DYNSTACK_TAG_TYPE_MASK)
+#define SCM_DYNSTACK_TAG_FLAGS(tag) \
+ ((tag) & SCM_DYNSTACK_TAG_FLAGS_MASK)
+#define SCM_DYNSTACK_TAG_LEN(tag) \
+ ((tag) >> SCM_DYNSTACK_TAG_LEN_SHIFT)
+
+#define SCM_DYNSTACK_PREV(top) \
+ (SCM_DYNSTACK_PREV_OFFSET (top) \
+ ? ((top) - SCM_DYNSTACK_PREV_OFFSET (top)) : NULL)
+#define SCM_DYNSTACK_NEXT(top) \
+ (SCM_DYNSTACK_TAG (top) \
+ ? ((top) + SCM_DYNSTACK_TAG_LEN (SCM_DYNSTACK_TAG (top)) \
+ + SCM_DYNSTACK_HEADER_LEN) \
+ : NULL)
+
+#define SCM_DYNSTACK_FIRST(dynstack) \
+ ((dynstack)->base + SCM_DYNSTACK_HEADER_LEN)
+
+#define SCM_DYNSTACK_CAPACITY(dynstack) \
+ ((dynstack)->limit - (dynstack)->base)
+#define SCM_DYNSTACK_SPACE(dynstack) \
+ ((dynstack)->limit - (dynstack)->top)
+#define SCM_DYNSTACK_HEIGHT(dynstack) \
+ ((dynstack)->top - (dynstack)->base)
+
+#define SCM_DYNSTACK_HAS_SPACE(dynstack, n) \
+ (SCM_DYNSTACK_SPACE (dynstack) >= n + SCM_DYNSTACK_HEADER_LEN)
+
+typedef enum {
+ SCM_F_DYNSTACK_FRAME_REWINDABLE = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
+} scm_t_dynstack_frame_flags;
+
+typedef enum {
+ SCM_F_DYNSTACK_WINDER_EXPLICIT = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
+} scm_t_dynstack_winder_flags;
+
+typedef enum {
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT),
+ SCM_F_DYNSTACK_PROMPT_PUSH_NARGS = (2 << SCM_DYNSTACK_TAG_FLAGS_SHIFT)
+} scm_t_dynstack_prompt_flags;
+
+typedef void (*scm_t_guard) (void *);
+
+
+\f
+
+/* Pushing and popping entries on the dynamic stack. */
+
+SCM_INTERNAL void scm_dynstack_push_frame (scm_t_dynstack *,
+ scm_t_dynstack_frame_flags);
+SCM_INTERNAL void scm_dynstack_push_rewinder (scm_t_dynstack *,
+ scm_t_dynstack_winder_flags,
+ scm_t_guard, void *);
+SCM_INTERNAL void scm_dynstack_push_unwinder (scm_t_dynstack *,
+ scm_t_dynstack_winder_flags,
+ scm_t_guard, void *);
+SCM_INTERNAL void scm_dynstack_push_fluid (scm_t_dynstack *,
+ SCM fluid, SCM value,
+ SCM dynamic_state);
+SCM_INTERNAL void scm_dynstack_push_prompt (scm_t_dynstack *,
+ scm_t_dynstack_prompt_flags,
+ SCM key,
+ scm_t_ptrdiff fp_offset,
+ scm_t_ptrdiff sp_offset,
+ scm_t_uint32 *ip,
+ scm_i_jmp_buf *registers);
+SCM_INTERNAL void scm_dynstack_push_dynwind (scm_t_dynstack *,
+ SCM enter, SCM leave);
+
+SCM_INTERNAL void scm_dynstack_pop (scm_t_dynstack *);
+
+
+\f
+
+/* Capturing, winding, and unwinding. */
+
+SCM_INTERNAL scm_t_dynstack* scm_dynstack_capture_all (scm_t_dynstack *dynstack);
+SCM_INTERNAL scm_t_dynstack* scm_dynstack_capture (scm_t_dynstack *dynstack,
+ scm_t_bits *item);
+
+SCM_INTERNAL void scm_dynstack_wind_1 (scm_t_dynstack *, scm_t_bits *);
+SCM_INTERNAL scm_t_bits scm_dynstack_unwind_1 (scm_t_dynstack *);
+
+SCM_INTERNAL void scm_dynstack_wind (scm_t_dynstack *, scm_t_bits *);
+SCM_INTERNAL void scm_dynstack_unwind (scm_t_dynstack *, scm_t_bits *);
+
+
+\f
+
+/* Miscellany. */
+
+SCM_INTERNAL scm_t_bits* scm_dynstack_unwind_fork (scm_t_dynstack *,
+ scm_t_dynstack *);
+
+SCM_INTERNAL void scm_dynstack_unwind_frame (scm_t_dynstack *);
+SCM_INTERNAL void scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack,
+ SCM dynamic_state);
+
+SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM,
+ scm_t_dynstack_prompt_flags *,
+ scm_t_ptrdiff *,
+ scm_t_ptrdiff *,
+ scm_t_uint32 **,
+ scm_i_jmp_buf **);
+
+SCM_INTERNAL void scm_dynstack_wind_prompt (scm_t_dynstack *, scm_t_bits *,
+ scm_t_ptrdiff, scm_i_jmp_buf *);
+
+
+#endif /* SCM_DYNSTACK_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public 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 <assert.h>
-
-#include "libguile/_scm.h"
-#include "libguile/control.h"
-#include "libguile/eval.h"
-#include "libguile/alist.h"
-#include "libguile/fluids.h"
-#include "libguile/ports.h"
-#include "libguile/smob.h"
-
-#include "libguile/dynwind.h"
-\f
-
-/* {Dynamic wind}
-
- Things that can be on the wind list:
-
- #<frame>
- #<winder>
- #<with-fluids>
- #<prompt>
- (enter-proc . leave-proc) dynamic-wind
-
-*/
-
-
-
-SCM
-scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard)
-#define FUNC_NAME "dynamic-wind"
-{
- SCM ans, old_winds;
- SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
- out_guard,
- SCM_ARG3, FUNC_NAME);
- scm_call_0 (in_guard);
- old_winds = scm_i_dynwinds ();
- scm_i_set_dynwinds (scm_acons (in_guard, out_guard, old_winds));
- ans = scm_call_0 (thunk);
- scm_i_set_dynwinds (old_winds);
- scm_call_0 (out_guard);
- return ans;
-}
-#undef FUNC_NAME
-
-/* Frames and winders. */
-
-static scm_t_bits tc16_frame;
-#define FRAME_P(f) SCM_SMOB_PREDICATE (tc16_frame, (f))
-
-#define FRAME_F_REWINDABLE (1 << 0)
-#define FRAME_REWINDABLE_P(f) (SCM_SMOB_FLAGS(f) & FRAME_F_REWINDABLE)
-
-static scm_t_bits tc16_winder;
-#define WINDER_P(w) SCM_SMOB_PREDICATE (tc16_winder, (w))
-#define WINDER_PROC(w) ((void (*)(void *))SCM_SMOB_DATA (w))
-#define WINDER_DATA(w) ((void *)SCM_SMOB_DATA_2 (w))
-
-#define WINDER_F_EXPLICIT (1 << 0)
-#define WINDER_F_REWIND (1 << 1)
-#define WINDER_F_MARK (1 << 2)
-#define WINDER_EXPLICIT_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_EXPLICIT)
-#define WINDER_REWIND_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_REWIND)
-#define WINDER_MARK_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_MARK)
-
-void
-scm_dynwind_begin (scm_t_dynwind_flags flags)
-{
- SCM f;
- SCM_NEWSMOB (f, tc16_frame, 0);
- if (flags & SCM_F_DYNWIND_REWINDABLE)
- SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE);
- scm_i_set_dynwinds (scm_cons (f, scm_i_dynwinds ()));
-}
-
-void
-scm_dynwind_end (void)
-{
- SCM winds;
-
- /* Unwind upto and including the next frame entry. We can only
- encounter #<winder> entries on the way.
- */
-
- winds = scm_i_dynwinds ();
- while (scm_is_pair (winds))
- {
- SCM entry = SCM_CAR (winds);
- winds = SCM_CDR (winds);
-
- scm_i_set_dynwinds (winds);
-
- if (FRAME_P (entry))
- return;
-
- assert (WINDER_P (entry));
- if (!WINDER_REWIND_P (entry) && WINDER_EXPLICIT_P (entry))
- WINDER_PROC(entry) (WINDER_DATA (entry));
- }
-
- assert (0);
-}
-
-void
-scm_dynwind_unwind_handler (void (*proc) (void *), void *data,
- scm_t_wind_flags flags)
-{
- SCM w;
- SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
- if (flags & SCM_F_WIND_EXPLICITLY)
- SCM_SET_SMOB_FLAGS (w, WINDER_F_EXPLICIT);
- scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
-}
-
-void
-scm_dynwind_rewind_handler (void (*proc) (void *), void *data,
- scm_t_wind_flags flags)
-{
- SCM w;
- SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
- SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND);
- scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
- if (flags & SCM_F_WIND_EXPLICITLY)
- proc (data);
-}
-
-void
-scm_dynwind_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
- scm_t_wind_flags flags)
-{
- SCM w;
- scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
- SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
- SCM_SET_SMOB_FLAGS (w, fl | WINDER_F_MARK);
- scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
-}
-
-void
-scm_dynwind_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
- scm_t_wind_flags flags)
-{
- SCM w;
- SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
- SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND | WINDER_F_MARK);
- scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
- if (flags & SCM_F_WIND_EXPLICITLY)
- proc (data);
-}
-
-void
-scm_dynwind_free (void *mem)
-{
- scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
-}
-
-#ifdef GUILE_DEBUG
-SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
- (),
- "Return the current wind chain. The wind chain contains all\n"
- "information required by @code{dynamic-wind} to call its\n"
- "argument thunks when entering/exiting its scope.")
-#define FUNC_NAME s_scm_wind_chain
-{
- return scm_i_dynwinds ();
-}
-#undef FUNC_NAME
-#endif
-
-void
-scm_swap_bindings (SCM vars, SCM vals)
-{
- SCM tmp;
- while (SCM_NIMP (vals))
- {
- tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
- SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
- SCM_SETCAR (vals, tmp);
- vars = SCM_CDR (vars);
- vals = SCM_CDR (vals);
- }
-}
-
-void
-scm_dowinds (SCM to, long delta)
-{
- scm_i_dowinds (to, delta, NULL, NULL);
-}
-
-void
-scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
-{
- tail:
- if (scm_is_eq (to, scm_i_dynwinds ()))
- {
- if (turn_func)
- turn_func (data);
- }
- else if (delta < 0)
- {
- SCM wind_elt;
-
- scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
- wind_elt = SCM_CAR (to);
-
- if (FRAME_P (wind_elt))
- {
- if (!FRAME_REWINDABLE_P (wind_elt))
- scm_misc_error ("dowinds",
- "cannot invoke continuation from this context",
- SCM_EOL);
- }
- else if (WINDER_P (wind_elt))
- {
- if (WINDER_REWIND_P (wind_elt))
- WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
- }
- else if (SCM_WITH_FLUIDS_P (wind_elt))
- {
- scm_i_swap_with_fluids (wind_elt,
- SCM_I_CURRENT_THREAD->dynamic_state);
- }
- else if (SCM_PROMPT_P (wind_elt))
- ; /* pass -- see vm_reinstate_partial_continuation */
- else if (scm_is_pair (wind_elt))
- scm_call_0 (SCM_CAR (wind_elt));
- else
- /* trash on the wind list */
- abort ();
-
- scm_i_set_dynwinds (to);
- }
- else
- {
- SCM wind;
- SCM wind_elt;
-
- wind = scm_i_dynwinds ();
- wind_elt = SCM_CAR (wind);
- scm_i_set_dynwinds (SCM_CDR (wind));
-
- if (FRAME_P (wind_elt))
- {
- /* Nothing to do. */
- }
- else if (WINDER_P (wind_elt))
- {
- if (!WINDER_REWIND_P (wind_elt))
- WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
- }
- else if (SCM_WITH_FLUIDS_P (wind_elt))
- {
- scm_i_swap_with_fluids (wind_elt,
- SCM_I_CURRENT_THREAD->dynamic_state);
- }
- else if (SCM_PROMPT_P (wind_elt))
- ; /* pass -- though we could invalidate the prompt */
- else if (scm_is_pair (wind_elt))
- scm_call_0 (SCM_CDR (wind_elt));
- else
- /* trash on the wind list */
- abort ();
-
- delta--;
- goto tail; /* scm_dowinds(to, delta-1); */
- }
-}
-
-void
-scm_init_dynwind ()
-{
- tc16_frame = scm_make_smob_type ("frame", 0);
-
- tc16_winder = scm_make_smob_type ("winder", 0);
-
-#include "libguile/dynwind.x"
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010, 2011, 2012 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * 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 <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/dynstack.h"
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+
+#include "libguile/dynwind.h"
+
+
+\f
+
+SCM
+scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard)
+#define FUNC_NAME "dynamic-wind"
+{
+ SCM ans;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+
+ SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)), out_guard,
+ SCM_ARG3, FUNC_NAME);
+
+ scm_call_0 (in_guard);
+ scm_dynstack_push_dynwind (&thread->dynstack, in_guard, out_guard);
+
+ ans = scm_call_0 (thunk);
+
+ scm_dynstack_pop (&thread->dynstack);
+ scm_call_0 (out_guard);
+
+ return ans;
+}
+#undef FUNC_NAME
+
+
+void
+scm_dynwind_begin (scm_t_dynwind_flags flags)
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+
+ scm_dynstack_push_frame (&thread->dynstack, flags);
+}
+
+void
+scm_dynwind_end (void)
+{
+ scm_dynstack_unwind_frame (&SCM_I_CURRENT_THREAD->dynstack);
+}
+
+void
+scm_dynwind_unwind_handler (void (*proc) (void *), void *data,
+ scm_t_wind_flags flags)
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_t_dynstack *dynstack = &thread->dynstack;
+
+ scm_dynstack_push_unwinder (dynstack, flags, proc, data);
+}
+
+void
+scm_dynwind_rewind_handler (void (*proc) (void *), void *data,
+ scm_t_wind_flags flags)
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_t_dynstack *dynstack = &thread->dynstack;
+
+ scm_dynstack_push_rewinder (dynstack, 0, proc, data);
+
+ if (flags & SCM_F_WIND_EXPLICITLY)
+ proc (data);
+}
+
+void
+scm_dynwind_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
+ scm_t_wind_flags flags)
+{
+ /* FIXME: This is not a safe cast. */
+ scm_dynwind_unwind_handler ((scm_t_guard) proc, SCM2PTR (data), flags);
+}
+
+void
+scm_dynwind_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
+ scm_t_wind_flags flags)
+{
+ /* FIXME: This is not a safe cast. */
+ scm_dynwind_rewind_handler ((scm_t_guard) proc, SCM2PTR (data), flags);
+}
+
+void
+scm_dynwind_free (void *mem)
+{
+ scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
+}
+
+void
+scm_swap_bindings (SCM vars, SCM vals)
+{
+ SCM tmp;
+ while (scm_is_pair (vals))
+ {
+ tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
+ SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
+ SCM_SETCAR (vals, tmp);
+ vars = SCM_CDR (vars);
+ vals = SCM_CDR (vals);
+ }
+}
+
+void
+scm_init_dynwind ()
+{
+#include "libguile/dynwind.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
#ifndef SCM_DYNWIND_H
#define SCM_DYNWIND_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2003,2004, 2006, 2008, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2003,2004, 2006, 2008, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
\f
#include "libguile/__scm.h"
+#include "libguile/dynstack.h"
\f
-typedef void (*scm_t_guard) (void *);
-
SCM_API SCM scm_dynamic_wind (SCM thunk1, SCM thunk2, SCM thunk3);
-SCM_API void scm_dowinds (SCM to, long delta);
-SCM_INTERNAL void scm_i_dowinds (SCM to, long delta,
- void (*turn_func) (void *), void *data);
+
SCM_INTERNAL void scm_init_dynwind (void);
SCM_API void scm_swap_bindings (SCM vars, SCM vals);
typedef enum {
- SCM_F_DYNWIND_REWINDABLE = (1 << 0)
+ SCM_F_DYNWIND_REWINDABLE = SCM_F_DYNSTACK_FRAME_REWINDABLE
} scm_t_dynwind_flags;
typedef enum {
- SCM_F_WIND_EXPLICITLY = (1 << 0)
+ SCM_F_WIND_EXPLICITLY = SCM_F_DYNSTACK_WINDER_EXPLICIT
} scm_t_wind_flags;
SCM_API void scm_dynwind_begin (scm_t_dynwind_flags);
SCM_API void scm_dynwind_free (void *mem);
-#ifdef GUILE_DEBUG
-SCM_API SCM scm_wind_chain (void);
-#endif /*GUILE_DEBUG*/
#endif /* SCM_DYNWIND_H */
--- /dev/null
+/* This file defines standard ELF types, structures, and macros.
+ Copyright (C) 1995-2003,2004,2005,2006,2007,2008,2009,2010
+ Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
+
+ The GNU C 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 2.1 of the License, or (at your option) any later version.
+
+ The GNU C 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 the GNU C Library; if not, write to the Free
+ Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307 USA. */
+
+#ifndef _ELF_H
+#define _ELF_H 1
+
+/* Standard ELF types. */
+
+#include <stdint.h>
+
+/* Type for a 16-bit quantity. */
+typedef uint16_t Elf32_Half;
+typedef uint16_t Elf64_Half;
+
+/* Types for signed and unsigned 32-bit quantities. */
+typedef uint32_t Elf32_Word;
+typedef int32_t Elf32_Sword;
+typedef uint32_t Elf64_Word;
+typedef int32_t Elf64_Sword;
+
+/* Types for signed and unsigned 64-bit quantities. */
+typedef uint64_t Elf32_Xword;
+typedef int64_t Elf32_Sxword;
+typedef uint64_t Elf64_Xword;
+typedef int64_t Elf64_Sxword;
+
+/* Type of addresses. */
+typedef uint32_t Elf32_Addr;
+typedef uint64_t Elf64_Addr;
+
+/* Type of file offsets. */
+typedef uint32_t Elf32_Off;
+typedef uint64_t Elf64_Off;
+
+/* Type for section indices, which are 16-bit quantities. */
+typedef uint16_t Elf32_Section;
+typedef uint16_t Elf64_Section;
+
+/* Type for version symbol information. */
+typedef Elf32_Half Elf32_Versym;
+typedef Elf64_Half Elf64_Versym;
+
+
+/* The ELF file header. This appears at the start of every ELF file. */
+
+#define EI_NIDENT (16)
+
+typedef struct
+{
+ unsigned char e_ident[EI_NIDENT]; /* Magic number and other info */
+ Elf32_Half e_type; /* Object file type */
+ Elf32_Half e_machine; /* Architecture */
+ Elf32_Word e_version; /* Object file version */
+ Elf32_Addr e_entry; /* Entry point virtual address */
+ Elf32_Off e_phoff; /* Program header table file offset */
+ Elf32_Off e_shoff; /* Section header table file offset */
+ Elf32_Word e_flags; /* Processor-specific flags */
+ Elf32_Half e_ehsize; /* ELF header size in bytes */
+ Elf32_Half e_phentsize; /* Program header table entry size */
+ Elf32_Half e_phnum; /* Program header table entry count */
+ Elf32_Half e_shentsize; /* Section header table entry size */
+ Elf32_Half e_shnum; /* Section header table entry count */
+ Elf32_Half e_shstrndx; /* Section header string table index */
+} Elf32_Ehdr;
+
+typedef struct
+{
+ unsigned char e_ident[EI_NIDENT]; /* Magic number and other info */
+ Elf64_Half e_type; /* Object file type */
+ Elf64_Half e_machine; /* Architecture */
+ Elf64_Word e_version; /* Object file version */
+ Elf64_Addr e_entry; /* Entry point virtual address */
+ Elf64_Off e_phoff; /* Program header table file offset */
+ Elf64_Off e_shoff; /* Section header table file offset */
+ Elf64_Word e_flags; /* Processor-specific flags */
+ Elf64_Half e_ehsize; /* ELF header size in bytes */
+ Elf64_Half e_phentsize; /* Program header table entry size */
+ Elf64_Half e_phnum; /* Program header table entry count */
+ Elf64_Half e_shentsize; /* Section header table entry size */
+ Elf64_Half e_shnum; /* Section header table entry count */
+ Elf64_Half e_shstrndx; /* Section header string table index */
+} Elf64_Ehdr;
+
+/* Fields in the e_ident array. The EI_* macros are indices into the
+ array. The macros under each EI_* macro are the values the byte
+ may have. */
+
+#define EI_MAG0 0 /* File identification byte 0 index */
+#define ELFMAG0 0x7f /* Magic number byte 0 */
+
+#define EI_MAG1 1 /* File identification byte 1 index */
+#define ELFMAG1 'E' /* Magic number byte 1 */
+
+#define EI_MAG2 2 /* File identification byte 2 index */
+#define ELFMAG2 'L' /* Magic number byte 2 */
+
+#define EI_MAG3 3 /* File identification byte 3 index */
+#define ELFMAG3 'F' /* Magic number byte 3 */
+
+/* Conglomeration of the identification bytes, for easy testing as a word. */
+#define ELFMAG "\177ELF"
+#define SELFMAG 4
+
+#define EI_CLASS 4 /* File class byte index */
+#define ELFCLASSNONE 0 /* Invalid class */
+#define ELFCLASS32 1 /* 32-bit objects */
+#define ELFCLASS64 2 /* 64-bit objects */
+#define ELFCLASSNUM 3
+
+#define EI_DATA 5 /* Data encoding byte index */
+#define ELFDATANONE 0 /* Invalid data encoding */
+#define ELFDATA2LSB 1 /* 2's complement, little endian */
+#define ELFDATA2MSB 2 /* 2's complement, big endian */
+#define ELFDATANUM 3
+
+#define EI_VERSION 6 /* File version byte index */
+ /* Value must be EV_CURRENT */
+
+#define EI_OSABI 7 /* OS ABI identification */
+#define ELFOSABI_NONE 0 /* UNIX System V ABI */
+#define ELFOSABI_SYSV 0 /* Alias. */
+#define ELFOSABI_HPUX 1 /* HP-UX */
+#define ELFOSABI_NETBSD 2 /* NetBSD. */
+#define ELFOSABI_GNU 3 /* GNU. */
+#define ELFOSABI_LINUX 3 /* Alias for ELFOSABI_GNU. */
+#define ELFOSABI_SOLARIS 6 /* Sun Solaris. */
+#define ELFOSABI_AIX 7 /* IBM AIX. */
+#define ELFOSABI_IRIX 8 /* SGI Irix. */
+#define ELFOSABI_FREEBSD 9 /* FreeBSD. */
+#define ELFOSABI_TRU64 10 /* Compaq TRU64 UNIX. */
+#define ELFOSABI_MODESTO 11 /* Novell Modesto. */
+#define ELFOSABI_OPENBSD 12 /* OpenBSD. */
+#define ELFOSABI_ARM_AEABI 64 /* ARM EABI */
+#define ELFOSABI_ARM 97 /* ARM */
+#define ELFOSABI_STANDALONE 255 /* Standalone (embedded) application */
+
+#define EI_ABIVERSION 8 /* ABI version */
+
+#define EI_PAD 9 /* Byte index of padding bytes */
+
+/* Legal values for e_type (object file type). */
+
+#define ET_NONE 0 /* No file type */
+#define ET_REL 1 /* Relocatable file */
+#define ET_EXEC 2 /* Executable file */
+#define ET_DYN 3 /* Shared object file */
+#define ET_CORE 4 /* Core file */
+#define ET_NUM 5 /* Number of defined types */
+#define ET_LOOS 0xfe00 /* OS-specific range start */
+#define ET_HIOS 0xfeff /* OS-specific range end */
+#define ET_LOPROC 0xff00 /* Processor-specific range start */
+#define ET_HIPROC 0xffff /* Processor-specific range end */
+
+/* Legal values for e_machine (architecture). */
+
+#define EM_NONE 0 /* No machine */
+#define EM_M32 1 /* AT&T WE 32100 */
+#define EM_SPARC 2 /* SUN SPARC */
+#define EM_386 3 /* Intel 80386 */
+#define EM_68K 4 /* Motorola m68k family */
+#define EM_88K 5 /* Motorola m88k family */
+#define EM_860 7 /* Intel 80860 */
+#define EM_MIPS 8 /* MIPS R3000 big-endian */
+#define EM_S370 9 /* IBM System/370 */
+#define EM_MIPS_RS3_LE 10 /* MIPS R3000 little-endian */
+
+#define EM_PARISC 15 /* HPPA */
+#define EM_VPP500 17 /* Fujitsu VPP500 */
+#define EM_SPARC32PLUS 18 /* Sun's "v8plus" */
+#define EM_960 19 /* Intel 80960 */
+#define EM_PPC 20 /* PowerPC */
+#define EM_PPC64 21 /* PowerPC 64-bit */
+#define EM_S390 22 /* IBM S390 */
+
+#define EM_V800 36 /* NEC V800 series */
+#define EM_FR20 37 /* Fujitsu FR20 */
+#define EM_RH32 38 /* TRW RH-32 */
+#define EM_RCE 39 /* Motorola RCE */
+#define EM_ARM 40 /* ARM */
+#define EM_FAKE_ALPHA 41 /* Digital Alpha */
+#define EM_SH 42 /* Hitachi SH */
+#define EM_SPARCV9 43 /* SPARC v9 64-bit */
+#define EM_TRICORE 44 /* Siemens Tricore */
+#define EM_ARC 45 /* Argonaut RISC Core */
+#define EM_H8_300 46 /* Hitachi H8/300 */
+#define EM_H8_300H 47 /* Hitachi H8/300H */
+#define EM_H8S 48 /* Hitachi H8S */
+#define EM_H8_500 49 /* Hitachi H8/500 */
+#define EM_IA_64 50 /* Intel Merced */
+#define EM_MIPS_X 51 /* Stanford MIPS-X */
+#define EM_COLDFIRE 52 /* Motorola Coldfire */
+#define EM_68HC12 53 /* Motorola M68HC12 */
+#define EM_MMA 54 /* Fujitsu MMA Multimedia Accelerator*/
+#define EM_PCP 55 /* Siemens PCP */
+#define EM_NCPU 56 /* Sony nCPU embeeded RISC */
+#define EM_NDR1 57 /* Denso NDR1 microprocessor */
+#define EM_STARCORE 58 /* Motorola Start*Core processor */
+#define EM_ME16 59 /* Toyota ME16 processor */
+#define EM_ST100 60 /* STMicroelectronic ST100 processor */
+#define EM_TINYJ 61 /* Advanced Logic Corp. Tinyj emb.fam*/
+#define EM_X86_64 62 /* AMD x86-64 architecture */
+#define EM_PDSP 63 /* Sony DSP Processor */
+
+#define EM_FX66 66 /* Siemens FX66 microcontroller */
+#define EM_ST9PLUS 67 /* STMicroelectronics ST9+ 8/16 mc */
+#define EM_ST7 68 /* STmicroelectronics ST7 8 bit mc */
+#define EM_68HC16 69 /* Motorola MC68HC16 microcontroller */
+#define EM_68HC11 70 /* Motorola MC68HC11 microcontroller */
+#define EM_68HC08 71 /* Motorola MC68HC08 microcontroller */
+#define EM_68HC05 72 /* Motorola MC68HC05 microcontroller */
+#define EM_SVX 73 /* Silicon Graphics SVx */
+#define EM_ST19 74 /* STMicroelectronics ST19 8 bit mc */
+#define EM_VAX 75 /* Digital VAX */
+#define EM_CRIS 76 /* Axis Communications 32-bit embedded processor */
+#define EM_JAVELIN 77 /* Infineon Technologies 32-bit embedded processor */
+#define EM_FIREPATH 78 /* Element 14 64-bit DSP Processor */
+#define EM_ZSP 79 /* LSI Logic 16-bit DSP Processor */
+#define EM_MMIX 80 /* Donald Knuth's educational 64-bit processor */
+#define EM_HUANY 81 /* Harvard University machine-independent object files */
+#define EM_PRISM 82 /* SiTera Prism */
+#define EM_AVR 83 /* Atmel AVR 8-bit microcontroller */
+#define EM_FR30 84 /* Fujitsu FR30 */
+#define EM_D10V 85 /* Mitsubishi D10V */
+#define EM_D30V 86 /* Mitsubishi D30V */
+#define EM_V850 87 /* NEC v850 */
+#define EM_M32R 88 /* Mitsubishi M32R */
+#define EM_MN10300 89 /* Matsushita MN10300 */
+#define EM_MN10200 90 /* Matsushita MN10200 */
+#define EM_PJ 91 /* picoJava */
+#define EM_OPENRISC 92 /* OpenRISC 32-bit embedded processor */
+#define EM_ARC_A5 93 /* ARC Cores Tangent-A5 */
+#define EM_XTENSA 94 /* Tensilica Xtensa Architecture */
+#define EM_NUM 95
+
+/* If it is necessary to assign new unofficial EM_* values, please
+ pick large random numbers (0x8523, 0xa7f2, etc.) to minimize the
+ chances of collision with official or non-GNU unofficial values. */
+
+#define EM_ALPHA 0x9026
+
+/* Legal values for e_version (version). */
+
+#define EV_NONE 0 /* Invalid ELF version */
+#define EV_CURRENT 1 /* Current version */
+#define EV_NUM 2
+
+/* Section header. */
+
+typedef struct
+{
+ Elf32_Word sh_name; /* Section name (string tbl index) */
+ Elf32_Word sh_type; /* Section type */
+ Elf32_Word sh_flags; /* Section flags */
+ Elf32_Addr sh_addr; /* Section virtual addr at execution */
+ Elf32_Off sh_offset; /* Section file offset */
+ Elf32_Word sh_size; /* Section size in bytes */
+ Elf32_Word sh_link; /* Link to another section */
+ Elf32_Word sh_info; /* Additional section information */
+ Elf32_Word sh_addralign; /* Section alignment */
+ Elf32_Word sh_entsize; /* Entry size if section holds table */
+} Elf32_Shdr;
+
+typedef struct
+{
+ Elf64_Word sh_name; /* Section name (string tbl index) */
+ Elf64_Word sh_type; /* Section type */
+ Elf64_Xword sh_flags; /* Section flags */
+ Elf64_Addr sh_addr; /* Section virtual addr at execution */
+ Elf64_Off sh_offset; /* Section file offset */
+ Elf64_Xword sh_size; /* Section size in bytes */
+ Elf64_Word sh_link; /* Link to another section */
+ Elf64_Word sh_info; /* Additional section information */
+ Elf64_Xword sh_addralign; /* Section alignment */
+ Elf64_Xword sh_entsize; /* Entry size if section holds table */
+} Elf64_Shdr;
+
+/* Special section indices. */
+
+#define SHN_UNDEF 0 /* Undefined section */
+#define SHN_LORESERVE 0xff00 /* Start of reserved indices */
+#define SHN_LOPROC 0xff00 /* Start of processor-specific */
+#define SHN_BEFORE 0xff00 /* Order section before all others
+ (Solaris). */
+#define SHN_AFTER 0xff01 /* Order section after all others
+ (Solaris). */
+#define SHN_HIPROC 0xff1f /* End of processor-specific */
+#define SHN_LOOS 0xff20 /* Start of OS-specific */
+#define SHN_HIOS 0xff3f /* End of OS-specific */
+#define SHN_ABS 0xfff1 /* Associated symbol is absolute */
+#define SHN_COMMON 0xfff2 /* Associated symbol is common */
+#define SHN_XINDEX 0xffff /* Index is in extra table. */
+#define SHN_HIRESERVE 0xffff /* End of reserved indices */
+
+/* Legal values for sh_type (section type). */
+
+#define SHT_NULL 0 /* Section header table entry unused */
+#define SHT_PROGBITS 1 /* Program data */
+#define SHT_SYMTAB 2 /* Symbol table */
+#define SHT_STRTAB 3 /* String table */
+#define SHT_RELA 4 /* Relocation entries with addends */
+#define SHT_HASH 5 /* Symbol hash table */
+#define SHT_DYNAMIC 6 /* Dynamic linking information */
+#define SHT_NOTE 7 /* Notes */
+#define SHT_NOBITS 8 /* Program space with no data (bss) */
+#define SHT_REL 9 /* Relocation entries, no addends */
+#define SHT_SHLIB 10 /* Reserved */
+#define SHT_DYNSYM 11 /* Dynamic linker symbol table */
+#define SHT_INIT_ARRAY 14 /* Array of constructors */
+#define SHT_FINI_ARRAY 15 /* Array of destructors */
+#define SHT_PREINIT_ARRAY 16 /* Array of pre-constructors */
+#define SHT_GROUP 17 /* Section group */
+#define SHT_SYMTAB_SHNDX 18 /* Extended section indeces */
+#define SHT_NUM 19 /* Number of defined types. */
+#define SHT_LOOS 0x60000000 /* Start OS-specific. */
+#define SHT_GNU_ATTRIBUTES 0x6ffffff5 /* Object attributes. */
+#define SHT_GNU_HASH 0x6ffffff6 /* GNU-style hash table. */
+#define SHT_GNU_LIBLIST 0x6ffffff7 /* Prelink library list */
+#define SHT_CHECKSUM 0x6ffffff8 /* Checksum for DSO content. */
+#define SHT_LOSUNW 0x6ffffffa /* Sun-specific low bound. */
+#define SHT_SUNW_move 0x6ffffffa
+#define SHT_SUNW_COMDAT 0x6ffffffb
+#define SHT_SUNW_syminfo 0x6ffffffc
+#define SHT_GNU_verdef 0x6ffffffd /* Version definition section. */
+#define SHT_GNU_verneed 0x6ffffffe /* Version needs section. */
+#define SHT_GNU_versym 0x6fffffff /* Version symbol table. */
+#define SHT_HISUNW 0x6fffffff /* Sun-specific high bound. */
+#define SHT_HIOS 0x6fffffff /* End OS-specific type */
+#define SHT_LOPROC 0x70000000 /* Start of processor-specific */
+#define SHT_HIPROC 0x7fffffff /* End of processor-specific */
+#define SHT_LOUSER 0x80000000 /* Start of application-specific */
+#define SHT_HIUSER 0x8fffffff /* End of application-specific */
+
+/* Legal values for sh_flags (section flags). */
+
+#define SHF_WRITE (1 << 0) /* Writable */
+#define SHF_ALLOC (1 << 1) /* Occupies memory during execution */
+#define SHF_EXECINSTR (1 << 2) /* Executable */
+#define SHF_MERGE (1 << 4) /* Might be merged */
+#define SHF_STRINGS (1 << 5) /* Contains nul-terminated strings */
+#define SHF_INFO_LINK (1 << 6) /* `sh_info' contains SHT index */
+#define SHF_LINK_ORDER (1 << 7) /* Preserve order after combining */
+#define SHF_OS_NONCONFORMING (1 << 8) /* Non-standard OS specific handling
+ required */
+#define SHF_GROUP (1 << 9) /* Section is member of a group. */
+#define SHF_TLS (1 << 10) /* Section hold thread-local data. */
+#define SHF_MASKOS 0x0ff00000 /* OS-specific. */
+#define SHF_MASKPROC 0xf0000000 /* Processor-specific */
+#define SHF_ORDERED (1 << 30) /* Special ordering requirement
+ (Solaris). */
+#define SHF_EXCLUDE (1 << 31) /* Section is excluded unless
+ referenced or allocated (Solaris).*/
+
+/* Section group handling. */
+#define GRP_COMDAT 0x1 /* Mark group as COMDAT. */
+
+/* Symbol table entry. */
+
+typedef struct
+{
+ Elf32_Word st_name; /* Symbol name (string tbl index) */
+ Elf32_Addr st_value; /* Symbol value */
+ Elf32_Word st_size; /* Symbol size */
+ unsigned char st_info; /* Symbol type and binding */
+ unsigned char st_other; /* Symbol visibility */
+ Elf32_Section st_shndx; /* Section index */
+} Elf32_Sym;
+
+typedef struct
+{
+ Elf64_Word st_name; /* Symbol name (string tbl index) */
+ unsigned char st_info; /* Symbol type and binding */
+ unsigned char st_other; /* Symbol visibility */
+ Elf64_Section st_shndx; /* Section index */
+ Elf64_Addr st_value; /* Symbol value */
+ Elf64_Xword st_size; /* Symbol size */
+} Elf64_Sym;
+
+/* The syminfo section if available contains additional information about
+ every dynamic symbol. */
+
+typedef struct
+{
+ Elf32_Half si_boundto; /* Direct bindings, symbol bound to */
+ Elf32_Half si_flags; /* Per symbol flags */
+} Elf32_Syminfo;
+
+typedef struct
+{
+ Elf64_Half si_boundto; /* Direct bindings, symbol bound to */
+ Elf64_Half si_flags; /* Per symbol flags */
+} Elf64_Syminfo;
+
+/* Possible values for si_boundto. */
+#define SYMINFO_BT_SELF 0xffff /* Symbol bound to self */
+#define SYMINFO_BT_PARENT 0xfffe /* Symbol bound to parent */
+#define SYMINFO_BT_LOWRESERVE 0xff00 /* Beginning of reserved entries */
+
+/* Possible bitmasks for si_flags. */
+#define SYMINFO_FLG_DIRECT 0x0001 /* Direct bound symbol */
+#define SYMINFO_FLG_PASSTHRU 0x0002 /* Pass-thru symbol for translator */
+#define SYMINFO_FLG_COPY 0x0004 /* Symbol is a copy-reloc */
+#define SYMINFO_FLG_LAZYLOAD 0x0008 /* Symbol bound to object to be lazy
+ loaded */
+/* Syminfo version values. */
+#define SYMINFO_NONE 0
+#define SYMINFO_CURRENT 1
+#define SYMINFO_NUM 2
+
+
+/* How to extract and insert information held in the st_info field. */
+
+#define ELF32_ST_BIND(val) (((unsigned char) (val)) >> 4)
+#define ELF32_ST_TYPE(val) ((val) & 0xf)
+#define ELF32_ST_INFO(bind, type) (((bind) << 4) + ((type) & 0xf))
+
+/* Both Elf32_Sym and Elf64_Sym use the same one-byte st_info field. */
+#define ELF64_ST_BIND(val) ELF32_ST_BIND (val)
+#define ELF64_ST_TYPE(val) ELF32_ST_TYPE (val)
+#define ELF64_ST_INFO(bind, type) ELF32_ST_INFO ((bind), (type))
+
+/* Legal values for ST_BIND subfield of st_info (symbol binding). */
+
+#define STB_LOCAL 0 /* Local symbol */
+#define STB_GLOBAL 1 /* Global symbol */
+#define STB_WEAK 2 /* Weak symbol */
+#define STB_NUM 3 /* Number of defined types. */
+#define STB_LOOS 10 /* Start of OS-specific */
+#define STB_GNU_UNIQUE 10 /* Unique symbol. */
+#define STB_HIOS 12 /* End of OS-specific */
+#define STB_LOPROC 13 /* Start of processor-specific */
+#define STB_HIPROC 15 /* End of processor-specific */
+
+/* Legal values for ST_TYPE subfield of st_info (symbol type). */
+
+#define STT_NOTYPE 0 /* Symbol type is unspecified */
+#define STT_OBJECT 1 /* Symbol is a data object */
+#define STT_FUNC 2 /* Symbol is a code object */
+#define STT_SECTION 3 /* Symbol associated with a section */
+#define STT_FILE 4 /* Symbol's name is file name */
+#define STT_COMMON 5 /* Symbol is a common data object */
+#define STT_TLS 6 /* Symbol is thread-local data object*/
+#define STT_NUM 7 /* Number of defined types. */
+#define STT_LOOS 10 /* Start of OS-specific */
+#define STT_GNU_IFUNC 10 /* Symbol is indirect code object */
+#define STT_HIOS 12 /* End of OS-specific */
+#define STT_LOPROC 13 /* Start of processor-specific */
+#define STT_HIPROC 15 /* End of processor-specific */
+
+
+/* Symbol table indices are found in the hash buckets and chain table
+ of a symbol hash table section. This special index value indicates
+ the end of a chain, meaning no further symbols are found in that bucket. */
+
+#define STN_UNDEF 0 /* End of a chain. */
+
+
+/* How to extract and insert information held in the st_other field. */
+
+#define ELF32_ST_VISIBILITY(o) ((o) & 0x03)
+
+/* For ELF64 the definitions are the same. */
+#define ELF64_ST_VISIBILITY(o) ELF32_ST_VISIBILITY (o)
+
+/* Symbol visibility specification encoded in the st_other field. */
+#define STV_DEFAULT 0 /* Default symbol visibility rules */
+#define STV_INTERNAL 1 /* Processor specific hidden class */
+#define STV_HIDDEN 2 /* Sym unavailable in other modules */
+#define STV_PROTECTED 3 /* Not preemptible, not exported */
+
+
+/* Relocation table entry without addend (in section of type SHT_REL). */
+
+typedef struct
+{
+ Elf32_Addr r_offset; /* Address */
+ Elf32_Word r_info; /* Relocation type and symbol index */
+} Elf32_Rel;
+
+/* I have seen two different definitions of the Elf64_Rel and
+ Elf64_Rela structures, so we'll leave them out until Novell (or
+ whoever) gets their act together. */
+/* The following, at least, is used on Sparc v9, MIPS, and Alpha. */
+
+typedef struct
+{
+ Elf64_Addr r_offset; /* Address */
+ Elf64_Xword r_info; /* Relocation type and symbol index */
+} Elf64_Rel;
+
+/* Relocation table entry with addend (in section of type SHT_RELA). */
+
+typedef struct
+{
+ Elf32_Addr r_offset; /* Address */
+ Elf32_Word r_info; /* Relocation type and symbol index */
+ Elf32_Sword r_addend; /* Addend */
+} Elf32_Rela;
+
+typedef struct
+{
+ Elf64_Addr r_offset; /* Address */
+ Elf64_Xword r_info; /* Relocation type and symbol index */
+ Elf64_Sxword r_addend; /* Addend */
+} Elf64_Rela;
+
+/* How to extract and insert information held in the r_info field. */
+
+#define ELF32_R_SYM(val) ((val) >> 8)
+#define ELF32_R_TYPE(val) ((val) & 0xff)
+#define ELF32_R_INFO(sym, type) (((sym) << 8) + ((type) & 0xff))
+
+#define ELF64_R_SYM(i) ((i) >> 32)
+#define ELF64_R_TYPE(i) ((i) & 0xffffffff)
+#define ELF64_R_INFO(sym,type) ((((Elf64_Xword) (sym)) << 32) + (type))
+
+/* Program segment header. */
+
+typedef struct
+{
+ Elf32_Word p_type; /* Segment type */
+ Elf32_Off p_offset; /* Segment file offset */
+ Elf32_Addr p_vaddr; /* Segment virtual address */
+ Elf32_Addr p_paddr; /* Segment physical address */
+ Elf32_Word p_filesz; /* Segment size in file */
+ Elf32_Word p_memsz; /* Segment size in memory */
+ Elf32_Word p_flags; /* Segment flags */
+ Elf32_Word p_align; /* Segment alignment */
+} Elf32_Phdr;
+
+typedef struct
+{
+ Elf64_Word p_type; /* Segment type */
+ Elf64_Word p_flags; /* Segment flags */
+ Elf64_Off p_offset; /* Segment file offset */
+ Elf64_Addr p_vaddr; /* Segment virtual address */
+ Elf64_Addr p_paddr; /* Segment physical address */
+ Elf64_Xword p_filesz; /* Segment size in file */
+ Elf64_Xword p_memsz; /* Segment size in memory */
+ Elf64_Xword p_align; /* Segment alignment */
+} Elf64_Phdr;
+
+/* Special value for e_phnum. This indicates that the real number of
+ program headers is too large to fit into e_phnum. Instead the real
+ value is in the field sh_info of section 0. */
+
+#define PN_XNUM 0xffff
+
+/* Legal values for p_type (segment type). */
+
+#define PT_NULL 0 /* Program header table entry unused */
+#define PT_LOAD 1 /* Loadable program segment */
+#define PT_DYNAMIC 2 /* Dynamic linking information */
+#define PT_INTERP 3 /* Program interpreter */
+#define PT_NOTE 4 /* Auxiliary information */
+#define PT_SHLIB 5 /* Reserved */
+#define PT_PHDR 6 /* Entry for header table itself */
+#define PT_TLS 7 /* Thread-local storage segment */
+#define PT_NUM 8 /* Number of defined types */
+#define PT_LOOS 0x60000000 /* Start of OS-specific */
+#define PT_GNU_EH_FRAME 0x6474e550 /* GCC .eh_frame_hdr segment */
+#define PT_GNU_STACK 0x6474e551 /* Indicates stack executability */
+#define PT_GNU_RELRO 0x6474e552 /* Read-only after relocation */
+#define PT_LOSUNW 0x6ffffffa
+#define PT_SUNWBSS 0x6ffffffa /* Sun Specific segment */
+#define PT_SUNWSTACK 0x6ffffffb /* Stack segment */
+#define PT_HISUNW 0x6fffffff
+#define PT_HIOS 0x6fffffff /* End of OS-specific */
+#define PT_LOPROC 0x70000000 /* Start of processor-specific */
+#define PT_HIPROC 0x7fffffff /* End of processor-specific */
+
+/* Legal values for p_flags (segment flags). */
+
+#define PF_X (1 << 0) /* Segment is executable */
+#define PF_W (1 << 1) /* Segment is writable */
+#define PF_R (1 << 2) /* Segment is readable */
+#define PF_MASKOS 0x0ff00000 /* OS-specific */
+#define PF_MASKPROC 0xf0000000 /* Processor-specific */
+
+/* Legal values for note segment descriptor types for core files. */
+
+#define NT_PRSTATUS 1 /* Contains copy of prstatus struct */
+#define NT_FPREGSET 2 /* Contains copy of fpregset struct */
+#define NT_PRPSINFO 3 /* Contains copy of prpsinfo struct */
+#define NT_PRXREG 4 /* Contains copy of prxregset struct */
+#define NT_TASKSTRUCT 4 /* Contains copy of task structure */
+#define NT_PLATFORM 5 /* String from sysinfo(SI_PLATFORM) */
+#define NT_AUXV 6 /* Contains copy of auxv array */
+#define NT_GWINDOWS 7 /* Contains copy of gwindows struct */
+#define NT_ASRS 8 /* Contains copy of asrset struct */
+#define NT_PSTATUS 10 /* Contains copy of pstatus struct */
+#define NT_PSINFO 13 /* Contains copy of psinfo struct */
+#define NT_PRCRED 14 /* Contains copy of prcred struct */
+#define NT_UTSNAME 15 /* Contains copy of utsname struct */
+#define NT_LWPSTATUS 16 /* Contains copy of lwpstatus struct */
+#define NT_LWPSINFO 17 /* Contains copy of lwpinfo struct */
+#define NT_PRFPXREG 20 /* Contains copy of fprxregset struct */
+#define NT_PRXFPREG 0x46e62b7f /* Contains copy of user_fxsr_struct */
+#define NT_PPC_VMX 0x100 /* PowerPC Altivec/VMX registers */
+#define NT_PPC_SPE 0x101 /* PowerPC SPE/EVR registers */
+#define NT_PPC_VSX 0x102 /* PowerPC VSX registers */
+#define NT_386_TLS 0x200 /* i386 TLS slots (struct user_desc) */
+#define NT_386_IOPERM 0x201 /* x86 io permission bitmap (1=deny) */
+#define NT_X86_XSTATE 0x202 /* x86 extended state using xsave */
+
+/* Legal values for the note segment descriptor types for object files. */
+
+#define NT_VERSION 1 /* Contains a version string. */
+
+
+/* Dynamic section entry. */
+
+typedef struct
+{
+ Elf32_Sword d_tag; /* Dynamic entry type */
+ union
+ {
+ Elf32_Word d_val; /* Integer value */
+ Elf32_Addr d_ptr; /* Address value */
+ } d_un;
+} Elf32_Dyn;
+
+typedef struct
+{
+ Elf64_Sxword d_tag; /* Dynamic entry type */
+ union
+ {
+ Elf64_Xword d_val; /* Integer value */
+ Elf64_Addr d_ptr; /* Address value */
+ } d_un;
+} Elf64_Dyn;
+
+/* Legal values for d_tag (dynamic entry type). */
+
+#define DT_NULL 0 /* Marks end of dynamic section */
+#define DT_NEEDED 1 /* Name of needed library */
+#define DT_PLTRELSZ 2 /* Size in bytes of PLT relocs */
+#define DT_PLTGOT 3 /* Processor defined value */
+#define DT_HASH 4 /* Address of symbol hash table */
+#define DT_STRTAB 5 /* Address of string table */
+#define DT_SYMTAB 6 /* Address of symbol table */
+#define DT_RELA 7 /* Address of Rela relocs */
+#define DT_RELASZ 8 /* Total size of Rela relocs */
+#define DT_RELAENT 9 /* Size of one Rela reloc */
+#define DT_STRSZ 10 /* Size of string table */
+#define DT_SYMENT 11 /* Size of one symbol table entry */
+#define DT_INIT 12 /* Address of init function */
+#define DT_FINI 13 /* Address of termination function */
+#define DT_SONAME 14 /* Name of shared object */
+#define DT_RPATH 15 /* Library search path (deprecated) */
+#define DT_SYMBOLIC 16 /* Start symbol search here */
+#define DT_REL 17 /* Address of Rel relocs */
+#define DT_RELSZ 18 /* Total size of Rel relocs */
+#define DT_RELENT 19 /* Size of one Rel reloc */
+#define DT_PLTREL 20 /* Type of reloc in PLT */
+#define DT_DEBUG 21 /* For debugging; unspecified */
+#define DT_TEXTREL 22 /* Reloc might modify .text */
+#define DT_JMPREL 23 /* Address of PLT relocs */
+#define DT_BIND_NOW 24 /* Process relocations of object */
+#define DT_INIT_ARRAY 25 /* Array with addresses of init fct */
+#define DT_FINI_ARRAY 26 /* Array with addresses of fini fct */
+#define DT_INIT_ARRAYSZ 27 /* Size in bytes of DT_INIT_ARRAY */
+#define DT_FINI_ARRAYSZ 28 /* Size in bytes of DT_FINI_ARRAY */
+#define DT_RUNPATH 29 /* Library search path */
+#define DT_FLAGS 30 /* Flags for the object being loaded */
+#define DT_ENCODING 32 /* Start of encoded range */
+#define DT_PREINIT_ARRAY 32 /* Array with addresses of preinit fct*/
+#define DT_PREINIT_ARRAYSZ 33 /* size in bytes of DT_PREINIT_ARRAY */
+#define DT_NUM 34 /* Number used */
+#define DT_LOOS 0x6000000d /* Start of OS-specific */
+#define DT_HIOS 0x6ffff000 /* End of OS-specific */
+#define DT_LOPROC 0x70000000 /* Start of processor-specific */
+#define DT_HIPROC 0x7fffffff /* End of processor-specific */
+#define DT_PROCNUM DT_MIPS_NUM /* Most used by any processor */
+
+/* DT_* entries which fall between DT_VALRNGHI & DT_VALRNGLO use the
+ Dyn.d_un.d_val field of the Elf*_Dyn structure. This follows Sun's
+ approach. */
+#define DT_VALRNGLO 0x6ffffd00
+#define DT_GNU_PRELINKED 0x6ffffdf5 /* Prelinking timestamp */
+#define DT_GNU_CONFLICTSZ 0x6ffffdf6 /* Size of conflict section */
+#define DT_GNU_LIBLISTSZ 0x6ffffdf7 /* Size of library list */
+#define DT_CHECKSUM 0x6ffffdf8
+#define DT_PLTPADSZ 0x6ffffdf9
+#define DT_MOVEENT 0x6ffffdfa
+#define DT_MOVESZ 0x6ffffdfb
+#define DT_FEATURE_1 0x6ffffdfc /* Feature selection (DTF_*). */
+#define DT_POSFLAG_1 0x6ffffdfd /* Flags for DT_* entries, effecting
+ the following DT_* entry. */
+#define DT_SYMINSZ 0x6ffffdfe /* Size of syminfo table (in bytes) */
+#define DT_SYMINENT 0x6ffffdff /* Entry size of syminfo */
+#define DT_VALRNGHI 0x6ffffdff
+#define DT_VALTAGIDX(tag) (DT_VALRNGHI - (tag)) /* Reverse order! */
+#define DT_VALNUM 12
+
+/* DT_* entries which fall between DT_ADDRRNGHI & DT_ADDRRNGLO use the
+ Dyn.d_un.d_ptr field of the Elf*_Dyn structure.
+
+ If any adjustment is made to the ELF object after it has been
+ built these entries will need to be adjusted. */
+#define DT_ADDRRNGLO 0x6ffffe00
+#define DT_GNU_HASH 0x6ffffef5 /* GNU-style hash table. */
+#define DT_TLSDESC_PLT 0x6ffffef6
+#define DT_TLSDESC_GOT 0x6ffffef7
+#define DT_GNU_CONFLICT 0x6ffffef8 /* Start of conflict section */
+#define DT_GNU_LIBLIST 0x6ffffef9 /* Library list */
+#define DT_CONFIG 0x6ffffefa /* Configuration information. */
+#define DT_DEPAUDIT 0x6ffffefb /* Dependency auditing. */
+#define DT_AUDIT 0x6ffffefc /* Object auditing. */
+#define DT_PLTPAD 0x6ffffefd /* PLT padding. */
+#define DT_MOVETAB 0x6ffffefe /* Move table. */
+#define DT_SYMINFO 0x6ffffeff /* Syminfo table. */
+#define DT_ADDRRNGHI 0x6ffffeff
+#define DT_ADDRTAGIDX(tag) (DT_ADDRRNGHI - (tag)) /* Reverse order! */
+#define DT_ADDRNUM 11
+
+/* The versioning entry types. The next are defined as part of the
+ GNU extension. */
+#define DT_VERSYM 0x6ffffff0
+
+#define DT_RELACOUNT 0x6ffffff9
+#define DT_RELCOUNT 0x6ffffffa
+
+/* These were chosen by Sun. */
+#define DT_FLAGS_1 0x6ffffffb /* State flags, see DF_1_* below. */
+#define DT_VERDEF 0x6ffffffc /* Address of version definition
+ table */
+#define DT_VERDEFNUM 0x6ffffffd /* Number of version definitions */
+#define DT_VERNEED 0x6ffffffe /* Address of table with needed
+ versions */
+#define DT_VERNEEDNUM 0x6fffffff /* Number of needed versions */
+#define DT_VERSIONTAGIDX(tag) (DT_VERNEEDNUM - (tag)) /* Reverse order! */
+#define DT_VERSIONTAGNUM 16
+
+/* Sun added these machine-independent extensions in the "processor-specific"
+ range. Be compatible. */
+#define DT_AUXILIARY 0x7ffffffd /* Shared object to load before self */
+#define DT_FILTER 0x7fffffff /* Shared object to get values from */
+#define DT_EXTRATAGIDX(tag) ((Elf32_Word)-((Elf32_Sword) (tag) <<1>>1)-1)
+#define DT_EXTRANUM 3
+
+/* Values of `d_un.d_val' in the DT_FLAGS entry. */
+#define DF_ORIGIN 0x00000001 /* Object may use DF_ORIGIN */
+#define DF_SYMBOLIC 0x00000002 /* Symbol resolutions starts here */
+#define DF_TEXTREL 0x00000004 /* Object contains text relocations */
+#define DF_BIND_NOW 0x00000008 /* No lazy binding for this object */
+#define DF_STATIC_TLS 0x00000010 /* Module uses the static TLS model */
+
+/* State flags selectable in the `d_un.d_val' element of the DT_FLAGS_1
+ entry in the dynamic section. */
+#define DF_1_NOW 0x00000001 /* Set RTLD_NOW for this object. */
+#define DF_1_GLOBAL 0x00000002 /* Set RTLD_GLOBAL for this object. */
+#define DF_1_GROUP 0x00000004 /* Set RTLD_GROUP for this object. */
+#define DF_1_NODELETE 0x00000008 /* Set RTLD_NODELETE for this object.*/
+#define DF_1_LOADFLTR 0x00000010 /* Trigger filtee loading at runtime.*/
+#define DF_1_INITFIRST 0x00000020 /* Set RTLD_INITFIRST for this object*/
+#define DF_1_NOOPEN 0x00000040 /* Set RTLD_NOOPEN for this object. */
+#define DF_1_ORIGIN 0x00000080 /* $ORIGIN must be handled. */
+#define DF_1_DIRECT 0x00000100 /* Direct binding enabled. */
+#define DF_1_TRANS 0x00000200
+#define DF_1_INTERPOSE 0x00000400 /* Object is used to interpose. */
+#define DF_1_NODEFLIB 0x00000800 /* Ignore default lib search path. */
+#define DF_1_NODUMP 0x00001000 /* Object can't be dldump'ed. */
+#define DF_1_CONFALT 0x00002000 /* Configuration alternative created.*/
+#define DF_1_ENDFILTEE 0x00004000 /* Filtee terminates filters search. */
+#define DF_1_DISPRELDNE 0x00008000 /* Disp reloc applied at build time. */
+#define DF_1_DISPRELPND 0x00010000 /* Disp reloc applied at run-time. */
+
+/* Flags for the feature selection in DT_FEATURE_1. */
+#define DTF_1_PARINIT 0x00000001
+#define DTF_1_CONFEXP 0x00000002
+
+/* Flags in the DT_POSFLAG_1 entry effecting only the next DT_* entry. */
+#define DF_P1_LAZYLOAD 0x00000001 /* Lazyload following object. */
+#define DF_P1_GROUPPERM 0x00000002 /* Symbols from next object are not
+ generally available. */
+
+/* Version definition sections. */
+
+typedef struct
+{
+ Elf32_Half vd_version; /* Version revision */
+ Elf32_Half vd_flags; /* Version information */
+ Elf32_Half vd_ndx; /* Version Index */
+ Elf32_Half vd_cnt; /* Number of associated aux entries */
+ Elf32_Word vd_hash; /* Version name hash value */
+ Elf32_Word vd_aux; /* Offset in bytes to verdaux array */
+ Elf32_Word vd_next; /* Offset in bytes to next verdef
+ entry */
+} Elf32_Verdef;
+
+typedef struct
+{
+ Elf64_Half vd_version; /* Version revision */
+ Elf64_Half vd_flags; /* Version information */
+ Elf64_Half vd_ndx; /* Version Index */
+ Elf64_Half vd_cnt; /* Number of associated aux entries */
+ Elf64_Word vd_hash; /* Version name hash value */
+ Elf64_Word vd_aux; /* Offset in bytes to verdaux array */
+ Elf64_Word vd_next; /* Offset in bytes to next verdef
+ entry */
+} Elf64_Verdef;
+
+
+/* Legal values for vd_version (version revision). */
+#define VER_DEF_NONE 0 /* No version */
+#define VER_DEF_CURRENT 1 /* Current version */
+#define VER_DEF_NUM 2 /* Given version number */
+
+/* Legal values for vd_flags (version information flags). */
+#define VER_FLG_BASE 0x1 /* Version definition of file itself */
+#define VER_FLG_WEAK 0x2 /* Weak version identifier */
+
+/* Versym symbol index values. */
+#define VER_NDX_LOCAL 0 /* Symbol is local. */
+#define VER_NDX_GLOBAL 1 /* Symbol is global. */
+#define VER_NDX_LORESERVE 0xff00 /* Beginning of reserved entries. */
+#define VER_NDX_ELIMINATE 0xff01 /* Symbol is to be eliminated. */
+
+/* Auxialiary version information. */
+
+typedef struct
+{
+ Elf32_Word vda_name; /* Version or dependency names */
+ Elf32_Word vda_next; /* Offset in bytes to next verdaux
+ entry */
+} Elf32_Verdaux;
+
+typedef struct
+{
+ Elf64_Word vda_name; /* Version or dependency names */
+ Elf64_Word vda_next; /* Offset in bytes to next verdaux
+ entry */
+} Elf64_Verdaux;
+
+
+/* Version dependency section. */
+
+typedef struct
+{
+ Elf32_Half vn_version; /* Version of structure */
+ Elf32_Half vn_cnt; /* Number of associated aux entries */
+ Elf32_Word vn_file; /* Offset of filename for this
+ dependency */
+ Elf32_Word vn_aux; /* Offset in bytes to vernaux array */
+ Elf32_Word vn_next; /* Offset in bytes to next verneed
+ entry */
+} Elf32_Verneed;
+
+typedef struct
+{
+ Elf64_Half vn_version; /* Version of structure */
+ Elf64_Half vn_cnt; /* Number of associated aux entries */
+ Elf64_Word vn_file; /* Offset of filename for this
+ dependency */
+ Elf64_Word vn_aux; /* Offset in bytes to vernaux array */
+ Elf64_Word vn_next; /* Offset in bytes to next verneed
+ entry */
+} Elf64_Verneed;
+
+
+/* Legal values for vn_version (version revision). */
+#define VER_NEED_NONE 0 /* No version */
+#define VER_NEED_CURRENT 1 /* Current version */
+#define VER_NEED_NUM 2 /* Given version number */
+
+/* Auxiliary needed version information. */
+
+typedef struct
+{
+ Elf32_Word vna_hash; /* Hash value of dependency name */
+ Elf32_Half vna_flags; /* Dependency specific information */
+ Elf32_Half vna_other; /* Unused */
+ Elf32_Word vna_name; /* Dependency name string offset */
+ Elf32_Word vna_next; /* Offset in bytes to next vernaux
+ entry */
+} Elf32_Vernaux;
+
+typedef struct
+{
+ Elf64_Word vna_hash; /* Hash value of dependency name */
+ Elf64_Half vna_flags; /* Dependency specific information */
+ Elf64_Half vna_other; /* Unused */
+ Elf64_Word vna_name; /* Dependency name string offset */
+ Elf64_Word vna_next; /* Offset in bytes to next vernaux
+ entry */
+} Elf64_Vernaux;
+
+
+/* Legal values for vna_flags. */
+#define VER_FLG_WEAK 0x2 /* Weak version identifier */
+
+
+/* Auxiliary vector. */
+
+/* This vector is normally only used by the program interpreter. The
+ usual definition in an ABI supplement uses the name auxv_t. The
+ vector is not usually defined in a standard <elf.h> file, but it
+ can't hurt. We rename it to avoid conflicts. The sizes of these
+ types are an arrangement between the exec server and the program
+ interpreter, so we don't fully specify them here. */
+
+typedef struct
+{
+ uint32_t a_type; /* Entry type */
+ union
+ {
+ uint32_t a_val; /* Integer value */
+ /* We use to have pointer elements added here. We cannot do that,
+ though, since it does not work when using 32-bit definitions
+ on 64-bit platforms and vice versa. */
+ } a_un;
+} Elf32_auxv_t;
+
+typedef struct
+{
+ uint64_t a_type; /* Entry type */
+ union
+ {
+ uint64_t a_val; /* Integer value */
+ /* We use to have pointer elements added here. We cannot do that,
+ though, since it does not work when using 32-bit definitions
+ on 64-bit platforms and vice versa. */
+ } a_un;
+} Elf64_auxv_t;
+
+/* Legal values for a_type (entry type). */
+
+#define AT_NULL 0 /* End of vector */
+#define AT_IGNORE 1 /* Entry should be ignored */
+#define AT_EXECFD 2 /* File descriptor of program */
+#define AT_PHDR 3 /* Program headers for program */
+#define AT_PHENT 4 /* Size of program header entry */
+#define AT_PHNUM 5 /* Number of program headers */
+#define AT_PAGESZ 6 /* System page size */
+#define AT_BASE 7 /* Base address of interpreter */
+#define AT_FLAGS 8 /* Flags */
+#define AT_ENTRY 9 /* Entry point of program */
+#define AT_NOTELF 10 /* Program is not ELF */
+#define AT_UID 11 /* Real uid */
+#define AT_EUID 12 /* Effective uid */
+#define AT_GID 13 /* Real gid */
+#define AT_EGID 14 /* Effective gid */
+#define AT_CLKTCK 17 /* Frequency of times() */
+
+/* Some more special a_type values describing the hardware. */
+#define AT_PLATFORM 15 /* String identifying platform. */
+#define AT_HWCAP 16 /* Machine dependent hints about
+ processor capabilities. */
+
+/* This entry gives some information about the FPU initialization
+ performed by the kernel. */
+#define AT_FPUCW 18 /* Used FPU control word. */
+
+/* Cache block sizes. */
+#define AT_DCACHEBSIZE 19 /* Data cache block size. */
+#define AT_ICACHEBSIZE 20 /* Instruction cache block size. */
+#define AT_UCACHEBSIZE 21 /* Unified cache block size. */
+
+/* A special ignored value for PPC, used by the kernel to control the
+ interpretation of the AUXV. Must be > 16. */
+#define AT_IGNOREPPC 22 /* Entry should be ignored. */
+
+#define AT_SECURE 23 /* Boolean, was exec setuid-like? */
+
+#define AT_BASE_PLATFORM 24 /* String identifying real platforms.*/
+
+#define AT_RANDOM 25 /* Address of 16 random bytes. */
+
+#define AT_EXECFN 31 /* Filename of executable. */
+
+/* Pointer to the global system page used for system calls and other
+ nice things. */
+#define AT_SYSINFO 32
+#define AT_SYSINFO_EHDR 33
+
+/* Shapes of the caches. Bits 0-3 contains associativity; bits 4-7 contains
+ log2 of line size; mask those to get cache size. */
+#define AT_L1I_CACHESHAPE 34
+#define AT_L1D_CACHESHAPE 35
+#define AT_L2_CACHESHAPE 36
+#define AT_L3_CACHESHAPE 37
+
+/* Note section contents. Each entry in the note section begins with
+ a header of a fixed form. */
+
+typedef struct
+{
+ Elf32_Word n_namesz; /* Length of the note's name. */
+ Elf32_Word n_descsz; /* Length of the note's descriptor. */
+ Elf32_Word n_type; /* Type of the note. */
+} Elf32_Nhdr;
+
+typedef struct
+{
+ Elf64_Word n_namesz; /* Length of the note's name. */
+ Elf64_Word n_descsz; /* Length of the note's descriptor. */
+ Elf64_Word n_type; /* Type of the note. */
+} Elf64_Nhdr;
+
+/* Known names of notes. */
+
+/* Solaris entries in the note section have this name. */
+#define ELF_NOTE_SOLARIS "SUNW Solaris"
+
+/* Note entries for GNU systems have this name. */
+#define ELF_NOTE_GNU "GNU"
+
+
+/* Defined types of notes for Solaris. */
+
+/* Value of descriptor (one word) is desired pagesize for the binary. */
+#define ELF_NOTE_PAGESIZE_HINT 1
+
+
+/* Defined note types for GNU systems. */
+
+/* ABI information. The descriptor consists of words:
+ word 0: OS descriptor
+ word 1: major version of the ABI
+ word 2: minor version of the ABI
+ word 3: subminor version of the ABI
+*/
+#define NT_GNU_ABI_TAG 1
+#define ELF_NOTE_ABI NT_GNU_ABI_TAG /* Old name. */
+
+/* Known OSes. These values can appear in word 0 of an
+ NT_GNU_ABI_TAG note section entry. */
+#define ELF_NOTE_OS_LINUX 0
+#define ELF_NOTE_OS_GNU 1
+#define ELF_NOTE_OS_SOLARIS2 2
+#define ELF_NOTE_OS_FREEBSD 3
+
+/* Synthetic hwcap information. The descriptor begins with two words:
+ word 0: number of entries
+ word 1: bitmask of enabled entries
+ Then follow variable-length entries, one byte followed by a
+ '\0'-terminated hwcap name string. The byte gives the bit
+ number to test if enabled, (1U << bit) & bitmask. */
+#define NT_GNU_HWCAP 2
+
+/* Build ID bits as generated by ld --build-id.
+ The descriptor consists of any nonzero number of bytes. */
+#define NT_GNU_BUILD_ID 3
+
+/* Version note generated by GNU gold containing a version string. */
+#define NT_GNU_GOLD_VERSION 4
+
+
+/* Move records. */
+typedef struct
+{
+ Elf32_Xword m_value; /* Symbol value. */
+ Elf32_Word m_info; /* Size and index. */
+ Elf32_Word m_poffset; /* Symbol offset. */
+ Elf32_Half m_repeat; /* Repeat count. */
+ Elf32_Half m_stride; /* Stride info. */
+} Elf32_Move;
+
+typedef struct
+{
+ Elf64_Xword m_value; /* Symbol value. */
+ Elf64_Xword m_info; /* Size and index. */
+ Elf64_Xword m_poffset; /* Symbol offset. */
+ Elf64_Half m_repeat; /* Repeat count. */
+ Elf64_Half m_stride; /* Stride info. */
+} Elf64_Move;
+
+/* Macro to construct move records. */
+#define ELF32_M_SYM(info) ((info) >> 8)
+#define ELF32_M_SIZE(info) ((unsigned char) (info))
+#define ELF32_M_INFO(sym, size) (((sym) << 8) + (unsigned char) (size))
+
+#define ELF64_M_SYM(info) ELF32_M_SYM (info)
+#define ELF64_M_SIZE(info) ELF32_M_SIZE (info)
+#define ELF64_M_INFO(sym, size) ELF32_M_INFO (sym, size)
+
+
+/* Motorola 68k specific definitions. */
+
+/* Values for Elf32_Ehdr.e_flags. */
+#define EF_CPU32 0x00810000
+
+/* m68k relocs. */
+
+#define R_68K_NONE 0 /* No reloc */
+#define R_68K_32 1 /* Direct 32 bit */
+#define R_68K_16 2 /* Direct 16 bit */
+#define R_68K_8 3 /* Direct 8 bit */
+#define R_68K_PC32 4 /* PC relative 32 bit */
+#define R_68K_PC16 5 /* PC relative 16 bit */
+#define R_68K_PC8 6 /* PC relative 8 bit */
+#define R_68K_GOT32 7 /* 32 bit PC relative GOT entry */
+#define R_68K_GOT16 8 /* 16 bit PC relative GOT entry */
+#define R_68K_GOT8 9 /* 8 bit PC relative GOT entry */
+#define R_68K_GOT32O 10 /* 32 bit GOT offset */
+#define R_68K_GOT16O 11 /* 16 bit GOT offset */
+#define R_68K_GOT8O 12 /* 8 bit GOT offset */
+#define R_68K_PLT32 13 /* 32 bit PC relative PLT address */
+#define R_68K_PLT16 14 /* 16 bit PC relative PLT address */
+#define R_68K_PLT8 15 /* 8 bit PC relative PLT address */
+#define R_68K_PLT32O 16 /* 32 bit PLT offset */
+#define R_68K_PLT16O 17 /* 16 bit PLT offset */
+#define R_68K_PLT8O 18 /* 8 bit PLT offset */
+#define R_68K_COPY 19 /* Copy symbol at runtime */
+#define R_68K_GLOB_DAT 20 /* Create GOT entry */
+#define R_68K_JMP_SLOT 21 /* Create PLT entry */
+#define R_68K_RELATIVE 22 /* Adjust by program base */
+#define R_68K_TLS_GD32 25 /* 32 bit GOT offset for GD */
+#define R_68K_TLS_GD16 26 /* 16 bit GOT offset for GD */
+#define R_68K_TLS_GD8 27 /* 8 bit GOT offset for GD */
+#define R_68K_TLS_LDM32 28 /* 32 bit GOT offset for LDM */
+#define R_68K_TLS_LDM16 29 /* 16 bit GOT offset for LDM */
+#define R_68K_TLS_LDM8 30 /* 8 bit GOT offset for LDM */
+#define R_68K_TLS_LDO32 31 /* 32 bit module-relative offset */
+#define R_68K_TLS_LDO16 32 /* 16 bit module-relative offset */
+#define R_68K_TLS_LDO8 33 /* 8 bit module-relative offset */
+#define R_68K_TLS_IE32 34 /* 32 bit GOT offset for IE */
+#define R_68K_TLS_IE16 35 /* 16 bit GOT offset for IE */
+#define R_68K_TLS_IE8 36 /* 8 bit GOT offset for IE */
+#define R_68K_TLS_LE32 37 /* 32 bit offset relative to
+ static TLS block */
+#define R_68K_TLS_LE16 38 /* 16 bit offset relative to
+ static TLS block */
+#define R_68K_TLS_LE8 39 /* 8 bit offset relative to
+ static TLS block */
+#define R_68K_TLS_DTPMOD32 40 /* 32 bit module number */
+#define R_68K_TLS_DTPREL32 41 /* 32 bit module-relative offset */
+#define R_68K_TLS_TPREL32 42 /* 32 bit TP-relative offset */
+/* Keep this the last entry. */
+#define R_68K_NUM 43
+
+/* Intel 80386 specific definitions. */
+
+/* i386 relocs. */
+
+#define R_386_NONE 0 /* No reloc */
+#define R_386_32 1 /* Direct 32 bit */
+#define R_386_PC32 2 /* PC relative 32 bit */
+#define R_386_GOT32 3 /* 32 bit GOT entry */
+#define R_386_PLT32 4 /* 32 bit PLT address */
+#define R_386_COPY 5 /* Copy symbol at runtime */
+#define R_386_GLOB_DAT 6 /* Create GOT entry */
+#define R_386_JMP_SLOT 7 /* Create PLT entry */
+#define R_386_RELATIVE 8 /* Adjust by program base */
+#define R_386_GOTOFF 9 /* 32 bit offset to GOT */
+#define R_386_GOTPC 10 /* 32 bit PC relative offset to GOT */
+#define R_386_32PLT 11
+#define R_386_TLS_TPOFF 14 /* Offset in static TLS block */
+#define R_386_TLS_IE 15 /* Address of GOT entry for static TLS
+ block offset */
+#define R_386_TLS_GOTIE 16 /* GOT entry for static TLS block
+ offset */
+#define R_386_TLS_LE 17 /* Offset relative to static TLS
+ block */
+#define R_386_TLS_GD 18 /* Direct 32 bit for GNU version of
+ general dynamic thread local data */
+#define R_386_TLS_LDM 19 /* Direct 32 bit for GNU version of
+ local dynamic thread local data
+ in LE code */
+#define R_386_16 20
+#define R_386_PC16 21
+#define R_386_8 22
+#define R_386_PC8 23
+#define R_386_TLS_GD_32 24 /* Direct 32 bit for general dynamic
+ thread local data */
+#define R_386_TLS_GD_PUSH 25 /* Tag for pushl in GD TLS code */
+#define R_386_TLS_GD_CALL 26 /* Relocation for call to
+ __tls_get_addr() */
+#define R_386_TLS_GD_POP 27 /* Tag for popl in GD TLS code */
+#define R_386_TLS_LDM_32 28 /* Direct 32 bit for local dynamic
+ thread local data in LE code */
+#define R_386_TLS_LDM_PUSH 29 /* Tag for pushl in LDM TLS code */
+#define R_386_TLS_LDM_CALL 30 /* Relocation for call to
+ __tls_get_addr() in LDM code */
+#define R_386_TLS_LDM_POP 31 /* Tag for popl in LDM TLS code */
+#define R_386_TLS_LDO_32 32 /* Offset relative to TLS block */
+#define R_386_TLS_IE_32 33 /* GOT entry for negated static TLS
+ block offset */
+#define R_386_TLS_LE_32 34 /* Negated offset relative to static
+ TLS block */
+#define R_386_TLS_DTPMOD32 35 /* ID of module containing symbol */
+#define R_386_TLS_DTPOFF32 36 /* Offset in TLS block */
+#define R_386_TLS_TPOFF32 37 /* Negated offset in static TLS block */
+/* 38? */
+#define R_386_TLS_GOTDESC 39 /* GOT offset for TLS descriptor. */
+#define R_386_TLS_DESC_CALL 40 /* Marker of call through TLS
+ descriptor for
+ relaxation. */
+#define R_386_TLS_DESC 41 /* TLS descriptor containing
+ pointer to code and to
+ argument, returning the TLS
+ offset for the symbol. */
+#define R_386_IRELATIVE 42 /* Adjust indirectly by program base */
+/* Keep this the last entry. */
+#define R_386_NUM 43
+
+/* SUN SPARC specific definitions. */
+
+/* Legal values for ST_TYPE subfield of st_info (symbol type). */
+
+#define STT_SPARC_REGISTER 13 /* Global register reserved to app. */
+
+/* Values for Elf64_Ehdr.e_flags. */
+
+#define EF_SPARCV9_MM 3
+#define EF_SPARCV9_TSO 0
+#define EF_SPARCV9_PSO 1
+#define EF_SPARCV9_RMO 2
+#define EF_SPARC_LEDATA 0x800000 /* little endian data */
+#define EF_SPARC_EXT_MASK 0xFFFF00
+#define EF_SPARC_32PLUS 0x000100 /* generic V8+ features */
+#define EF_SPARC_SUN_US1 0x000200 /* Sun UltraSPARC1 extensions */
+#define EF_SPARC_HAL_R1 0x000400 /* HAL R1 extensions */
+#define EF_SPARC_SUN_US3 0x000800 /* Sun UltraSPARCIII extensions */
+
+/* SPARC relocs. */
+
+#define R_SPARC_NONE 0 /* No reloc */
+#define R_SPARC_8 1 /* Direct 8 bit */
+#define R_SPARC_16 2 /* Direct 16 bit */
+#define R_SPARC_32 3 /* Direct 32 bit */
+#define R_SPARC_DISP8 4 /* PC relative 8 bit */
+#define R_SPARC_DISP16 5 /* PC relative 16 bit */
+#define R_SPARC_DISP32 6 /* PC relative 32 bit */
+#define R_SPARC_WDISP30 7 /* PC relative 30 bit shifted */
+#define R_SPARC_WDISP22 8 /* PC relative 22 bit shifted */
+#define R_SPARC_HI22 9 /* High 22 bit */
+#define R_SPARC_22 10 /* Direct 22 bit */
+#define R_SPARC_13 11 /* Direct 13 bit */
+#define R_SPARC_LO10 12 /* Truncated 10 bit */
+#define R_SPARC_GOT10 13 /* Truncated 10 bit GOT entry */
+#define R_SPARC_GOT13 14 /* 13 bit GOT entry */
+#define R_SPARC_GOT22 15 /* 22 bit GOT entry shifted */
+#define R_SPARC_PC10 16 /* PC relative 10 bit truncated */
+#define R_SPARC_PC22 17 /* PC relative 22 bit shifted */
+#define R_SPARC_WPLT30 18 /* 30 bit PC relative PLT address */
+#define R_SPARC_COPY 19 /* Copy symbol at runtime */
+#define R_SPARC_GLOB_DAT 20 /* Create GOT entry */
+#define R_SPARC_JMP_SLOT 21 /* Create PLT entry */
+#define R_SPARC_RELATIVE 22 /* Adjust by program base */
+#define R_SPARC_UA32 23 /* Direct 32 bit unaligned */
+
+/* Additional Sparc64 relocs. */
+
+#define R_SPARC_PLT32 24 /* Direct 32 bit ref to PLT entry */
+#define R_SPARC_HIPLT22 25 /* High 22 bit PLT entry */
+#define R_SPARC_LOPLT10 26 /* Truncated 10 bit PLT entry */
+#define R_SPARC_PCPLT32 27 /* PC rel 32 bit ref to PLT entry */
+#define R_SPARC_PCPLT22 28 /* PC rel high 22 bit PLT entry */
+#define R_SPARC_PCPLT10 29 /* PC rel trunc 10 bit PLT entry */
+#define R_SPARC_10 30 /* Direct 10 bit */
+#define R_SPARC_11 31 /* Direct 11 bit */
+#define R_SPARC_64 32 /* Direct 64 bit */
+#define R_SPARC_OLO10 33 /* 10bit with secondary 13bit addend */
+#define R_SPARC_HH22 34 /* Top 22 bits of direct 64 bit */
+#define R_SPARC_HM10 35 /* High middle 10 bits of ... */
+#define R_SPARC_LM22 36 /* Low middle 22 bits of ... */
+#define R_SPARC_PC_HH22 37 /* Top 22 bits of pc rel 64 bit */
+#define R_SPARC_PC_HM10 38 /* High middle 10 bit of ... */
+#define R_SPARC_PC_LM22 39 /* Low miggle 22 bits of ... */
+#define R_SPARC_WDISP16 40 /* PC relative 16 bit shifted */
+#define R_SPARC_WDISP19 41 /* PC relative 19 bit shifted */
+#define R_SPARC_GLOB_JMP 42 /* was part of v9 ABI but was removed */
+#define R_SPARC_7 43 /* Direct 7 bit */
+#define R_SPARC_5 44 /* Direct 5 bit */
+#define R_SPARC_6 45 /* Direct 6 bit */
+#define R_SPARC_DISP64 46 /* PC relative 64 bit */
+#define R_SPARC_PLT64 47 /* Direct 64 bit ref to PLT entry */
+#define R_SPARC_HIX22 48 /* High 22 bit complemented */
+#define R_SPARC_LOX10 49 /* Truncated 11 bit complemented */
+#define R_SPARC_H44 50 /* Direct high 12 of 44 bit */
+#define R_SPARC_M44 51 /* Direct mid 22 of 44 bit */
+#define R_SPARC_L44 52 /* Direct low 10 of 44 bit */
+#define R_SPARC_REGISTER 53 /* Global register usage */
+#define R_SPARC_UA64 54 /* Direct 64 bit unaligned */
+#define R_SPARC_UA16 55 /* Direct 16 bit unaligned */
+#define R_SPARC_TLS_GD_HI22 56
+#define R_SPARC_TLS_GD_LO10 57
+#define R_SPARC_TLS_GD_ADD 58
+#define R_SPARC_TLS_GD_CALL 59
+#define R_SPARC_TLS_LDM_HI22 60
+#define R_SPARC_TLS_LDM_LO10 61
+#define R_SPARC_TLS_LDM_ADD 62
+#define R_SPARC_TLS_LDM_CALL 63
+#define R_SPARC_TLS_LDO_HIX22 64
+#define R_SPARC_TLS_LDO_LOX10 65
+#define R_SPARC_TLS_LDO_ADD 66
+#define R_SPARC_TLS_IE_HI22 67
+#define R_SPARC_TLS_IE_LO10 68
+#define R_SPARC_TLS_IE_LD 69
+#define R_SPARC_TLS_IE_LDX 70
+#define R_SPARC_TLS_IE_ADD 71
+#define R_SPARC_TLS_LE_HIX22 72
+#define R_SPARC_TLS_LE_LOX10 73
+#define R_SPARC_TLS_DTPMOD32 74
+#define R_SPARC_TLS_DTPMOD64 75
+#define R_SPARC_TLS_DTPOFF32 76
+#define R_SPARC_TLS_DTPOFF64 77
+#define R_SPARC_TLS_TPOFF32 78
+#define R_SPARC_TLS_TPOFF64 79
+#define R_SPARC_GOTDATA_HIX22 80
+#define R_SPARC_GOTDATA_LOX10 81
+#define R_SPARC_GOTDATA_OP_HIX22 82
+#define R_SPARC_GOTDATA_OP_LOX10 83
+#define R_SPARC_GOTDATA_OP 84
+#define R_SPARC_H34 85
+#define R_SPARC_SIZE32 86
+#define R_SPARC_SIZE64 87
+#define R_SPARC_JMP_IREL 248
+#define R_SPARC_IRELATIVE 249
+#define R_SPARC_GNU_VTINHERIT 250
+#define R_SPARC_GNU_VTENTRY 251
+#define R_SPARC_REV32 252
+/* Keep this the last entry. */
+#define R_SPARC_NUM 253
+
+/* For Sparc64, legal values for d_tag of Elf64_Dyn. */
+
+#define DT_SPARC_REGISTER 0x70000001
+#define DT_SPARC_NUM 2
+
+/* Bits present in AT_HWCAP on SPARC. */
+
+#define HWCAP_SPARC_FLUSH 1 /* The CPU supports flush insn. */
+#define HWCAP_SPARC_STBAR 2
+#define HWCAP_SPARC_SWAP 4
+#define HWCAP_SPARC_MULDIV 8
+#define HWCAP_SPARC_V9 16 /* The CPU is v9, so v8plus is ok. */
+#define HWCAP_SPARC_ULTRA3 32
+#define HWCAP_SPARC_BLKINIT 64 /* Sun4v with block-init/load-twin. */
+#define HWCAP_SPARC_N2 128
+
+/* MIPS R3000 specific definitions. */
+
+/* Legal values for e_flags field of Elf32_Ehdr. */
+
+#define EF_MIPS_NOREORDER 1 /* A .noreorder directive was used */
+#define EF_MIPS_PIC 2 /* Contains PIC code */
+#define EF_MIPS_CPIC 4 /* Uses PIC calling sequence */
+#define EF_MIPS_XGOT 8
+#define EF_MIPS_64BIT_WHIRL 16
+#define EF_MIPS_ABI2 32
+#define EF_MIPS_ABI_ON32 64
+#define EF_MIPS_ARCH 0xf0000000 /* MIPS architecture level */
+
+/* Legal values for MIPS architecture level. */
+
+#define EF_MIPS_ARCH_1 0x00000000 /* -mips1 code. */
+#define EF_MIPS_ARCH_2 0x10000000 /* -mips2 code. */
+#define EF_MIPS_ARCH_3 0x20000000 /* -mips3 code. */
+#define EF_MIPS_ARCH_4 0x30000000 /* -mips4 code. */
+#define EF_MIPS_ARCH_5 0x40000000 /* -mips5 code. */
+#define EF_MIPS_ARCH_32 0x60000000 /* MIPS32 code. */
+#define EF_MIPS_ARCH_64 0x70000000 /* MIPS64 code. */
+
+/* The following are non-official names and should not be used. */
+
+#define E_MIPS_ARCH_1 0x00000000 /* -mips1 code. */
+#define E_MIPS_ARCH_2 0x10000000 /* -mips2 code. */
+#define E_MIPS_ARCH_3 0x20000000 /* -mips3 code. */
+#define E_MIPS_ARCH_4 0x30000000 /* -mips4 code. */
+#define E_MIPS_ARCH_5 0x40000000 /* -mips5 code. */
+#define E_MIPS_ARCH_32 0x60000000 /* MIPS32 code. */
+#define E_MIPS_ARCH_64 0x70000000 /* MIPS64 code. */
+
+/* Special section indices. */
+
+#define SHN_MIPS_ACOMMON 0xff00 /* Allocated common symbols */
+#define SHN_MIPS_TEXT 0xff01 /* Allocated test symbols. */
+#define SHN_MIPS_DATA 0xff02 /* Allocated data symbols. */
+#define SHN_MIPS_SCOMMON 0xff03 /* Small common symbols */
+#define SHN_MIPS_SUNDEFINED 0xff04 /* Small undefined symbols */
+
+/* Legal values for sh_type field of Elf32_Shdr. */
+
+#define SHT_MIPS_LIBLIST 0x70000000 /* Shared objects used in link */
+#define SHT_MIPS_MSYM 0x70000001
+#define SHT_MIPS_CONFLICT 0x70000002 /* Conflicting symbols */
+#define SHT_MIPS_GPTAB 0x70000003 /* Global data area sizes */
+#define SHT_MIPS_UCODE 0x70000004 /* Reserved for SGI/MIPS compilers */
+#define SHT_MIPS_DEBUG 0x70000005 /* MIPS ECOFF debugging information*/
+#define SHT_MIPS_REGINFO 0x70000006 /* Register usage information */
+#define SHT_MIPS_PACKAGE 0x70000007
+#define SHT_MIPS_PACKSYM 0x70000008
+#define SHT_MIPS_RELD 0x70000009
+#define SHT_MIPS_IFACE 0x7000000b
+#define SHT_MIPS_CONTENT 0x7000000c
+#define SHT_MIPS_OPTIONS 0x7000000d /* Miscellaneous options. */
+#define SHT_MIPS_SHDR 0x70000010
+#define SHT_MIPS_FDESC 0x70000011
+#define SHT_MIPS_EXTSYM 0x70000012
+#define SHT_MIPS_DENSE 0x70000013
+#define SHT_MIPS_PDESC 0x70000014
+#define SHT_MIPS_LOCSYM 0x70000015
+#define SHT_MIPS_AUXSYM 0x70000016
+#define SHT_MIPS_OPTSYM 0x70000017
+#define SHT_MIPS_LOCSTR 0x70000018
+#define SHT_MIPS_LINE 0x70000019
+#define SHT_MIPS_RFDESC 0x7000001a
+#define SHT_MIPS_DELTASYM 0x7000001b
+#define SHT_MIPS_DELTAINST 0x7000001c
+#define SHT_MIPS_DELTACLASS 0x7000001d
+#define SHT_MIPS_DWARF 0x7000001e /* DWARF debugging information. */
+#define SHT_MIPS_DELTADECL 0x7000001f
+#define SHT_MIPS_SYMBOL_LIB 0x70000020
+#define SHT_MIPS_EVENTS 0x70000021 /* Event section. */
+#define SHT_MIPS_TRANSLATE 0x70000022
+#define SHT_MIPS_PIXIE 0x70000023
+#define SHT_MIPS_XLATE 0x70000024
+#define SHT_MIPS_XLATE_DEBUG 0x70000025
+#define SHT_MIPS_WHIRL 0x70000026
+#define SHT_MIPS_EH_REGION 0x70000027
+#define SHT_MIPS_XLATE_OLD 0x70000028
+#define SHT_MIPS_PDR_EXCEPTION 0x70000029
+
+/* Legal values for sh_flags field of Elf32_Shdr. */
+
+#define SHF_MIPS_GPREL 0x10000000 /* Must be part of global data area */
+#define SHF_MIPS_MERGE 0x20000000
+#define SHF_MIPS_ADDR 0x40000000
+#define SHF_MIPS_STRINGS 0x80000000
+#define SHF_MIPS_NOSTRIP 0x08000000
+#define SHF_MIPS_LOCAL 0x04000000
+#define SHF_MIPS_NAMES 0x02000000
+#define SHF_MIPS_NODUPE 0x01000000
+
+
+/* Symbol tables. */
+
+/* MIPS specific values for `st_other'. */
+#define STO_MIPS_DEFAULT 0x0
+#define STO_MIPS_INTERNAL 0x1
+#define STO_MIPS_HIDDEN 0x2
+#define STO_MIPS_PROTECTED 0x3
+#define STO_MIPS_PLT 0x8
+#define STO_MIPS_SC_ALIGN_UNUSED 0xff
+
+/* MIPS specific values for `st_info'. */
+#define STB_MIPS_SPLIT_COMMON 13
+
+/* Entries found in sections of type SHT_MIPS_GPTAB. */
+
+typedef union
+{
+ struct
+ {
+ Elf32_Word gt_current_g_value; /* -G value used for compilation */
+ Elf32_Word gt_unused; /* Not used */
+ } gt_header; /* First entry in section */
+ struct
+ {
+ Elf32_Word gt_g_value; /* If this value were used for -G */
+ Elf32_Word gt_bytes; /* This many bytes would be used */
+ } gt_entry; /* Subsequent entries in section */
+} Elf32_gptab;
+
+/* Entry found in sections of type SHT_MIPS_REGINFO. */
+
+typedef struct
+{
+ Elf32_Word ri_gprmask; /* General registers used */
+ Elf32_Word ri_cprmask[4]; /* Coprocessor registers used */
+ Elf32_Sword ri_gp_value; /* $gp register value */
+} Elf32_RegInfo;
+
+/* Entries found in sections of type SHT_MIPS_OPTIONS. */
+
+typedef struct
+{
+ unsigned char kind; /* Determines interpretation of the
+ variable part of descriptor. */
+ unsigned char size; /* Size of descriptor, including header. */
+ Elf32_Section section; /* Section header index of section affected,
+ 0 for global options. */
+ Elf32_Word info; /* Kind-specific information. */
+} Elf_Options;
+
+/* Values for `kind' field in Elf_Options. */
+
+#define ODK_NULL 0 /* Undefined. */
+#define ODK_REGINFO 1 /* Register usage information. */
+#define ODK_EXCEPTIONS 2 /* Exception processing options. */
+#define ODK_PAD 3 /* Section padding options. */
+#define ODK_HWPATCH 4 /* Hardware workarounds performed */
+#define ODK_FILL 5 /* record the fill value used by the linker. */
+#define ODK_TAGS 6 /* reserve space for desktop tools to write. */
+#define ODK_HWAND 7 /* HW workarounds. 'AND' bits when merging. */
+#define ODK_HWOR 8 /* HW workarounds. 'OR' bits when merging. */
+
+/* Values for `info' in Elf_Options for ODK_EXCEPTIONS entries. */
+
+#define OEX_FPU_MIN 0x1f /* FPE's which MUST be enabled. */
+#define OEX_FPU_MAX 0x1f00 /* FPE's which MAY be enabled. */
+#define OEX_PAGE0 0x10000 /* page zero must be mapped. */
+#define OEX_SMM 0x20000 /* Force sequential memory mode? */
+#define OEX_FPDBUG 0x40000 /* Force floating point debug mode? */
+#define OEX_PRECISEFP OEX_FPDBUG
+#define OEX_DISMISS 0x80000 /* Dismiss invalid address faults? */
+
+#define OEX_FPU_INVAL 0x10
+#define OEX_FPU_DIV0 0x08
+#define OEX_FPU_OFLO 0x04
+#define OEX_FPU_UFLO 0x02
+#define OEX_FPU_INEX 0x01
+
+/* Masks for `info' in Elf_Options for an ODK_HWPATCH entry. */
+
+#define OHW_R4KEOP 0x1 /* R4000 end-of-page patch. */
+#define OHW_R8KPFETCH 0x2 /* may need R8000 prefetch patch. */
+#define OHW_R5KEOP 0x4 /* R5000 end-of-page patch. */
+#define OHW_R5KCVTL 0x8 /* R5000 cvt.[ds].l bug. clean=1. */
+
+#define OPAD_PREFIX 0x1
+#define OPAD_POSTFIX 0x2
+#define OPAD_SYMBOL 0x4
+
+/* Entry found in `.options' section. */
+
+typedef struct
+{
+ Elf32_Word hwp_flags1; /* Extra flags. */
+ Elf32_Word hwp_flags2; /* Extra flags. */
+} Elf_Options_Hw;
+
+/* Masks for `info' in ElfOptions for ODK_HWAND and ODK_HWOR entries. */
+
+#define OHWA0_R4KEOP_CHECKED 0x00000001
+#define OHWA1_R4KEOP_CLEAN 0x00000002
+
+/* MIPS relocs. */
+
+#define R_MIPS_NONE 0 /* No reloc */
+#define R_MIPS_16 1 /* Direct 16 bit */
+#define R_MIPS_32 2 /* Direct 32 bit */
+#define R_MIPS_REL32 3 /* PC relative 32 bit */
+#define R_MIPS_26 4 /* Direct 26 bit shifted */
+#define R_MIPS_HI16 5 /* High 16 bit */
+#define R_MIPS_LO16 6 /* Low 16 bit */
+#define R_MIPS_GPREL16 7 /* GP relative 16 bit */
+#define R_MIPS_LITERAL 8 /* 16 bit literal entry */
+#define R_MIPS_GOT16 9 /* 16 bit GOT entry */
+#define R_MIPS_PC16 10 /* PC relative 16 bit */
+#define R_MIPS_CALL16 11 /* 16 bit GOT entry for function */
+#define R_MIPS_GPREL32 12 /* GP relative 32 bit */
+
+#define R_MIPS_SHIFT5 16
+#define R_MIPS_SHIFT6 17
+#define R_MIPS_64 18
+#define R_MIPS_GOT_DISP 19
+#define R_MIPS_GOT_PAGE 20
+#define R_MIPS_GOT_OFST 21
+#define R_MIPS_GOT_HI16 22
+#define R_MIPS_GOT_LO16 23
+#define R_MIPS_SUB 24
+#define R_MIPS_INSERT_A 25
+#define R_MIPS_INSERT_B 26
+#define R_MIPS_DELETE 27
+#define R_MIPS_HIGHER 28
+#define R_MIPS_HIGHEST 29
+#define R_MIPS_CALL_HI16 30
+#define R_MIPS_CALL_LO16 31
+#define R_MIPS_SCN_DISP 32
+#define R_MIPS_REL16 33
+#define R_MIPS_ADD_IMMEDIATE 34
+#define R_MIPS_PJUMP 35
+#define R_MIPS_RELGOT 36
+#define R_MIPS_JALR 37
+#define R_MIPS_TLS_DTPMOD32 38 /* Module number 32 bit */
+#define R_MIPS_TLS_DTPREL32 39 /* Module-relative offset 32 bit */
+#define R_MIPS_TLS_DTPMOD64 40 /* Module number 64 bit */
+#define R_MIPS_TLS_DTPREL64 41 /* Module-relative offset 64 bit */
+#define R_MIPS_TLS_GD 42 /* 16 bit GOT offset for GD */
+#define R_MIPS_TLS_LDM 43 /* 16 bit GOT offset for LDM */
+#define R_MIPS_TLS_DTPREL_HI16 44 /* Module-relative offset, high 16 bits */
+#define R_MIPS_TLS_DTPREL_LO16 45 /* Module-relative offset, low 16 bits */
+#define R_MIPS_TLS_GOTTPREL 46 /* 16 bit GOT offset for IE */
+#define R_MIPS_TLS_TPREL32 47 /* TP-relative offset, 32 bit */
+#define R_MIPS_TLS_TPREL64 48 /* TP-relative offset, 64 bit */
+#define R_MIPS_TLS_TPREL_HI16 49 /* TP-relative offset, high 16 bits */
+#define R_MIPS_TLS_TPREL_LO16 50 /* TP-relative offset, low 16 bits */
+#define R_MIPS_GLOB_DAT 51
+#define R_MIPS_COPY 126
+#define R_MIPS_JUMP_SLOT 127
+/* Keep this the last entry. */
+#define R_MIPS_NUM 128
+
+/* Legal values for p_type field of Elf32_Phdr. */
+
+#define PT_MIPS_REGINFO 0x70000000 /* Register usage information */
+#define PT_MIPS_RTPROC 0x70000001 /* Runtime procedure table. */
+#define PT_MIPS_OPTIONS 0x70000002
+
+/* Special program header types. */
+
+#define PF_MIPS_LOCAL 0x10000000
+
+/* Legal values for d_tag field of Elf32_Dyn. */
+
+#define DT_MIPS_RLD_VERSION 0x70000001 /* Runtime linker interface version */
+#define DT_MIPS_TIME_STAMP 0x70000002 /* Timestamp */
+#define DT_MIPS_ICHECKSUM 0x70000003 /* Checksum */
+#define DT_MIPS_IVERSION 0x70000004 /* Version string (string tbl index) */
+#define DT_MIPS_FLAGS 0x70000005 /* Flags */
+#define DT_MIPS_BASE_ADDRESS 0x70000006 /* Base address */
+#define DT_MIPS_MSYM 0x70000007
+#define DT_MIPS_CONFLICT 0x70000008 /* Address of CONFLICT section */
+#define DT_MIPS_LIBLIST 0x70000009 /* Address of LIBLIST section */
+#define DT_MIPS_LOCAL_GOTNO 0x7000000a /* Number of local GOT entries */
+#define DT_MIPS_CONFLICTNO 0x7000000b /* Number of CONFLICT entries */
+#define DT_MIPS_LIBLISTNO 0x70000010 /* Number of LIBLIST entries */
+#define DT_MIPS_SYMTABNO 0x70000011 /* Number of DYNSYM entries */
+#define DT_MIPS_UNREFEXTNO 0x70000012 /* First external DYNSYM */
+#define DT_MIPS_GOTSYM 0x70000013 /* First GOT entry in DYNSYM */
+#define DT_MIPS_HIPAGENO 0x70000014 /* Number of GOT page table entries */
+#define DT_MIPS_RLD_MAP 0x70000016 /* Address of run time loader map. */
+#define DT_MIPS_DELTA_CLASS 0x70000017 /* Delta C++ class definition. */
+#define DT_MIPS_DELTA_CLASS_NO 0x70000018 /* Number of entries in
+ DT_MIPS_DELTA_CLASS. */
+#define DT_MIPS_DELTA_INSTANCE 0x70000019 /* Delta C++ class instances. */
+#define DT_MIPS_DELTA_INSTANCE_NO 0x7000001a /* Number of entries in
+ DT_MIPS_DELTA_INSTANCE. */
+#define DT_MIPS_DELTA_RELOC 0x7000001b /* Delta relocations. */
+#define DT_MIPS_DELTA_RELOC_NO 0x7000001c /* Number of entries in
+ DT_MIPS_DELTA_RELOC. */
+#define DT_MIPS_DELTA_SYM 0x7000001d /* Delta symbols that Delta
+ relocations refer to. */
+#define DT_MIPS_DELTA_SYM_NO 0x7000001e /* Number of entries in
+ DT_MIPS_DELTA_SYM. */
+#define DT_MIPS_DELTA_CLASSSYM 0x70000020 /* Delta symbols that hold the
+ class declaration. */
+#define DT_MIPS_DELTA_CLASSSYM_NO 0x70000021 /* Number of entries in
+ DT_MIPS_DELTA_CLASSSYM. */
+#define DT_MIPS_CXX_FLAGS 0x70000022 /* Flags indicating for C++ flavor. */
+#define DT_MIPS_PIXIE_INIT 0x70000023
+#define DT_MIPS_SYMBOL_LIB 0x70000024
+#define DT_MIPS_LOCALPAGE_GOTIDX 0x70000025
+#define DT_MIPS_LOCAL_GOTIDX 0x70000026
+#define DT_MIPS_HIDDEN_GOTIDX 0x70000027
+#define DT_MIPS_PROTECTED_GOTIDX 0x70000028
+#define DT_MIPS_OPTIONS 0x70000029 /* Address of .options. */
+#define DT_MIPS_INTERFACE 0x7000002a /* Address of .interface. */
+#define DT_MIPS_DYNSTR_ALIGN 0x7000002b
+#define DT_MIPS_INTERFACE_SIZE 0x7000002c /* Size of the .interface section. */
+#define DT_MIPS_RLD_TEXT_RESOLVE_ADDR 0x7000002d /* Address of rld_text_rsolve
+ function stored in GOT. */
+#define DT_MIPS_PERF_SUFFIX 0x7000002e /* Default suffix of dso to be added
+ by rld on dlopen() calls. */
+#define DT_MIPS_COMPACT_SIZE 0x7000002f /* (O32)Size of compact rel section. */
+#define DT_MIPS_GP_VALUE 0x70000030 /* GP value for aux GOTs. */
+#define DT_MIPS_AUX_DYNAMIC 0x70000031 /* Address of aux .dynamic. */
+/* The address of .got.plt in an executable using the new non-PIC ABI. */
+#define DT_MIPS_PLTGOT 0x70000032
+/* The base of the PLT in an executable using the new non-PIC ABI if that
+ PLT is writable. For a non-writable PLT, this is omitted or has a zero
+ value. */
+#define DT_MIPS_RWPLT 0x70000034
+#define DT_MIPS_NUM 0x35
+
+/* Legal values for DT_MIPS_FLAGS Elf32_Dyn entry. */
+
+#define RHF_NONE 0 /* No flags */
+#define RHF_QUICKSTART (1 << 0) /* Use quickstart */
+#define RHF_NOTPOT (1 << 1) /* Hash size not power of 2 */
+#define RHF_NO_LIBRARY_REPLACEMENT (1 << 2) /* Ignore LD_LIBRARY_PATH */
+#define RHF_NO_MOVE (1 << 3)
+#define RHF_SGI_ONLY (1 << 4)
+#define RHF_GUARANTEE_INIT (1 << 5)
+#define RHF_DELTA_C_PLUS_PLUS (1 << 6)
+#define RHF_GUARANTEE_START_INIT (1 << 7)
+#define RHF_PIXIE (1 << 8)
+#define RHF_DEFAULT_DELAY_LOAD (1 << 9)
+#define RHF_REQUICKSTART (1 << 10)
+#define RHF_REQUICKSTARTED (1 << 11)
+#define RHF_CORD (1 << 12)
+#define RHF_NO_UNRES_UNDEF (1 << 13)
+#define RHF_RLD_ORDER_SAFE (1 << 14)
+
+/* Entries found in sections of type SHT_MIPS_LIBLIST. */
+
+typedef struct
+{
+ Elf32_Word l_name; /* Name (string table index) */
+ Elf32_Word l_time_stamp; /* Timestamp */
+ Elf32_Word l_checksum; /* Checksum */
+ Elf32_Word l_version; /* Interface version */
+ Elf32_Word l_flags; /* Flags */
+} Elf32_Lib;
+
+typedef struct
+{
+ Elf64_Word l_name; /* Name (string table index) */
+ Elf64_Word l_time_stamp; /* Timestamp */
+ Elf64_Word l_checksum; /* Checksum */
+ Elf64_Word l_version; /* Interface version */
+ Elf64_Word l_flags; /* Flags */
+} Elf64_Lib;
+
+
+/* Legal values for l_flags. */
+
+#define LL_NONE 0
+#define LL_EXACT_MATCH (1 << 0) /* Require exact match */
+#define LL_IGNORE_INT_VER (1 << 1) /* Ignore interface version */
+#define LL_REQUIRE_MINOR (1 << 2)
+#define LL_EXPORTS (1 << 3)
+#define LL_DELAY_LOAD (1 << 4)
+#define LL_DELTA (1 << 5)
+
+/* Entries found in sections of type SHT_MIPS_CONFLICT. */
+
+typedef Elf32_Addr Elf32_Conflict;
+
+
+/* HPPA specific definitions. */
+
+/* Legal values for e_flags field of Elf32_Ehdr. */
+
+#define EF_PARISC_TRAPNIL 0x00010000 /* Trap nil pointer dereference. */
+#define EF_PARISC_EXT 0x00020000 /* Program uses arch. extensions. */
+#define EF_PARISC_LSB 0x00040000 /* Program expects little endian. */
+#define EF_PARISC_WIDE 0x00080000 /* Program expects wide mode. */
+#define EF_PARISC_NO_KABP 0x00100000 /* No kernel assisted branch
+ prediction. */
+#define EF_PARISC_LAZYSWAP 0x00400000 /* Allow lazy swapping. */
+#define EF_PARISC_ARCH 0x0000ffff /* Architecture version. */
+
+/* Defined values for `e_flags & EF_PARISC_ARCH' are: */
+
+#define EFA_PARISC_1_0 0x020b /* PA-RISC 1.0 big-endian. */
+#define EFA_PARISC_1_1 0x0210 /* PA-RISC 1.1 big-endian. */
+#define EFA_PARISC_2_0 0x0214 /* PA-RISC 2.0 big-endian. */
+
+/* Additional section indeces. */
+
+#define SHN_PARISC_ANSI_COMMON 0xff00 /* Section for tenatively declared
+ symbols in ANSI C. */
+#define SHN_PARISC_HUGE_COMMON 0xff01 /* Common blocks in huge model. */
+
+/* Legal values for sh_type field of Elf32_Shdr. */
+
+#define SHT_PARISC_EXT 0x70000000 /* Contains product specific ext. */
+#define SHT_PARISC_UNWIND 0x70000001 /* Unwind information. */
+#define SHT_PARISC_DOC 0x70000002 /* Debug info for optimized code. */
+
+/* Legal values for sh_flags field of Elf32_Shdr. */
+
+#define SHF_PARISC_SHORT 0x20000000 /* Section with short addressing. */
+#define SHF_PARISC_HUGE 0x40000000 /* Section far from gp. */
+#define SHF_PARISC_SBP 0x80000000 /* Static branch prediction code. */
+
+/* Legal values for ST_TYPE subfield of st_info (symbol type). */
+
+#define STT_PARISC_MILLICODE 13 /* Millicode function entry point. */
+
+#define STT_HP_OPAQUE (STT_LOOS + 0x1)
+#define STT_HP_STUB (STT_LOOS + 0x2)
+
+/* HPPA relocs. */
+
+#define R_PARISC_NONE 0 /* No reloc. */
+#define R_PARISC_DIR32 1 /* Direct 32-bit reference. */
+#define R_PARISC_DIR21L 2 /* Left 21 bits of eff. address. */
+#define R_PARISC_DIR17R 3 /* Right 17 bits of eff. address. */
+#define R_PARISC_DIR17F 4 /* 17 bits of eff. address. */
+#define R_PARISC_DIR14R 6 /* Right 14 bits of eff. address. */
+#define R_PARISC_PCREL32 9 /* 32-bit rel. address. */
+#define R_PARISC_PCREL21L 10 /* Left 21 bits of rel. address. */
+#define R_PARISC_PCREL17R 11 /* Right 17 bits of rel. address. */
+#define R_PARISC_PCREL17F 12 /* 17 bits of rel. address. */
+#define R_PARISC_PCREL14R 14 /* Right 14 bits of rel. address. */
+#define R_PARISC_DPREL21L 18 /* Left 21 bits of rel. address. */
+#define R_PARISC_DPREL14R 22 /* Right 14 bits of rel. address. */
+#define R_PARISC_GPREL21L 26 /* GP-relative, left 21 bits. */
+#define R_PARISC_GPREL14R 30 /* GP-relative, right 14 bits. */
+#define R_PARISC_LTOFF21L 34 /* LT-relative, left 21 bits. */
+#define R_PARISC_LTOFF14R 38 /* LT-relative, right 14 bits. */
+#define R_PARISC_SECREL32 41 /* 32 bits section rel. address. */
+#define R_PARISC_SEGBASE 48 /* No relocation, set segment base. */
+#define R_PARISC_SEGREL32 49 /* 32 bits segment rel. address. */
+#define R_PARISC_PLTOFF21L 50 /* PLT rel. address, left 21 bits. */
+#define R_PARISC_PLTOFF14R 54 /* PLT rel. address, right 14 bits. */
+#define R_PARISC_LTOFF_FPTR32 57 /* 32 bits LT-rel. function pointer. */
+#define R_PARISC_LTOFF_FPTR21L 58 /* LT-rel. fct ptr, left 21 bits. */
+#define R_PARISC_LTOFF_FPTR14R 62 /* LT-rel. fct ptr, right 14 bits. */
+#define R_PARISC_FPTR64 64 /* 64 bits function address. */
+#define R_PARISC_PLABEL32 65 /* 32 bits function address. */
+#define R_PARISC_PLABEL21L 66 /* Left 21 bits of fdesc address. */
+#define R_PARISC_PLABEL14R 70 /* Right 14 bits of fdesc address. */
+#define R_PARISC_PCREL64 72 /* 64 bits PC-rel. address. */
+#define R_PARISC_PCREL22F 74 /* 22 bits PC-rel. address. */
+#define R_PARISC_PCREL14WR 75 /* PC-rel. address, right 14 bits. */
+#define R_PARISC_PCREL14DR 76 /* PC rel. address, right 14 bits. */
+#define R_PARISC_PCREL16F 77 /* 16 bits PC-rel. address. */
+#define R_PARISC_PCREL16WF 78 /* 16 bits PC-rel. address. */
+#define R_PARISC_PCREL16DF 79 /* 16 bits PC-rel. address. */
+#define R_PARISC_DIR64 80 /* 64 bits of eff. address. */
+#define R_PARISC_DIR14WR 83 /* 14 bits of eff. address. */
+#define R_PARISC_DIR14DR 84 /* 14 bits of eff. address. */
+#define R_PARISC_DIR16F 85 /* 16 bits of eff. address. */
+#define R_PARISC_DIR16WF 86 /* 16 bits of eff. address. */
+#define R_PARISC_DIR16DF 87 /* 16 bits of eff. address. */
+#define R_PARISC_GPREL64 88 /* 64 bits of GP-rel. address. */
+#define R_PARISC_GPREL14WR 91 /* GP-rel. address, right 14 bits. */
+#define R_PARISC_GPREL14DR 92 /* GP-rel. address, right 14 bits. */
+#define R_PARISC_GPREL16F 93 /* 16 bits GP-rel. address. */
+#define R_PARISC_GPREL16WF 94 /* 16 bits GP-rel. address. */
+#define R_PARISC_GPREL16DF 95 /* 16 bits GP-rel. address. */
+#define R_PARISC_LTOFF64 96 /* 64 bits LT-rel. address. */
+#define R_PARISC_LTOFF14WR 99 /* LT-rel. address, right 14 bits. */
+#define R_PARISC_LTOFF14DR 100 /* LT-rel. address, right 14 bits. */
+#define R_PARISC_LTOFF16F 101 /* 16 bits LT-rel. address. */
+#define R_PARISC_LTOFF16WF 102 /* 16 bits LT-rel. address. */
+#define R_PARISC_LTOFF16DF 103 /* 16 bits LT-rel. address. */
+#define R_PARISC_SECREL64 104 /* 64 bits section rel. address. */
+#define R_PARISC_SEGREL64 112 /* 64 bits segment rel. address. */
+#define R_PARISC_PLTOFF14WR 115 /* PLT-rel. address, right 14 bits. */
+#define R_PARISC_PLTOFF14DR 116 /* PLT-rel. address, right 14 bits. */
+#define R_PARISC_PLTOFF16F 117 /* 16 bits LT-rel. address. */
+#define R_PARISC_PLTOFF16WF 118 /* 16 bits PLT-rel. address. */
+#define R_PARISC_PLTOFF16DF 119 /* 16 bits PLT-rel. address. */
+#define R_PARISC_LTOFF_FPTR64 120 /* 64 bits LT-rel. function ptr. */
+#define R_PARISC_LTOFF_FPTR14WR 123 /* LT-rel. fct. ptr., right 14 bits. */
+#define R_PARISC_LTOFF_FPTR14DR 124 /* LT-rel. fct. ptr., right 14 bits. */
+#define R_PARISC_LTOFF_FPTR16F 125 /* 16 bits LT-rel. function ptr. */
+#define R_PARISC_LTOFF_FPTR16WF 126 /* 16 bits LT-rel. function ptr. */
+#define R_PARISC_LTOFF_FPTR16DF 127 /* 16 bits LT-rel. function ptr. */
+#define R_PARISC_LORESERVE 128
+#define R_PARISC_COPY 128 /* Copy relocation. */
+#define R_PARISC_IPLT 129 /* Dynamic reloc, imported PLT */
+#define R_PARISC_EPLT 130 /* Dynamic reloc, exported PLT */
+#define R_PARISC_TPREL32 153 /* 32 bits TP-rel. address. */
+#define R_PARISC_TPREL21L 154 /* TP-rel. address, left 21 bits. */
+#define R_PARISC_TPREL14R 158 /* TP-rel. address, right 14 bits. */
+#define R_PARISC_LTOFF_TP21L 162 /* LT-TP-rel. address, left 21 bits. */
+#define R_PARISC_LTOFF_TP14R 166 /* LT-TP-rel. address, right 14 bits.*/
+#define R_PARISC_LTOFF_TP14F 167 /* 14 bits LT-TP-rel. address. */
+#define R_PARISC_TPREL64 216 /* 64 bits TP-rel. address. */
+#define R_PARISC_TPREL14WR 219 /* TP-rel. address, right 14 bits. */
+#define R_PARISC_TPREL14DR 220 /* TP-rel. address, right 14 bits. */
+#define R_PARISC_TPREL16F 221 /* 16 bits TP-rel. address. */
+#define R_PARISC_TPREL16WF 222 /* 16 bits TP-rel. address. */
+#define R_PARISC_TPREL16DF 223 /* 16 bits TP-rel. address. */
+#define R_PARISC_LTOFF_TP64 224 /* 64 bits LT-TP-rel. address. */
+#define R_PARISC_LTOFF_TP14WR 227 /* LT-TP-rel. address, right 14 bits.*/
+#define R_PARISC_LTOFF_TP14DR 228 /* LT-TP-rel. address, right 14 bits.*/
+#define R_PARISC_LTOFF_TP16F 229 /* 16 bits LT-TP-rel. address. */
+#define R_PARISC_LTOFF_TP16WF 230 /* 16 bits LT-TP-rel. address. */
+#define R_PARISC_LTOFF_TP16DF 231 /* 16 bits LT-TP-rel. address. */
+#define R_PARISC_GNU_VTENTRY 232
+#define R_PARISC_GNU_VTINHERIT 233
+#define R_PARISC_TLS_GD21L 234 /* GD 21-bit left. */
+#define R_PARISC_TLS_GD14R 235 /* GD 14-bit right. */
+#define R_PARISC_TLS_GDCALL 236 /* GD call to __t_g_a. */
+#define R_PARISC_TLS_LDM21L 237 /* LD module 21-bit left. */
+#define R_PARISC_TLS_LDM14R 238 /* LD module 14-bit right. */
+#define R_PARISC_TLS_LDMCALL 239 /* LD module call to __t_g_a. */
+#define R_PARISC_TLS_LDO21L 240 /* LD offset 21-bit left. */
+#define R_PARISC_TLS_LDO14R 241 /* LD offset 14-bit right. */
+#define R_PARISC_TLS_DTPMOD32 242 /* DTP module 32-bit. */
+#define R_PARISC_TLS_DTPMOD64 243 /* DTP module 64-bit. */
+#define R_PARISC_TLS_DTPOFF32 244 /* DTP offset 32-bit. */
+#define R_PARISC_TLS_DTPOFF64 245 /* DTP offset 32-bit. */
+#define R_PARISC_TLS_LE21L R_PARISC_TPREL21L
+#define R_PARISC_TLS_LE14R R_PARISC_TPREL14R
+#define R_PARISC_TLS_IE21L R_PARISC_LTOFF_TP21L
+#define R_PARISC_TLS_IE14R R_PARISC_LTOFF_TP14R
+#define R_PARISC_TLS_TPREL32 R_PARISC_TPREL32
+#define R_PARISC_TLS_TPREL64 R_PARISC_TPREL64
+#define R_PARISC_HIRESERVE 255
+
+/* Legal values for p_type field of Elf32_Phdr/Elf64_Phdr. */
+
+#define PT_HP_TLS (PT_LOOS + 0x0)
+#define PT_HP_CORE_NONE (PT_LOOS + 0x1)
+#define PT_HP_CORE_VERSION (PT_LOOS + 0x2)
+#define PT_HP_CORE_KERNEL (PT_LOOS + 0x3)
+#define PT_HP_CORE_COMM (PT_LOOS + 0x4)
+#define PT_HP_CORE_PROC (PT_LOOS + 0x5)
+#define PT_HP_CORE_LOADABLE (PT_LOOS + 0x6)
+#define PT_HP_CORE_STACK (PT_LOOS + 0x7)
+#define PT_HP_CORE_SHM (PT_LOOS + 0x8)
+#define PT_HP_CORE_MMF (PT_LOOS + 0x9)
+#define PT_HP_PARALLEL (PT_LOOS + 0x10)
+#define PT_HP_FASTBIND (PT_LOOS + 0x11)
+#define PT_HP_OPT_ANNOT (PT_LOOS + 0x12)
+#define PT_HP_HSL_ANNOT (PT_LOOS + 0x13)
+#define PT_HP_STACK (PT_LOOS + 0x14)
+
+#define PT_PARISC_ARCHEXT 0x70000000
+#define PT_PARISC_UNWIND 0x70000001
+
+/* Legal values for p_flags field of Elf32_Phdr/Elf64_Phdr. */
+
+#define PF_PARISC_SBP 0x08000000
+
+#define PF_HP_PAGE_SIZE 0x00100000
+#define PF_HP_FAR_SHARED 0x00200000
+#define PF_HP_NEAR_SHARED 0x00400000
+#define PF_HP_CODE 0x01000000
+#define PF_HP_MODIFY 0x02000000
+#define PF_HP_LAZYSWAP 0x04000000
+#define PF_HP_SBP 0x08000000
+
+
+/* Alpha specific definitions. */
+
+/* Legal values for e_flags field of Elf64_Ehdr. */
+
+#define EF_ALPHA_32BIT 1 /* All addresses must be < 2GB. */
+#define EF_ALPHA_CANRELAX 2 /* Relocations for relaxing exist. */
+
+/* Legal values for sh_type field of Elf64_Shdr. */
+
+/* These two are primerily concerned with ECOFF debugging info. */
+#define SHT_ALPHA_DEBUG 0x70000001
+#define SHT_ALPHA_REGINFO 0x70000002
+
+/* Legal values for sh_flags field of Elf64_Shdr. */
+
+#define SHF_ALPHA_GPREL 0x10000000
+
+/* Legal values for st_other field of Elf64_Sym. */
+#define STO_ALPHA_NOPV 0x80 /* No PV required. */
+#define STO_ALPHA_STD_GPLOAD 0x88 /* PV only used for initial ldgp. */
+
+/* Alpha relocs. */
+
+#define R_ALPHA_NONE 0 /* No reloc */
+#define R_ALPHA_REFLONG 1 /* Direct 32 bit */
+#define R_ALPHA_REFQUAD 2 /* Direct 64 bit */
+#define R_ALPHA_GPREL32 3 /* GP relative 32 bit */
+#define R_ALPHA_LITERAL 4 /* GP relative 16 bit w/optimization */
+#define R_ALPHA_LITUSE 5 /* Optimization hint for LITERAL */
+#define R_ALPHA_GPDISP 6 /* Add displacement to GP */
+#define R_ALPHA_BRADDR 7 /* PC+4 relative 23 bit shifted */
+#define R_ALPHA_HINT 8 /* PC+4 relative 16 bit shifted */
+#define R_ALPHA_SREL16 9 /* PC relative 16 bit */
+#define R_ALPHA_SREL32 10 /* PC relative 32 bit */
+#define R_ALPHA_SREL64 11 /* PC relative 64 bit */
+#define R_ALPHA_GPRELHIGH 17 /* GP relative 32 bit, high 16 bits */
+#define R_ALPHA_GPRELLOW 18 /* GP relative 32 bit, low 16 bits */
+#define R_ALPHA_GPREL16 19 /* GP relative 16 bit */
+#define R_ALPHA_COPY 24 /* Copy symbol at runtime */
+#define R_ALPHA_GLOB_DAT 25 /* Create GOT entry */
+#define R_ALPHA_JMP_SLOT 26 /* Create PLT entry */
+#define R_ALPHA_RELATIVE 27 /* Adjust by program base */
+#define R_ALPHA_TLS_GD_HI 28
+#define R_ALPHA_TLSGD 29
+#define R_ALPHA_TLS_LDM 30
+#define R_ALPHA_DTPMOD64 31
+#define R_ALPHA_GOTDTPREL 32
+#define R_ALPHA_DTPREL64 33
+#define R_ALPHA_DTPRELHI 34
+#define R_ALPHA_DTPRELLO 35
+#define R_ALPHA_DTPREL16 36
+#define R_ALPHA_GOTTPREL 37
+#define R_ALPHA_TPREL64 38
+#define R_ALPHA_TPRELHI 39
+#define R_ALPHA_TPRELLO 40
+#define R_ALPHA_TPREL16 41
+/* Keep this the last entry. */
+#define R_ALPHA_NUM 46
+
+/* Magic values of the LITUSE relocation addend. */
+#define LITUSE_ALPHA_ADDR 0
+#define LITUSE_ALPHA_BASE 1
+#define LITUSE_ALPHA_BYTOFF 2
+#define LITUSE_ALPHA_JSR 3
+#define LITUSE_ALPHA_TLS_GD 4
+#define LITUSE_ALPHA_TLS_LDM 5
+
+/* Legal values for d_tag of Elf64_Dyn. */
+#define DT_ALPHA_PLTRO (DT_LOPROC + 0)
+#define DT_ALPHA_NUM 1
+
+/* PowerPC specific declarations */
+
+/* Values for Elf32/64_Ehdr.e_flags. */
+#define EF_PPC_EMB 0x80000000 /* PowerPC embedded flag */
+
+/* Cygnus local bits below */
+#define EF_PPC_RELOCATABLE 0x00010000 /* PowerPC -mrelocatable flag*/
+#define EF_PPC_RELOCATABLE_LIB 0x00008000 /* PowerPC -mrelocatable-lib
+ flag */
+
+/* PowerPC relocations defined by the ABIs */
+#define R_PPC_NONE 0
+#define R_PPC_ADDR32 1 /* 32bit absolute address */
+#define R_PPC_ADDR24 2 /* 26bit address, 2 bits ignored. */
+#define R_PPC_ADDR16 3 /* 16bit absolute address */
+#define R_PPC_ADDR16_LO 4 /* lower 16bit of absolute address */
+#define R_PPC_ADDR16_HI 5 /* high 16bit of absolute address */
+#define R_PPC_ADDR16_HA 6 /* adjusted high 16bit */
+#define R_PPC_ADDR14 7 /* 16bit address, 2 bits ignored */
+#define R_PPC_ADDR14_BRTAKEN 8
+#define R_PPC_ADDR14_BRNTAKEN 9
+#define R_PPC_REL24 10 /* PC relative 26 bit */
+#define R_PPC_REL14 11 /* PC relative 16 bit */
+#define R_PPC_REL14_BRTAKEN 12
+#define R_PPC_REL14_BRNTAKEN 13
+#define R_PPC_GOT16 14
+#define R_PPC_GOT16_LO 15
+#define R_PPC_GOT16_HI 16
+#define R_PPC_GOT16_HA 17
+#define R_PPC_PLTREL24 18
+#define R_PPC_COPY 19
+#define R_PPC_GLOB_DAT 20
+#define R_PPC_JMP_SLOT 21
+#define R_PPC_RELATIVE 22
+#define R_PPC_LOCAL24PC 23
+#define R_PPC_UADDR32 24
+#define R_PPC_UADDR16 25
+#define R_PPC_REL32 26
+#define R_PPC_PLT32 27
+#define R_PPC_PLTREL32 28
+#define R_PPC_PLT16_LO 29
+#define R_PPC_PLT16_HI 30
+#define R_PPC_PLT16_HA 31
+#define R_PPC_SDAREL16 32
+#define R_PPC_SECTOFF 33
+#define R_PPC_SECTOFF_LO 34
+#define R_PPC_SECTOFF_HI 35
+#define R_PPC_SECTOFF_HA 36
+
+/* PowerPC relocations defined for the TLS access ABI. */
+#define R_PPC_TLS 67 /* none (sym+add)@tls */
+#define R_PPC_DTPMOD32 68 /* word32 (sym+add)@dtpmod */
+#define R_PPC_TPREL16 69 /* half16* (sym+add)@tprel */
+#define R_PPC_TPREL16_LO 70 /* half16 (sym+add)@tprel@l */
+#define R_PPC_TPREL16_HI 71 /* half16 (sym+add)@tprel@h */
+#define R_PPC_TPREL16_HA 72 /* half16 (sym+add)@tprel@ha */
+#define R_PPC_TPREL32 73 /* word32 (sym+add)@tprel */
+#define R_PPC_DTPREL16 74 /* half16* (sym+add)@dtprel */
+#define R_PPC_DTPREL16_LO 75 /* half16 (sym+add)@dtprel@l */
+#define R_PPC_DTPREL16_HI 76 /* half16 (sym+add)@dtprel@h */
+#define R_PPC_DTPREL16_HA 77 /* half16 (sym+add)@dtprel@ha */
+#define R_PPC_DTPREL32 78 /* word32 (sym+add)@dtprel */
+#define R_PPC_GOT_TLSGD16 79 /* half16* (sym+add)@got@tlsgd */
+#define R_PPC_GOT_TLSGD16_LO 80 /* half16 (sym+add)@got@tlsgd@l */
+#define R_PPC_GOT_TLSGD16_HI 81 /* half16 (sym+add)@got@tlsgd@h */
+#define R_PPC_GOT_TLSGD16_HA 82 /* half16 (sym+add)@got@tlsgd@ha */
+#define R_PPC_GOT_TLSLD16 83 /* half16* (sym+add)@got@tlsld */
+#define R_PPC_GOT_TLSLD16_LO 84 /* half16 (sym+add)@got@tlsld@l */
+#define R_PPC_GOT_TLSLD16_HI 85 /* half16 (sym+add)@got@tlsld@h */
+#define R_PPC_GOT_TLSLD16_HA 86 /* half16 (sym+add)@got@tlsld@ha */
+#define R_PPC_GOT_TPREL16 87 /* half16* (sym+add)@got@tprel */
+#define R_PPC_GOT_TPREL16_LO 88 /* half16 (sym+add)@got@tprel@l */
+#define R_PPC_GOT_TPREL16_HI 89 /* half16 (sym+add)@got@tprel@h */
+#define R_PPC_GOT_TPREL16_HA 90 /* half16 (sym+add)@got@tprel@ha */
+#define R_PPC_GOT_DTPREL16 91 /* half16* (sym+add)@got@dtprel */
+#define R_PPC_GOT_DTPREL16_LO 92 /* half16* (sym+add)@got@dtprel@l */
+#define R_PPC_GOT_DTPREL16_HI 93 /* half16* (sym+add)@got@dtprel@h */
+#define R_PPC_GOT_DTPREL16_HA 94 /* half16* (sym+add)@got@dtprel@ha */
+
+/* The remaining relocs are from the Embedded ELF ABI, and are not
+ in the SVR4 ELF ABI. */
+#define R_PPC_EMB_NADDR32 101
+#define R_PPC_EMB_NADDR16 102
+#define R_PPC_EMB_NADDR16_LO 103
+#define R_PPC_EMB_NADDR16_HI 104
+#define R_PPC_EMB_NADDR16_HA 105
+#define R_PPC_EMB_SDAI16 106
+#define R_PPC_EMB_SDA2I16 107
+#define R_PPC_EMB_SDA2REL 108
+#define R_PPC_EMB_SDA21 109 /* 16 bit offset in SDA */
+#define R_PPC_EMB_MRKREF 110
+#define R_PPC_EMB_RELSEC16 111
+#define R_PPC_EMB_RELST_LO 112
+#define R_PPC_EMB_RELST_HI 113
+#define R_PPC_EMB_RELST_HA 114
+#define R_PPC_EMB_BIT_FLD 115
+#define R_PPC_EMB_RELSDA 116 /* 16 bit relative offset in SDA */
+
+/* Diab tool relocations. */
+#define R_PPC_DIAB_SDA21_LO 180 /* like EMB_SDA21, but lower 16 bit */
+#define R_PPC_DIAB_SDA21_HI 181 /* like EMB_SDA21, but high 16 bit */
+#define R_PPC_DIAB_SDA21_HA 182 /* like EMB_SDA21, adjusted high 16 */
+#define R_PPC_DIAB_RELSDA_LO 183 /* like EMB_RELSDA, but lower 16 bit */
+#define R_PPC_DIAB_RELSDA_HI 184 /* like EMB_RELSDA, but high 16 bit */
+#define R_PPC_DIAB_RELSDA_HA 185 /* like EMB_RELSDA, adjusted high 16 */
+
+/* GNU extension to support local ifunc. */
+#define R_PPC_IRELATIVE 248
+
+/* GNU relocs used in PIC code sequences. */
+#define R_PPC_REL16 249 /* half16 (sym+add-.) */
+#define R_PPC_REL16_LO 250 /* half16 (sym+add-.)@l */
+#define R_PPC_REL16_HI 251 /* half16 (sym+add-.)@h */
+#define R_PPC_REL16_HA 252 /* half16 (sym+add-.)@ha */
+
+/* This is a phony reloc to handle any old fashioned TOC16 references
+ that may still be in object files. */
+#define R_PPC_TOC16 255
+
+/* PowerPC specific values for the Dyn d_tag field. */
+#define DT_PPC_GOT (DT_LOPROC + 0)
+#define DT_PPC_NUM 1
+
+/* PowerPC64 relocations defined by the ABIs */
+#define R_PPC64_NONE R_PPC_NONE
+#define R_PPC64_ADDR32 R_PPC_ADDR32 /* 32bit absolute address */
+#define R_PPC64_ADDR24 R_PPC_ADDR24 /* 26bit address, word aligned */
+#define R_PPC64_ADDR16 R_PPC_ADDR16 /* 16bit absolute address */
+#define R_PPC64_ADDR16_LO R_PPC_ADDR16_LO /* lower 16bits of address */
+#define R_PPC64_ADDR16_HI R_PPC_ADDR16_HI /* high 16bits of address. */
+#define R_PPC64_ADDR16_HA R_PPC_ADDR16_HA /* adjusted high 16bits. */
+#define R_PPC64_ADDR14 R_PPC_ADDR14 /* 16bit address, word aligned */
+#define R_PPC64_ADDR14_BRTAKEN R_PPC_ADDR14_BRTAKEN
+#define R_PPC64_ADDR14_BRNTAKEN R_PPC_ADDR14_BRNTAKEN
+#define R_PPC64_REL24 R_PPC_REL24 /* PC-rel. 26 bit, word aligned */
+#define R_PPC64_REL14 R_PPC_REL14 /* PC relative 16 bit */
+#define R_PPC64_REL14_BRTAKEN R_PPC_REL14_BRTAKEN
+#define R_PPC64_REL14_BRNTAKEN R_PPC_REL14_BRNTAKEN
+#define R_PPC64_GOT16 R_PPC_GOT16
+#define R_PPC64_GOT16_LO R_PPC_GOT16_LO
+#define R_PPC64_GOT16_HI R_PPC_GOT16_HI
+#define R_PPC64_GOT16_HA R_PPC_GOT16_HA
+
+#define R_PPC64_COPY R_PPC_COPY
+#define R_PPC64_GLOB_DAT R_PPC_GLOB_DAT
+#define R_PPC64_JMP_SLOT R_PPC_JMP_SLOT
+#define R_PPC64_RELATIVE R_PPC_RELATIVE
+
+#define R_PPC64_UADDR32 R_PPC_UADDR32
+#define R_PPC64_UADDR16 R_PPC_UADDR16
+#define R_PPC64_REL32 R_PPC_REL32
+#define R_PPC64_PLT32 R_PPC_PLT32
+#define R_PPC64_PLTREL32 R_PPC_PLTREL32
+#define R_PPC64_PLT16_LO R_PPC_PLT16_LO
+#define R_PPC64_PLT16_HI R_PPC_PLT16_HI
+#define R_PPC64_PLT16_HA R_PPC_PLT16_HA
+
+#define R_PPC64_SECTOFF R_PPC_SECTOFF
+#define R_PPC64_SECTOFF_LO R_PPC_SECTOFF_LO
+#define R_PPC64_SECTOFF_HI R_PPC_SECTOFF_HI
+#define R_PPC64_SECTOFF_HA R_PPC_SECTOFF_HA
+#define R_PPC64_ADDR30 37 /* word30 (S + A - P) >> 2 */
+#define R_PPC64_ADDR64 38 /* doubleword64 S + A */
+#define R_PPC64_ADDR16_HIGHER 39 /* half16 #higher(S + A) */
+#define R_PPC64_ADDR16_HIGHERA 40 /* half16 #highera(S + A) */
+#define R_PPC64_ADDR16_HIGHEST 41 /* half16 #highest(S + A) */
+#define R_PPC64_ADDR16_HIGHESTA 42 /* half16 #highesta(S + A) */
+#define R_PPC64_UADDR64 43 /* doubleword64 S + A */
+#define R_PPC64_REL64 44 /* doubleword64 S + A - P */
+#define R_PPC64_PLT64 45 /* doubleword64 L + A */
+#define R_PPC64_PLTREL64 46 /* doubleword64 L + A - P */
+#define R_PPC64_TOC16 47 /* half16* S + A - .TOC */
+#define R_PPC64_TOC16_LO 48 /* half16 #lo(S + A - .TOC.) */
+#define R_PPC64_TOC16_HI 49 /* half16 #hi(S + A - .TOC.) */
+#define R_PPC64_TOC16_HA 50 /* half16 #ha(S + A - .TOC.) */
+#define R_PPC64_TOC 51 /* doubleword64 .TOC */
+#define R_PPC64_PLTGOT16 52 /* half16* M + A */
+#define R_PPC64_PLTGOT16_LO 53 /* half16 #lo(M + A) */
+#define R_PPC64_PLTGOT16_HI 54 /* half16 #hi(M + A) */
+#define R_PPC64_PLTGOT16_HA 55 /* half16 #ha(M + A) */
+
+#define R_PPC64_ADDR16_DS 56 /* half16ds* (S + A) >> 2 */
+#define R_PPC64_ADDR16_LO_DS 57 /* half16ds #lo(S + A) >> 2 */
+#define R_PPC64_GOT16_DS 58 /* half16ds* (G + A) >> 2 */
+#define R_PPC64_GOT16_LO_DS 59 /* half16ds #lo(G + A) >> 2 */
+#define R_PPC64_PLT16_LO_DS 60 /* half16ds #lo(L + A) >> 2 */
+#define R_PPC64_SECTOFF_DS 61 /* half16ds* (R + A) >> 2 */
+#define R_PPC64_SECTOFF_LO_DS 62 /* half16ds #lo(R + A) >> 2 */
+#define R_PPC64_TOC16_DS 63 /* half16ds* (S + A - .TOC.) >> 2 */
+#define R_PPC64_TOC16_LO_DS 64 /* half16ds #lo(S + A - .TOC.) >> 2 */
+#define R_PPC64_PLTGOT16_DS 65 /* half16ds* (M + A) >> 2 */
+#define R_PPC64_PLTGOT16_LO_DS 66 /* half16ds #lo(M + A) >> 2 */
+
+/* PowerPC64 relocations defined for the TLS access ABI. */
+#define R_PPC64_TLS 67 /* none (sym+add)@tls */
+#define R_PPC64_DTPMOD64 68 /* doubleword64 (sym+add)@dtpmod */
+#define R_PPC64_TPREL16 69 /* half16* (sym+add)@tprel */
+#define R_PPC64_TPREL16_LO 70 /* half16 (sym+add)@tprel@l */
+#define R_PPC64_TPREL16_HI 71 /* half16 (sym+add)@tprel@h */
+#define R_PPC64_TPREL16_HA 72 /* half16 (sym+add)@tprel@ha */
+#define R_PPC64_TPREL64 73 /* doubleword64 (sym+add)@tprel */
+#define R_PPC64_DTPREL16 74 /* half16* (sym+add)@dtprel */
+#define R_PPC64_DTPREL16_LO 75 /* half16 (sym+add)@dtprel@l */
+#define R_PPC64_DTPREL16_HI 76 /* half16 (sym+add)@dtprel@h */
+#define R_PPC64_DTPREL16_HA 77 /* half16 (sym+add)@dtprel@ha */
+#define R_PPC64_DTPREL64 78 /* doubleword64 (sym+add)@dtprel */
+#define R_PPC64_GOT_TLSGD16 79 /* half16* (sym+add)@got@tlsgd */
+#define R_PPC64_GOT_TLSGD16_LO 80 /* half16 (sym+add)@got@tlsgd@l */
+#define R_PPC64_GOT_TLSGD16_HI 81 /* half16 (sym+add)@got@tlsgd@h */
+#define R_PPC64_GOT_TLSGD16_HA 82 /* half16 (sym+add)@got@tlsgd@ha */
+#define R_PPC64_GOT_TLSLD16 83 /* half16* (sym+add)@got@tlsld */
+#define R_PPC64_GOT_TLSLD16_LO 84 /* half16 (sym+add)@got@tlsld@l */
+#define R_PPC64_GOT_TLSLD16_HI 85 /* half16 (sym+add)@got@tlsld@h */
+#define R_PPC64_GOT_TLSLD16_HA 86 /* half16 (sym+add)@got@tlsld@ha */
+#define R_PPC64_GOT_TPREL16_DS 87 /* half16ds* (sym+add)@got@tprel */
+#define R_PPC64_GOT_TPREL16_LO_DS 88 /* half16ds (sym+add)@got@tprel@l */
+#define R_PPC64_GOT_TPREL16_HI 89 /* half16 (sym+add)@got@tprel@h */
+#define R_PPC64_GOT_TPREL16_HA 90 /* half16 (sym+add)@got@tprel@ha */
+#define R_PPC64_GOT_DTPREL16_DS 91 /* half16ds* (sym+add)@got@dtprel */
+#define R_PPC64_GOT_DTPREL16_LO_DS 92 /* half16ds (sym+add)@got@dtprel@l */
+#define R_PPC64_GOT_DTPREL16_HI 93 /* half16 (sym+add)@got@dtprel@h */
+#define R_PPC64_GOT_DTPREL16_HA 94 /* half16 (sym+add)@got@dtprel@ha */
+#define R_PPC64_TPREL16_DS 95 /* half16ds* (sym+add)@tprel */
+#define R_PPC64_TPREL16_LO_DS 96 /* half16ds (sym+add)@tprel@l */
+#define R_PPC64_TPREL16_HIGHER 97 /* half16 (sym+add)@tprel@higher */
+#define R_PPC64_TPREL16_HIGHERA 98 /* half16 (sym+add)@tprel@highera */
+#define R_PPC64_TPREL16_HIGHEST 99 /* half16 (sym+add)@tprel@highest */
+#define R_PPC64_TPREL16_HIGHESTA 100 /* half16 (sym+add)@tprel@highesta */
+#define R_PPC64_DTPREL16_DS 101 /* half16ds* (sym+add)@dtprel */
+#define R_PPC64_DTPREL16_LO_DS 102 /* half16ds (sym+add)@dtprel@l */
+#define R_PPC64_DTPREL16_HIGHER 103 /* half16 (sym+add)@dtprel@higher */
+#define R_PPC64_DTPREL16_HIGHERA 104 /* half16 (sym+add)@dtprel@highera */
+#define R_PPC64_DTPREL16_HIGHEST 105 /* half16 (sym+add)@dtprel@highest */
+#define R_PPC64_DTPREL16_HIGHESTA 106 /* half16 (sym+add)@dtprel@highesta */
+
+/* GNU extension to support local ifunc. */
+#define R_PPC64_JMP_IREL 247
+#define R_PPC64_IRELATIVE 248
+#define R_PPC64_REL16 249 /* half16 (sym+add-.) */
+#define R_PPC64_REL16_LO 250 /* half16 (sym+add-.)@l */
+#define R_PPC64_REL16_HI 251 /* half16 (sym+add-.)@h */
+#define R_PPC64_REL16_HA 252 /* half16 (sym+add-.)@ha */
+
+/* PowerPC64 specific values for the Dyn d_tag field. */
+#define DT_PPC64_GLINK (DT_LOPROC + 0)
+#define DT_PPC64_OPD (DT_LOPROC + 1)
+#define DT_PPC64_OPDSZ (DT_LOPROC + 2)
+#define DT_PPC64_NUM 3
+
+
+/* ARM specific declarations */
+
+/* Processor specific flags for the ELF header e_flags field. */
+#define EF_ARM_RELEXEC 0x01
+#define EF_ARM_HASENTRY 0x02
+#define EF_ARM_INTERWORK 0x04
+#define EF_ARM_APCS_26 0x08
+#define EF_ARM_APCS_FLOAT 0x10
+#define EF_ARM_PIC 0x20
+#define EF_ARM_ALIGN8 0x40 /* 8-bit structure alignment is in use */
+#define EF_ARM_NEW_ABI 0x80
+#define EF_ARM_OLD_ABI 0x100
+#define EF_ARM_SOFT_FLOAT 0x200
+#define EF_ARM_VFP_FLOAT 0x400
+#define EF_ARM_MAVERICK_FLOAT 0x800
+
+
+/* Other constants defined in the ARM ELF spec. version B-01. */
+/* NB. These conflict with values defined above. */
+#define EF_ARM_SYMSARESORTED 0x04
+#define EF_ARM_DYNSYMSUSESEGIDX 0x08
+#define EF_ARM_MAPSYMSFIRST 0x10
+#define EF_ARM_EABIMASK 0XFF000000
+
+/* Constants defined in AAELF. */
+#define EF_ARM_BE8 0x00800000
+#define EF_ARM_LE8 0x00400000
+
+#define EF_ARM_EABI_VERSION(flags) ((flags) & EF_ARM_EABIMASK)
+#define EF_ARM_EABI_UNKNOWN 0x00000000
+#define EF_ARM_EABI_VER1 0x01000000
+#define EF_ARM_EABI_VER2 0x02000000
+#define EF_ARM_EABI_VER3 0x03000000
+#define EF_ARM_EABI_VER4 0x04000000
+#define EF_ARM_EABI_VER5 0x05000000
+
+/* Additional symbol types for Thumb. */
+#define STT_ARM_TFUNC STT_LOPROC /* A Thumb function. */
+#define STT_ARM_16BIT STT_HIPROC /* A Thumb label. */
+
+/* ARM-specific values for sh_flags */
+#define SHF_ARM_ENTRYSECT 0x10000000 /* Section contains an entry point */
+#define SHF_ARM_COMDEF 0x80000000 /* Section may be multiply defined
+ in the input to a link step. */
+
+/* ARM-specific program header flags */
+#define PF_ARM_SB 0x10000000 /* Segment contains the location
+ addressed by the static base. */
+#define PF_ARM_PI 0x20000000 /* Position-independent segment. */
+#define PF_ARM_ABS 0x40000000 /* Absolute segment. */
+
+/* Processor specific values for the Phdr p_type field. */
+#define PT_ARM_EXIDX (PT_LOPROC + 1) /* ARM unwind segment. */
+
+/* Processor specific values for the Shdr sh_type field. */
+#define SHT_ARM_EXIDX (SHT_LOPROC + 1) /* ARM unwind section. */
+#define SHT_ARM_PREEMPTMAP (SHT_LOPROC + 2) /* Preemption details. */
+#define SHT_ARM_ATTRIBUTES (SHT_LOPROC + 3) /* ARM attributes section. */
+
+
+/* ARM relocs. */
+
+#define R_ARM_NONE 0 /* No reloc */
+#define R_ARM_PC24 1 /* PC relative 26 bit branch */
+#define R_ARM_ABS32 2 /* Direct 32 bit */
+#define R_ARM_REL32 3 /* PC relative 32 bit */
+#define R_ARM_PC13 4
+#define R_ARM_ABS16 5 /* Direct 16 bit */
+#define R_ARM_ABS12 6 /* Direct 12 bit */
+#define R_ARM_THM_ABS5 7
+#define R_ARM_ABS8 8 /* Direct 8 bit */
+#define R_ARM_SBREL32 9
+#define R_ARM_THM_PC22 10
+#define R_ARM_THM_PC8 11
+#define R_ARM_AMP_VCALL9 12
+#define R_ARM_SWI24 13
+#define R_ARM_THM_SWI8 14
+#define R_ARM_XPC25 15
+#define R_ARM_THM_XPC22 16
+#define R_ARM_TLS_DTPMOD32 17 /* ID of module containing symbol */
+#define R_ARM_TLS_DTPOFF32 18 /* Offset in TLS block */
+#define R_ARM_TLS_TPOFF32 19 /* Offset in static TLS block */
+#define R_ARM_COPY 20 /* Copy symbol at runtime */
+#define R_ARM_GLOB_DAT 21 /* Create GOT entry */
+#define R_ARM_JUMP_SLOT 22 /* Create PLT entry */
+#define R_ARM_RELATIVE 23 /* Adjust by program base */
+#define R_ARM_GOTOFF 24 /* 32 bit offset to GOT */
+#define R_ARM_GOTPC 25 /* 32 bit PC relative offset to GOT */
+#define R_ARM_GOT32 26 /* 32 bit GOT entry */
+#define R_ARM_PLT32 27 /* 32 bit PLT address */
+#define R_ARM_ALU_PCREL_7_0 32
+#define R_ARM_ALU_PCREL_15_8 33
+#define R_ARM_ALU_PCREL_23_15 34
+#define R_ARM_LDR_SBREL_11_0 35
+#define R_ARM_ALU_SBREL_19_12 36
+#define R_ARM_ALU_SBREL_27_20 37
+#define R_ARM_GNU_VTENTRY 100
+#define R_ARM_GNU_VTINHERIT 101
+#define R_ARM_THM_PC11 102 /* thumb unconditional branch */
+#define R_ARM_THM_PC9 103 /* thumb conditional branch */
+#define R_ARM_TLS_GD32 104 /* PC-rel 32 bit for global dynamic
+ thread local data */
+#define R_ARM_TLS_LDM32 105 /* PC-rel 32 bit for local dynamic
+ thread local data */
+#define R_ARM_TLS_LDO32 106 /* 32 bit offset relative to TLS
+ block */
+#define R_ARM_TLS_IE32 107 /* PC-rel 32 bit for GOT entry of
+ static TLS block offset */
+#define R_ARM_TLS_LE32 108 /* 32 bit offset relative to static
+ TLS block */
+#define R_ARM_RXPC25 249
+#define R_ARM_RSBREL32 250
+#define R_ARM_THM_RPC22 251
+#define R_ARM_RREL32 252
+#define R_ARM_RABS22 253
+#define R_ARM_RPC24 254
+#define R_ARM_RBASE 255
+/* Keep this the last entry. */
+#define R_ARM_NUM 256
+
+/* IA-64 specific declarations. */
+
+/* Processor specific flags for the Ehdr e_flags field. */
+#define EF_IA_64_MASKOS 0x0000000f /* os-specific flags */
+#define EF_IA_64_ABI64 0x00000010 /* 64-bit ABI */
+#define EF_IA_64_ARCH 0xff000000 /* arch. version mask */
+
+/* Processor specific values for the Phdr p_type field. */
+#define PT_IA_64_ARCHEXT (PT_LOPROC + 0) /* arch extension bits */
+#define PT_IA_64_UNWIND (PT_LOPROC + 1) /* ia64 unwind bits */
+#define PT_IA_64_HP_OPT_ANOT (PT_LOOS + 0x12)
+#define PT_IA_64_HP_HSL_ANOT (PT_LOOS + 0x13)
+#define PT_IA_64_HP_STACK (PT_LOOS + 0x14)
+
+/* Processor specific flags for the Phdr p_flags field. */
+#define PF_IA_64_NORECOV 0x80000000 /* spec insns w/o recovery */
+
+/* Processor specific values for the Shdr sh_type field. */
+#define SHT_IA_64_EXT (SHT_LOPROC + 0) /* extension bits */
+#define SHT_IA_64_UNWIND (SHT_LOPROC + 1) /* unwind bits */
+
+/* Processor specific flags for the Shdr sh_flags field. */
+#define SHF_IA_64_SHORT 0x10000000 /* section near gp */
+#define SHF_IA_64_NORECOV 0x20000000 /* spec insns w/o recovery */
+
+/* Processor specific values for the Dyn d_tag field. */
+#define DT_IA_64_PLT_RESERVE (DT_LOPROC + 0)
+#define DT_IA_64_NUM 1
+
+/* IA-64 relocations. */
+#define R_IA64_NONE 0x00 /* none */
+#define R_IA64_IMM14 0x21 /* symbol + addend, add imm14 */
+#define R_IA64_IMM22 0x22 /* symbol + addend, add imm22 */
+#define R_IA64_IMM64 0x23 /* symbol + addend, mov imm64 */
+#define R_IA64_DIR32MSB 0x24 /* symbol + addend, data4 MSB */
+#define R_IA64_DIR32LSB 0x25 /* symbol + addend, data4 LSB */
+#define R_IA64_DIR64MSB 0x26 /* symbol + addend, data8 MSB */
+#define R_IA64_DIR64LSB 0x27 /* symbol + addend, data8 LSB */
+#define R_IA64_GPREL22 0x2a /* @gprel(sym + add), add imm22 */
+#define R_IA64_GPREL64I 0x2b /* @gprel(sym + add), mov imm64 */
+#define R_IA64_GPREL32MSB 0x2c /* @gprel(sym + add), data4 MSB */
+#define R_IA64_GPREL32LSB 0x2d /* @gprel(sym + add), data4 LSB */
+#define R_IA64_GPREL64MSB 0x2e /* @gprel(sym + add), data8 MSB */
+#define R_IA64_GPREL64LSB 0x2f /* @gprel(sym + add), data8 LSB */
+#define R_IA64_LTOFF22 0x32 /* @ltoff(sym + add), add imm22 */
+#define R_IA64_LTOFF64I 0x33 /* @ltoff(sym + add), mov imm64 */
+#define R_IA64_PLTOFF22 0x3a /* @pltoff(sym + add), add imm22 */
+#define R_IA64_PLTOFF64I 0x3b /* @pltoff(sym + add), mov imm64 */
+#define R_IA64_PLTOFF64MSB 0x3e /* @pltoff(sym + add), data8 MSB */
+#define R_IA64_PLTOFF64LSB 0x3f /* @pltoff(sym + add), data8 LSB */
+#define R_IA64_FPTR64I 0x43 /* @fptr(sym + add), mov imm64 */
+#define R_IA64_FPTR32MSB 0x44 /* @fptr(sym + add), data4 MSB */
+#define R_IA64_FPTR32LSB 0x45 /* @fptr(sym + add), data4 LSB */
+#define R_IA64_FPTR64MSB 0x46 /* @fptr(sym + add), data8 MSB */
+#define R_IA64_FPTR64LSB 0x47 /* @fptr(sym + add), data8 LSB */
+#define R_IA64_PCREL60B 0x48 /* @pcrel(sym + add), brl */
+#define R_IA64_PCREL21B 0x49 /* @pcrel(sym + add), ptb, call */
+#define R_IA64_PCREL21M 0x4a /* @pcrel(sym + add), chk.s */
+#define R_IA64_PCREL21F 0x4b /* @pcrel(sym + add), fchkf */
+#define R_IA64_PCREL32MSB 0x4c /* @pcrel(sym + add), data4 MSB */
+#define R_IA64_PCREL32LSB 0x4d /* @pcrel(sym + add), data4 LSB */
+#define R_IA64_PCREL64MSB 0x4e /* @pcrel(sym + add), data8 MSB */
+#define R_IA64_PCREL64LSB 0x4f /* @pcrel(sym + add), data8 LSB */
+#define R_IA64_LTOFF_FPTR22 0x52 /* @ltoff(@fptr(s+a)), imm22 */
+#define R_IA64_LTOFF_FPTR64I 0x53 /* @ltoff(@fptr(s+a)), imm64 */
+#define R_IA64_LTOFF_FPTR32MSB 0x54 /* @ltoff(@fptr(s+a)), data4 MSB */
+#define R_IA64_LTOFF_FPTR32LSB 0x55 /* @ltoff(@fptr(s+a)), data4 LSB */
+#define R_IA64_LTOFF_FPTR64MSB 0x56 /* @ltoff(@fptr(s+a)), data8 MSB */
+#define R_IA64_LTOFF_FPTR64LSB 0x57 /* @ltoff(@fptr(s+a)), data8 LSB */
+#define R_IA64_SEGREL32MSB 0x5c /* @segrel(sym + add), data4 MSB */
+#define R_IA64_SEGREL32LSB 0x5d /* @segrel(sym + add), data4 LSB */
+#define R_IA64_SEGREL64MSB 0x5e /* @segrel(sym + add), data8 MSB */
+#define R_IA64_SEGREL64LSB 0x5f /* @segrel(sym + add), data8 LSB */
+#define R_IA64_SECREL32MSB 0x64 /* @secrel(sym + add), data4 MSB */
+#define R_IA64_SECREL32LSB 0x65 /* @secrel(sym + add), data4 LSB */
+#define R_IA64_SECREL64MSB 0x66 /* @secrel(sym + add), data8 MSB */
+#define R_IA64_SECREL64LSB 0x67 /* @secrel(sym + add), data8 LSB */
+#define R_IA64_REL32MSB 0x6c /* data 4 + REL */
+#define R_IA64_REL32LSB 0x6d /* data 4 + REL */
+#define R_IA64_REL64MSB 0x6e /* data 8 + REL */
+#define R_IA64_REL64LSB 0x6f /* data 8 + REL */
+#define R_IA64_LTV32MSB 0x74 /* symbol + addend, data4 MSB */
+#define R_IA64_LTV32LSB 0x75 /* symbol + addend, data4 LSB */
+#define R_IA64_LTV64MSB 0x76 /* symbol + addend, data8 MSB */
+#define R_IA64_LTV64LSB 0x77 /* symbol + addend, data8 LSB */
+#define R_IA64_PCREL21BI 0x79 /* @pcrel(sym + add), 21bit inst */
+#define R_IA64_PCREL22 0x7a /* @pcrel(sym + add), 22bit inst */
+#define R_IA64_PCREL64I 0x7b /* @pcrel(sym + add), 64bit inst */
+#define R_IA64_IPLTMSB 0x80 /* dynamic reloc, imported PLT, MSB */
+#define R_IA64_IPLTLSB 0x81 /* dynamic reloc, imported PLT, LSB */
+#define R_IA64_COPY 0x84 /* copy relocation */
+#define R_IA64_SUB 0x85 /* Addend and symbol difference */
+#define R_IA64_LTOFF22X 0x86 /* LTOFF22, relaxable. */
+#define R_IA64_LDXMOV 0x87 /* Use of LTOFF22X. */
+#define R_IA64_TPREL14 0x91 /* @tprel(sym + add), imm14 */
+#define R_IA64_TPREL22 0x92 /* @tprel(sym + add), imm22 */
+#define R_IA64_TPREL64I 0x93 /* @tprel(sym + add), imm64 */
+#define R_IA64_TPREL64MSB 0x96 /* @tprel(sym + add), data8 MSB */
+#define R_IA64_TPREL64LSB 0x97 /* @tprel(sym + add), data8 LSB */
+#define R_IA64_LTOFF_TPREL22 0x9a /* @ltoff(@tprel(s+a)), imm2 */
+#define R_IA64_DTPMOD64MSB 0xa6 /* @dtpmod(sym + add), data8 MSB */
+#define R_IA64_DTPMOD64LSB 0xa7 /* @dtpmod(sym + add), data8 LSB */
+#define R_IA64_LTOFF_DTPMOD22 0xaa /* @ltoff(@dtpmod(sym + add)), imm22 */
+#define R_IA64_DTPREL14 0xb1 /* @dtprel(sym + add), imm14 */
+#define R_IA64_DTPREL22 0xb2 /* @dtprel(sym + add), imm22 */
+#define R_IA64_DTPREL64I 0xb3 /* @dtprel(sym + add), imm64 */
+#define R_IA64_DTPREL32MSB 0xb4 /* @dtprel(sym + add), data4 MSB */
+#define R_IA64_DTPREL32LSB 0xb5 /* @dtprel(sym + add), data4 LSB */
+#define R_IA64_DTPREL64MSB 0xb6 /* @dtprel(sym + add), data8 MSB */
+#define R_IA64_DTPREL64LSB 0xb7 /* @dtprel(sym + add), data8 LSB */
+#define R_IA64_LTOFF_DTPREL22 0xba /* @ltoff(@dtprel(s+a)), imm22 */
+
+/* SH specific declarations */
+
+/* Processor specific flags for the ELF header e_flags field. */
+#define EF_SH_MACH_MASK 0x1f
+#define EF_SH_UNKNOWN 0x0
+#define EF_SH1 0x1
+#define EF_SH2 0x2
+#define EF_SH3 0x3
+#define EF_SH_DSP 0x4
+#define EF_SH3_DSP 0x5
+#define EF_SH4AL_DSP 0x6
+#define EF_SH3E 0x8
+#define EF_SH4 0x9
+#define EF_SH2E 0xb
+#define EF_SH4A 0xc
+#define EF_SH2A 0xd
+#define EF_SH4_NOFPU 0x10
+#define EF_SH4A_NOFPU 0x11
+#define EF_SH4_NOMMU_NOFPU 0x12
+#define EF_SH2A_NOFPU 0x13
+#define EF_SH3_NOMMU 0x14
+#define EF_SH2A_SH4_NOFPU 0x15
+#define EF_SH2A_SH3_NOFPU 0x16
+#define EF_SH2A_SH4 0x17
+#define EF_SH2A_SH3E 0x18
+
+/* SH relocs. */
+#define R_SH_NONE 0
+#define R_SH_DIR32 1
+#define R_SH_REL32 2
+#define R_SH_DIR8WPN 3
+#define R_SH_IND12W 4
+#define R_SH_DIR8WPL 5
+#define R_SH_DIR8WPZ 6
+#define R_SH_DIR8BP 7
+#define R_SH_DIR8W 8
+#define R_SH_DIR8L 9
+#define R_SH_SWITCH16 25
+#define R_SH_SWITCH32 26
+#define R_SH_USES 27
+#define R_SH_COUNT 28
+#define R_SH_ALIGN 29
+#define R_SH_CODE 30
+#define R_SH_DATA 31
+#define R_SH_LABEL 32
+#define R_SH_SWITCH8 33
+#define R_SH_GNU_VTINHERIT 34
+#define R_SH_GNU_VTENTRY 35
+#define R_SH_TLS_GD_32 144
+#define R_SH_TLS_LD_32 145
+#define R_SH_TLS_LDO_32 146
+#define R_SH_TLS_IE_32 147
+#define R_SH_TLS_LE_32 148
+#define R_SH_TLS_DTPMOD32 149
+#define R_SH_TLS_DTPOFF32 150
+#define R_SH_TLS_TPOFF32 151
+#define R_SH_GOT32 160
+#define R_SH_PLT32 161
+#define R_SH_COPY 162
+#define R_SH_GLOB_DAT 163
+#define R_SH_JMP_SLOT 164
+#define R_SH_RELATIVE 165
+#define R_SH_GOTOFF 166
+#define R_SH_GOTPC 167
+/* Keep this the last entry. */
+#define R_SH_NUM 256
+
+/* S/390 specific definitions. */
+
+/* Valid values for the e_flags field. */
+
+#define EF_S390_HIGH_GPRS 0x00000001 /* High GPRs kernel facility needed. */
+
+/* Additional s390 relocs */
+
+#define R_390_NONE 0 /* No reloc. */
+#define R_390_8 1 /* Direct 8 bit. */
+#define R_390_12 2 /* Direct 12 bit. */
+#define R_390_16 3 /* Direct 16 bit. */
+#define R_390_32 4 /* Direct 32 bit. */
+#define R_390_PC32 5 /* PC relative 32 bit. */
+#define R_390_GOT12 6 /* 12 bit GOT offset. */
+#define R_390_GOT32 7 /* 32 bit GOT offset. */
+#define R_390_PLT32 8 /* 32 bit PC relative PLT address. */
+#define R_390_COPY 9 /* Copy symbol at runtime. */
+#define R_390_GLOB_DAT 10 /* Create GOT entry. */
+#define R_390_JMP_SLOT 11 /* Create PLT entry. */
+#define R_390_RELATIVE 12 /* Adjust by program base. */
+#define R_390_GOTOFF32 13 /* 32 bit offset to GOT. */
+#define R_390_GOTPC 14 /* 32 bit PC relative offset to GOT. */
+#define R_390_GOT16 15 /* 16 bit GOT offset. */
+#define R_390_PC16 16 /* PC relative 16 bit. */
+#define R_390_PC16DBL 17 /* PC relative 16 bit shifted by 1. */
+#define R_390_PLT16DBL 18 /* 16 bit PC rel. PLT shifted by 1. */
+#define R_390_PC32DBL 19 /* PC relative 32 bit shifted by 1. */
+#define R_390_PLT32DBL 20 /* 32 bit PC rel. PLT shifted by 1. */
+#define R_390_GOTPCDBL 21 /* 32 bit PC rel. GOT shifted by 1. */
+#define R_390_64 22 /* Direct 64 bit. */
+#define R_390_PC64 23 /* PC relative 64 bit. */
+#define R_390_GOT64 24 /* 64 bit GOT offset. */
+#define R_390_PLT64 25 /* 64 bit PC relative PLT address. */
+#define R_390_GOTENT 26 /* 32 bit PC rel. to GOT entry >> 1. */
+#define R_390_GOTOFF16 27 /* 16 bit offset to GOT. */
+#define R_390_GOTOFF64 28 /* 64 bit offset to GOT. */
+#define R_390_GOTPLT12 29 /* 12 bit offset to jump slot. */
+#define R_390_GOTPLT16 30 /* 16 bit offset to jump slot. */
+#define R_390_GOTPLT32 31 /* 32 bit offset to jump slot. */
+#define R_390_GOTPLT64 32 /* 64 bit offset to jump slot. */
+#define R_390_GOTPLTENT 33 /* 32 bit rel. offset to jump slot. */
+#define R_390_PLTOFF16 34 /* 16 bit offset from GOT to PLT. */
+#define R_390_PLTOFF32 35 /* 32 bit offset from GOT to PLT. */
+#define R_390_PLTOFF64 36 /* 16 bit offset from GOT to PLT. */
+#define R_390_TLS_LOAD 37 /* Tag for load insn in TLS code. */
+#define R_390_TLS_GDCALL 38 /* Tag for function call in general
+ dynamic TLS code. */
+#define R_390_TLS_LDCALL 39 /* Tag for function call in local
+ dynamic TLS code. */
+#define R_390_TLS_GD32 40 /* Direct 32 bit for general dynamic
+ thread local data. */
+#define R_390_TLS_GD64 41 /* Direct 64 bit for general dynamic
+ thread local data. */
+#define R_390_TLS_GOTIE12 42 /* 12 bit GOT offset for static TLS
+ block offset. */
+#define R_390_TLS_GOTIE32 43 /* 32 bit GOT offset for static TLS
+ block offset. */
+#define R_390_TLS_GOTIE64 44 /* 64 bit GOT offset for static TLS
+ block offset. */
+#define R_390_TLS_LDM32 45 /* Direct 32 bit for local dynamic
+ thread local data in LE code. */
+#define R_390_TLS_LDM64 46 /* Direct 64 bit for local dynamic
+ thread local data in LE code. */
+#define R_390_TLS_IE32 47 /* 32 bit address of GOT entry for
+ negated static TLS block offset. */
+#define R_390_TLS_IE64 48 /* 64 bit address of GOT entry for
+ negated static TLS block offset. */
+#define R_390_TLS_IEENT 49 /* 32 bit rel. offset to GOT entry for
+ negated static TLS block offset. */
+#define R_390_TLS_LE32 50 /* 32 bit negated offset relative to
+ static TLS block. */
+#define R_390_TLS_LE64 51 /* 64 bit negated offset relative to
+ static TLS block. */
+#define R_390_TLS_LDO32 52 /* 32 bit offset relative to TLS
+ block. */
+#define R_390_TLS_LDO64 53 /* 64 bit offset relative to TLS
+ block. */
+#define R_390_TLS_DTPMOD 54 /* ID of module containing symbol. */
+#define R_390_TLS_DTPOFF 55 /* Offset in TLS block. */
+#define R_390_TLS_TPOFF 56 /* Negated offset in static TLS
+ block. */
+#define R_390_20 57 /* Direct 20 bit. */
+#define R_390_GOT20 58 /* 20 bit GOT offset. */
+#define R_390_GOTPLT20 59 /* 20 bit offset to jump slot. */
+#define R_390_TLS_GOTIE20 60 /* 20 bit GOT offset for static TLS
+ block offset. */
+/* Keep this the last entry. */
+#define R_390_NUM 61
+
+
+/* CRIS relocations. */
+#define R_CRIS_NONE 0
+#define R_CRIS_8 1
+#define R_CRIS_16 2
+#define R_CRIS_32 3
+#define R_CRIS_8_PCREL 4
+#define R_CRIS_16_PCREL 5
+#define R_CRIS_32_PCREL 6
+#define R_CRIS_GNU_VTINHERIT 7
+#define R_CRIS_GNU_VTENTRY 8
+#define R_CRIS_COPY 9
+#define R_CRIS_GLOB_DAT 10
+#define R_CRIS_JUMP_SLOT 11
+#define R_CRIS_RELATIVE 12
+#define R_CRIS_16_GOT 13
+#define R_CRIS_32_GOT 14
+#define R_CRIS_16_GOTPLT 15
+#define R_CRIS_32_GOTPLT 16
+#define R_CRIS_32_GOTREL 17
+#define R_CRIS_32_PLT_GOTREL 18
+#define R_CRIS_32_PLT_PCREL 19
+
+#define R_CRIS_NUM 20
+
+
+/* AMD x86-64 relocations. */
+#define R_X86_64_NONE 0 /* No reloc */
+#define R_X86_64_64 1 /* Direct 64 bit */
+#define R_X86_64_PC32 2 /* PC relative 32 bit signed */
+#define R_X86_64_GOT32 3 /* 32 bit GOT entry */
+#define R_X86_64_PLT32 4 /* 32 bit PLT address */
+#define R_X86_64_COPY 5 /* Copy symbol at runtime */
+#define R_X86_64_GLOB_DAT 6 /* Create GOT entry */
+#define R_X86_64_JUMP_SLOT 7 /* Create PLT entry */
+#define R_X86_64_RELATIVE 8 /* Adjust by program base */
+#define R_X86_64_GOTPCREL 9 /* 32 bit signed PC relative
+ offset to GOT */
+#define R_X86_64_32 10 /* Direct 32 bit zero extended */
+#define R_X86_64_32S 11 /* Direct 32 bit sign extended */
+#define R_X86_64_16 12 /* Direct 16 bit zero extended */
+#define R_X86_64_PC16 13 /* 16 bit sign extended pc relative */
+#define R_X86_64_8 14 /* Direct 8 bit sign extended */
+#define R_X86_64_PC8 15 /* 8 bit sign extended pc relative */
+#define R_X86_64_DTPMOD64 16 /* ID of module containing symbol */
+#define R_X86_64_DTPOFF64 17 /* Offset in module's TLS block */
+#define R_X86_64_TPOFF64 18 /* Offset in initial TLS block */
+#define R_X86_64_TLSGD 19 /* 32 bit signed PC relative offset
+ to two GOT entries for GD symbol */
+#define R_X86_64_TLSLD 20 /* 32 bit signed PC relative offset
+ to two GOT entries for LD symbol */
+#define R_X86_64_DTPOFF32 21 /* Offset in TLS block */
+#define R_X86_64_GOTTPOFF 22 /* 32 bit signed PC relative offset
+ to GOT entry for IE symbol */
+#define R_X86_64_TPOFF32 23 /* Offset in initial TLS block */
+#define R_X86_64_PC64 24 /* PC relative 64 bit */
+#define R_X86_64_GOTOFF64 25 /* 64 bit offset to GOT */
+#define R_X86_64_GOTPC32 26 /* 32 bit signed pc relative
+ offset to GOT */
+#define R_X86_64_GOT64 27 /* 64-bit GOT entry offset */
+#define R_X86_64_GOTPCREL64 28 /* 64-bit PC relative offset
+ to GOT entry */
+#define R_X86_64_GOTPC64 29 /* 64-bit PC relative offset to GOT */
+#define R_X86_64_GOTPLT64 30 /* like GOT64, says PLT entry needed */
+#define R_X86_64_PLTOFF64 31 /* 64-bit GOT relative offset
+ to PLT entry */
+#define R_X86_64_SIZE32 32 /* Size of symbol plus 32-bit addend */
+#define R_X86_64_SIZE64 33 /* Size of symbol plus 64-bit addend */
+#define R_X86_64_GOTPC32_TLSDESC 34 /* GOT offset for TLS descriptor. */
+#define R_X86_64_TLSDESC_CALL 35 /* Marker for call through TLS
+ descriptor. */
+#define R_X86_64_TLSDESC 36 /* TLS descriptor. */
+#define R_X86_64_IRELATIVE 37 /* Adjust indirectly by program base */
+
+#define R_X86_64_NUM 38
+
+
+/* AM33 relocations. */
+#define R_MN10300_NONE 0 /* No reloc. */
+#define R_MN10300_32 1 /* Direct 32 bit. */
+#define R_MN10300_16 2 /* Direct 16 bit. */
+#define R_MN10300_8 3 /* Direct 8 bit. */
+#define R_MN10300_PCREL32 4 /* PC-relative 32-bit. */
+#define R_MN10300_PCREL16 5 /* PC-relative 16-bit signed. */
+#define R_MN10300_PCREL8 6 /* PC-relative 8-bit signed. */
+#define R_MN10300_GNU_VTINHERIT 7 /* Ancient C++ vtable garbage... */
+#define R_MN10300_GNU_VTENTRY 8 /* ... collection annotation. */
+#define R_MN10300_24 9 /* Direct 24 bit. */
+#define R_MN10300_GOTPC32 10 /* 32-bit PCrel offset to GOT. */
+#define R_MN10300_GOTPC16 11 /* 16-bit PCrel offset to GOT. */
+#define R_MN10300_GOTOFF32 12 /* 32-bit offset from GOT. */
+#define R_MN10300_GOTOFF24 13 /* 24-bit offset from GOT. */
+#define R_MN10300_GOTOFF16 14 /* 16-bit offset from GOT. */
+#define R_MN10300_PLT32 15 /* 32-bit PCrel to PLT entry. */
+#define R_MN10300_PLT16 16 /* 16-bit PCrel to PLT entry. */
+#define R_MN10300_GOT32 17 /* 32-bit offset to GOT entry. */
+#define R_MN10300_GOT24 18 /* 24-bit offset to GOT entry. */
+#define R_MN10300_GOT16 19 /* 16-bit offset to GOT entry. */
+#define R_MN10300_COPY 20 /* Copy symbol at runtime. */
+#define R_MN10300_GLOB_DAT 21 /* Create GOT entry. */
+#define R_MN10300_JMP_SLOT 22 /* Create PLT entry. */
+#define R_MN10300_RELATIVE 23 /* Adjust by program base. */
+
+#define R_MN10300_NUM 24
+
+
+/* M32R relocs. */
+#define R_M32R_NONE 0 /* No reloc. */
+#define R_M32R_16 1 /* Direct 16 bit. */
+#define R_M32R_32 2 /* Direct 32 bit. */
+#define R_M32R_24 3 /* Direct 24 bit. */
+#define R_M32R_10_PCREL 4 /* PC relative 10 bit shifted. */
+#define R_M32R_18_PCREL 5 /* PC relative 18 bit shifted. */
+#define R_M32R_26_PCREL 6 /* PC relative 26 bit shifted. */
+#define R_M32R_HI16_ULO 7 /* High 16 bit with unsigned low. */
+#define R_M32R_HI16_SLO 8 /* High 16 bit with signed low. */
+#define R_M32R_LO16 9 /* Low 16 bit. */
+#define R_M32R_SDA16 10 /* 16 bit offset in SDA. */
+#define R_M32R_GNU_VTINHERIT 11
+#define R_M32R_GNU_VTENTRY 12
+/* M32R relocs use SHT_RELA. */
+#define R_M32R_16_RELA 33 /* Direct 16 bit. */
+#define R_M32R_32_RELA 34 /* Direct 32 bit. */
+#define R_M32R_24_RELA 35 /* Direct 24 bit. */
+#define R_M32R_10_PCREL_RELA 36 /* PC relative 10 bit shifted. */
+#define R_M32R_18_PCREL_RELA 37 /* PC relative 18 bit shifted. */
+#define R_M32R_26_PCREL_RELA 38 /* PC relative 26 bit shifted. */
+#define R_M32R_HI16_ULO_RELA 39 /* High 16 bit with unsigned low */
+#define R_M32R_HI16_SLO_RELA 40 /* High 16 bit with signed low */
+#define R_M32R_LO16_RELA 41 /* Low 16 bit */
+#define R_M32R_SDA16_RELA 42 /* 16 bit offset in SDA */
+#define R_M32R_RELA_GNU_VTINHERIT 43
+#define R_M32R_RELA_GNU_VTENTRY 44
+#define R_M32R_REL32 45 /* PC relative 32 bit. */
+
+#define R_M32R_GOT24 48 /* 24 bit GOT entry */
+#define R_M32R_26_PLTREL 49 /* 26 bit PC relative to PLT shifted */
+#define R_M32R_COPY 50 /* Copy symbol at runtime */
+#define R_M32R_GLOB_DAT 51 /* Create GOT entry */
+#define R_M32R_JMP_SLOT 52 /* Create PLT entry */
+#define R_M32R_RELATIVE 53 /* Adjust by program base */
+#define R_M32R_GOTOFF 54 /* 24 bit offset to GOT */
+#define R_M32R_GOTPC24 55 /* 24 bit PC relative offset to GOT */
+#define R_M32R_GOT16_HI_ULO 56 /* High 16 bit GOT entry with unsigned
+ low */
+#define R_M32R_GOT16_HI_SLO 57 /* High 16 bit GOT entry with signed
+ low */
+#define R_M32R_GOT16_LO 58 /* Low 16 bit GOT entry */
+#define R_M32R_GOTPC_HI_ULO 59 /* High 16 bit PC relative offset to
+ GOT with unsigned low */
+#define R_M32R_GOTPC_HI_SLO 60 /* High 16 bit PC relative offset to
+ GOT with signed low */
+#define R_M32R_GOTPC_LO 61 /* Low 16 bit PC relative offset to
+ GOT */
+#define R_M32R_GOTOFF_HI_ULO 62 /* High 16 bit offset to GOT
+ with unsigned low */
+#define R_M32R_GOTOFF_HI_SLO 63 /* High 16 bit offset to GOT
+ with signed low */
+#define R_M32R_GOTOFF_LO 64 /* Low 16 bit offset to GOT */
+#define R_M32R_NUM 256 /* Keep this the last entry. */
+
+
+#endif /* elf.h */
generic_equal:
if (SCM_UNPACK (g_scm_i_equal_p))
- return scm_call_generic_2 (g_scm_i_equal_p, x, y);
+ return scm_call_2 (g_scm_i_equal_p, x, y);
else
return SCM_BOOL_F;
}
}
-SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
-void
-scm_memory_error (const char *subr)
-{
- fprintf (stderr, "FATAL: memory error in %s\n", subr);
- abort ();
-}
-
SCM_GLOBAL_SYMBOL (scm_misc_error_key, "misc-error");
void
scm_misc_error (const char *subr, const char *message, SCM args)
#ifndef SCM_ERROR_H
#define SCM_ERROR_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006, 2008, 2011, 2014 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_out_of_range_key;
SCM_API SCM scm_args_number_key;
SCM_API SCM scm_arg_type_key;
-SCM_API SCM scm_memory_alloc_key;
SCM_API SCM scm_misc_error_key;
\f
+#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
+ do { if (SCM_UNLIKELY (!(_cond))) \
+ scm_wrong_type_arg (_subr, _pos, _arg); } while (0)
+#define SCM_ASSERT_TYPE(_cond, _arg, _pos, _subr, _msg) \
+ do { if (SCM_UNLIKELY (!(_cond))) \
+ scm_wrong_type_arg_msg(_subr, _pos, _arg, _msg); } while (0)
+
+
+\f
+
SCM_API void scm_error (SCM key, const char *subr, const char *message,
SCM args, SCM rest) SCM_NORETURN;
SCM_API SCM scm_error_scm (SCM key, SCM subr, SCM message,
SCM bad_value) SCM_NORETURN;
SCM_API void scm_wrong_type_arg_msg (const char *subr, int pos,
SCM bad_value, const char *sz) SCM_NORETURN;
-SCM_API void scm_memory_error (const char *subr) SCM_NORETURN;
SCM_API void scm_misc_error (const char *subr, const char *message,
SCM args) SCM_NORETURN;
SCM_INTERNAL void scm_init_error (void);
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2013
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,
+ * 2005,2006,2007,2008,2009,2010,2011,2012,2013,2014
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#include "libguile/eq.h"
#include "libguile/expand.h"
#include "libguile/feature.h"
-#include "libguile/fluids.h"
#include "libguile/goops.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
#define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x))))
/* NB: One may only call the following accessors if the closure is not REST. */
#define BOOT_CLOSURE_IS_FULL(x) (1)
-#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \
+#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,ninits,unbound,alt) \
do { SCM fu = fu_; \
body = CAR (fu); fu = CDDR (fu); \
\
rest = kw = alt = SCM_BOOL_F; \
- inits = SCM_EOL; \
- nopt = 0; \
+ unbound = SCM_BOOL_F; \
+ nopt = ninits = 0; \
\
nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
if (scm_is_pair (fu)) \
{ \
nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
kw = CAR (fu); fu = CDR (fu); \
- inits = CAR (fu); fu = CDR (fu); \
+ ninits = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
+ unbound = CAR (fu); fu = CDR (fu); \
alt = CAR (fu); \
} \
} \
#define CADDR(x) SCM_CADDR(x)
#define CDDDR(x) SCM_CDDDR(x)
+#define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
+#define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
+#define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
-SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
+static SCM
+make_env (int n, SCM init, SCM next)
+{
+ SCM env = scm_c_make_vector (n + 1, init);
+ VECTOR_SET (env, 0, next);
+ return env;
+}
+
+static SCM
+next_rib (SCM env)
+{
+ return VECTOR_REF (env, 0);
+}
+
+static SCM
+env_tail (SCM env)
+{
+ while (SCM_I_IS_VECTOR (env))
+ env = next_rib (env);
+ return env;
+}
+
+static SCM
+env_ref (SCM env, int depth, int width)
+{
+ while (depth--)
+ env = next_rib (env);
+ return VECTOR_REF (env, width + 1);
+}
-static void error_used_before_defined (void)
+static void
+env_set (SCM env, int depth, int width, SCM val)
{
- scm_error (scm_unbound_variable_key, NULL,
- "Variable used before given a value", SCM_EOL, SCM_BOOL_F);
+ while (depth--)
+ env = next_rib (env);
+ VECTOR_SET (env, width + 1, val);
}
+
static void error_invalid_keyword (SCM proc, SCM obj)
{
scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
}
#define EVAL1(x, env) (truncate_values (eval ((x), (env))))
-/* 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) \
- (scm_is_null (env) ? scm_current_module () : \
- (scm_is_false (env) ? scm_the_root_module () : env))
-
static SCM
eval (SCM x, SCM env)
{
loop:
SCM_TICK;
- if (!SCM_MEMOIZED_P (x))
- abort ();
mx = SCM_MEMOIZED_ARGS (x);
- switch (SCM_MEMOIZED_TAG (x))
+ switch (SCM_I_INUM (SCM_CAR (x)))
{
- case SCM_M_BEGIN:
- for (; !scm_is_null (CDR (mx)); mx = CDR (mx))
- eval (CAR (mx), env);
- x = CAR (mx);
+ case SCM_M_SEQ:
+ eval (CAR (mx), env);
+ x = CDR (mx);
goto loop;
case SCM_M_IF:
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 (EVAL1 (CAR (inits), env),
- new_env);
+ SCM new_env;
+ int i;
+
+ new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env);
+ for (i = 0; i < VECTOR_LENGTH (inits); i++)
+ env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env));
env = new_env;
x = CDR (mx);
goto loop;
}
case SCM_M_LAMBDA:
- RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
+ RETURN_BOOT_CLOSURE (mx, env);
- case SCM_M_QUOTE:
- return mx;
+ case SCM_M_CAPTURE_ENV:
+ {
+ SCM locs = CAR (mx);
+ SCM new_env;
+ int i;
- case SCM_M_DEFINE:
- scm_define (CAR (mx), EVAL1 (CDR (mx), env));
- return SCM_UNSPECIFIED;
+ new_env = make_env (VECTOR_LENGTH (locs), SCM_BOOL_F, env);
+ for (i = 0; i < VECTOR_LENGTH (locs); i++)
+ {
+ SCM loc = VECTOR_REF (locs, i);
+ int depth, width;
- case SCM_M_DYNWIND:
- {
- SCM in, out, res, old_winds;
- in = EVAL1 (CAR (mx), env);
- out = EVAL1 (CDDR (mx), env);
- scm_call_0 (in);
- old_winds = scm_i_dynwinds ();
- scm_i_set_dynwinds (scm_acons (in, out, old_winds));
- res = eval (CADR (mx), env);
- scm_i_set_dynwinds (old_winds);
- scm_call_0 (out);
- return res;
- }
+ depth = SCM_I_INUM (CAR (loc));
+ width = SCM_I_INUM (CDR (loc));
+ env_set (new_env, 0, i, env_ref (env, depth, width));
+ }
- case SCM_M_WITH_FLUIDS:
- {
- long i, len;
- SCM *fluidv, *valuesv, walk, wf, res;
- len = scm_ilength (CAR (mx));
- fluidv = alloca (sizeof (SCM)*len);
- for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
- fluidv[i] = EVAL1 (CAR (walk), env);
- valuesv = alloca (sizeof (SCM)*len);
- for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
- valuesv[i] = EVAL1 (CAR (walk), env);
-
- wf = scm_i_make_with_fluids (len, fluidv, valuesv);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
- res = eval (CDDR (mx), env);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
-
- return res;
+ env = new_env;
+ x = CDR (mx);
+ goto loop;
}
+ case SCM_M_QUOTE:
+ return mx;
+
+ case SCM_M_CAPTURE_MODULE:
+ return eval (mx, scm_current_module ());
+
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
goto loop;
}
else
- return scm_call_with_vm (scm_the_vm (), proc, args);
+ return scm_apply_0 (proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
for (i = 0; i < argc; i++, mx = CDR (mx))
argv[i] = EVAL1 (CAR (mx), env);
- return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
+ return scm_call_n (proc, argv, argc);
}
case SCM_M_CONT:
producer = EVAL1 (CAR (mx), env);
/* `proc' is the consumer. */
proc = EVAL1 (CDR (mx), env);
- v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
+ v = scm_call_0 (producer);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
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;
+ SCM pos;
+ int depth, width;
+
+ pos = mx;
+ depth = SCM_I_INUM (CAR (pos));
+ width = SCM_I_INUM (CDR (pos));
+
+ return env_ref (env, depth, width);
}
case SCM_M_LEXICAL_SET:
{
- int n;
+ SCM pos;
+ int depth, width;
SCM val = EVAL1 (CDR (mx), env);
- for (n = SCM_I_INUM (CAR (mx)); n; n--)
- env = CDR (env);
- SCM_SETCAR (env, val);
+
+ pos = CAR (mx);
+ depth = SCM_I_INUM (CAR (pos));
+ width = SCM_I_INUM (CDR (pos));
+
+ env_set (env, depth, width, 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 = CDR (env);
- return SCM_VARIABLE_REF
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
- }
+ case SCM_M_BOX_REF:
+ {
+ SCM box = mx;
- case SCM_M_TOPLEVEL_SET:
+ return scm_variable_ref (EVAL1 (box, env));
+ }
+
+ case SCM_M_BOX_SET:
{
- SCM var = CAR (mx);
- SCM val = EVAL1 (CDR (mx), env);
- if (SCM_VARIABLEP (var))
- {
- SCM_VARIABLE_SET (var, val);
- return SCM_UNSPECIFIED;
- }
- else
- {
- while (scm_is_pair (env))
- env = CDR (env);
- SCM_VARIABLE_SET
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
- val);
- return SCM_UNSPECIFIED;
- }
+ SCM box = CAR (mx), val = CDR (mx);
+
+ return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
}
- case SCM_M_MODULE_REF:
+ case SCM_M_RESOLVE:
if (SCM_VARIABLEP (mx))
- return SCM_VARIABLE_REF (mx);
+ return 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), EVAL1 (CAR (mx), env));
- return SCM_UNSPECIFIED;
- }
- else
- {
- SCM_VARIABLE_SET
- (scm_memoize_variable_access_x (x, SCM_BOOL_F),
- EVAL1 (CAR (mx), env));
- return SCM_UNSPECIFIED;
+ SCM var;
+
+ var = scm_sys_resolve_variable (mx, env_tail (env));
+ scm_set_cdr_x (x, var);
+
+ return var;
}
- case SCM_M_PROMPT:
+ case SCM_M_CALL_WITH_PROMPT:
{
- SCM vm, res;
- /* We need the prompt and handler values after a longjmp case,
- so make sure they are volatile. */
- volatile SCM handler, prompt;
-
- vm = scm_the_vm ();
- prompt = scm_c_make_prompt (EVAL1 (CAR (mx), env),
- SCM_VM_DATA (vm)->fp,
- SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip,
- 0, -1, scm_i_dynwinds ());
+ struct scm_vm *vp;
+ SCM k, res;
+ scm_i_jmp_buf registers;
+ /* We need the handler after nonlocal return to the setjmp, so
+ make sure it is volatile. */
+ volatile SCM handler;
+
+ k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
- scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
-
- if (SCM_PROMPT_SETJMP (prompt))
+ vp = scm_the_vm ();
+
+ /* Push the prompt onto the dynamic stack. */
+ scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
+ | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
+ k,
+ vp->fp - vp->stack_base,
+ vp->sp - vp->stack_base,
+ vp->ip,
+ ®isters);
+
+ if (SCM_I_SETJMP (registers))
{
/* The prompt exited nonlocally. */
+ scm_gc_after_nonlocal_exit ();
proc = handler;
- args = scm_i_prompt_pop_abort_args_x (scm_the_vm ());
+ vp = scm_the_vm ();
+ args = scm_i_prompt_pop_abort_args_x (vp);
goto apply_proc;
}
- res = eval (CADR (mx), env);
- scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
+ res = scm_call_0 (eval (CADR (mx), env));
+ scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}
SCM
scm_call_0 (SCM proc)
{
- return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
+ return scm_call_n (proc, NULL, 0);
}
SCM
scm_call_1 (SCM proc, SCM arg1)
{
- return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
+ return scm_call_n (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);
+ return scm_call_n (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);
+ return scm_call_n (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);
+ return scm_call_n (proc, args, 4);
}
SCM
scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 5);
+ return scm_call_n (proc, args, 5);
}
SCM
SCM arg6)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 6);
+ return scm_call_n (proc, args, 6);
}
SCM
SCM arg6, SCM arg7)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 7);
+ return scm_call_n (proc, args, 7);
}
SCM
SCM arg6, SCM arg7, SCM arg8)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 8);
+ return scm_call_n (proc, args, 8);
}
SCM
SCM arg6, SCM arg7, SCM arg8, SCM arg9)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 9);
+ return scm_call_n (proc, args, 9);
}
-SCM
-scm_call_n (SCM proc, SCM *argv, size_t nargs)
-{
- return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
-}
+/* scm_call_n defined in vm.c */
SCM
scm_call (SCM proc, ...)
argv[i] = va_arg (argp, SCM);
va_end (argp);
- return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
+ return scm_call_n (proc, argv, nargs);
}
/* Simple procedure applies
SCM
scm_apply_0 (SCM proc, SCM args)
{
- return scm_apply (proc, args, SCM_EOL);
+ SCM *argv;
+ int i, nargs;
+
+ nargs = scm_ilength (args);
+ if (SCM_UNLIKELY (nargs < 0))
+ scm_wrong_type_arg_msg ("apply", 2, args, "list");
+
+ /* FIXME: Use vm_builtin_apply instead of alloca. */
+ argv = alloca (nargs * sizeof(SCM));
+ for (i = 0; i < nargs; i++)
+ {
+ argv[i] = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+
+ return scm_call_n (proc, argv, nargs);
}
SCM
scm_apply_1 (SCM proc, SCM arg1, SCM args)
{
- return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
+ return scm_apply_0 (proc, scm_cons (arg1, args));
}
SCM
scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
{
- return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
+ return scm_apply_0 (proc, scm_cons2 (arg1, arg2, args));
}
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)))
- lloc = SCM_CDRLOC (*lloc);
- SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
- *lloc = SCM_CAR (*lloc);
- return lst;
+ return scm_apply_0 (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)));
}
-#undef FUNC_NAME
static SCM map_var, for_each_var;
static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
scm_i_pthread_once (&once, init_map_var);
- return scm_apply (scm_variable_ref (map_var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (map_var),
+ scm_cons (proc, scm_cons (arg1, args)));
}
SCM
static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
scm_i_pthread_once (&once, init_for_each_var);
- return scm_apply (scm_variable_ref (for_each_var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (for_each_var),
+ scm_cons (proc, scm_cons (arg1, args)));
}
{
if (!SCM_EXPANDED_P (exp))
exp = scm_call_1 (scm_current_module_transformer (), exp);
- return eval (scm_memoize_expression (exp), SCM_EOL);
+ return eval (scm_memoize_expression (exp), SCM_BOOL_F);
}
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);
+ return scm_call_n (scm_variable_ref (var_primitive_eval),
+ &exp, 1);
}
/* 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:
+ This function's interface is a bit wonly. It takes 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. */
+
+ Usually you want to use scm_apply_0 or one of its cousins. */
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_call_with_vm (scm_the_vm (), proc, args);
+ return scm_apply_0 (proc,
+ scm_is_null (args) ? arg1 : scm_cons_star (arg1, args));
}
static void
{
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
SCM env = BOOT_CLOSURE_ENV (proc);
-
+ int i;
+
if (BOOT_CLOSURE_IS_FIXED (proc)
|| (BOOT_CLOSURE_IS_REST (proc)
&& !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
{
if (SCM_UNLIKELY (scm_ilength (args) != nreq))
scm_wrong_num_args (proc);
- for (; scm_is_pair (args); args = CDR (args))
- env = scm_cons (CAR (args), env);
+
+ env = make_env (nreq, SCM_UNDEFINED, env);
+ for (i = 0; i < nreq; args = CDR (args), i++)
+ env_set (env, 0, i, CAR (args));
*out_body = BOOT_CLOSURE_BODY (proc);
*out_env = env;
}
{
if (SCM_UNLIKELY (scm_ilength (args) < nreq))
scm_wrong_num_args (proc);
- for (; nreq; nreq--, args = CDR (args))
- env = scm_cons (CAR (args), env);
- env = scm_cons (args, env);
+
+ env = make_env (nreq + 1, SCM_UNDEFINED, env);
+ for (i = 0; i < nreq; args = CDR (args), i++)
+ env_set (env, 0, i, CAR (args));
+ env_set (env, 0, i++, args);
+
*out_body = BOOT_CLOSURE_BODY (proc);
*out_env = env;
}
else
{
- int i, argc, nreq, nopt;
- SCM body, rest, kw, inits, alt;
+ int i, argc, nreq, nopt, ninits, nenv;
+ SCM body, rest, kw, unbound, alt;
SCM mx = BOOT_CLOSURE_CODE (proc);
loop:
- BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, inits, alt);
+ BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw,
+ ninits, unbound, alt);
argc = scm_ilength (args);
if (argc < nreq)
else
scm_wrong_num_args (proc);
}
+ if (scm_is_true (kw) && scm_is_false (rest))
+ {
+ int npos = 0;
+ SCM walk;
+ for (walk = args; scm_is_pair (walk); walk = CDR (walk), npos++)
+ if (npos >= nreq && scm_is_keyword (CAR (walk)))
+ break;
+
+ if (npos > nreq + nopt)
+ {
+ /* Too many positional args and no rest arg. */
+ if (scm_is_true (alt))
+ {
+ mx = alt;
+ goto loop;
+ }
+ else
+ scm_wrong_num_args (proc);
+ }
+ }
+
+ /* At this point we are committed to the chosen clause. */
+ nenv = nreq + (scm_is_true (rest) ? 1 : 0) + ninits;
+ env = make_env (nenv, unbound, env);
for (i = 0; i < nreq; i++, args = CDR (args))
- env = scm_cons (CAR (args), env);
+ env_set (env, 0, i, CAR (args));
if (scm_is_false (kw))
{
/* Optional args (possibly), but no keyword args. */
- for (; i < argc && i < nreq + nopt;
- i++, args = CDR (args))
- {
- env = scm_cons (CAR (args), env);
- inits = CDR (inits);
- }
-
- for (; i < nreq + nopt; i++, inits = CDR (inits))
- env = scm_cons (EVAL1 (CAR (inits), env), env);
-
+ for (; i < argc && i < nreq + nopt; i++, args = CDR (args))
+ env_set (env, 0, i, CAR (args));
if (scm_is_true (rest))
- env = scm_cons (args, env);
+ env_set (env, 0, nreq + nopt, args);
}
else
{
aok = CAR (kw);
kw = CDR (kw);
- /* Keyword args. As before, but stop at the first keyword. */
+ /* Optional args. As before, but stop at the first keyword. */
for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args));
- i++, args = CDR (args), inits = CDR (inits))
- env = scm_cons (CAR (args), env);
-
- for (; i < nreq + nopt; i++, inits = CDR (inits))
- env = scm_cons (EVAL1 (CAR (inits), env), env);
-
+ i++, args = CDR (args))
+ env_set (env, 0, i, CAR (args));
if (scm_is_true (rest))
- {
- env = scm_cons (args, env);
- i++;
- }
- else if (scm_is_true (alt)
- && scm_is_pair (args) && !scm_is_keyword (CAR (args)))
- {
- /* Too many positional args, no rest arg, and we have an
- alternate clause. */
- mx = alt;
- goto loop;
- }
+ env_set (env, 0, nreq + nopt, args);
- /* Now fill in env with unbound values, limn the rest of the args for
- keywords, and fill in unbound values with their inits. */
+ /* Parse keyword args. */
{
- int imax = i - 1;
- int kw_start_idx = i;
- SCM walk, k, v;
- for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
- if (SCM_I_INUM (CDAR (walk)) > imax)
- imax = SCM_I_INUM (CDAR (walk));
- for (; i <= imax; i++)
- env = scm_cons (SCM_UNDEFINED, env);
+ SCM walk;
if (scm_is_pair (args) && scm_is_pair (CDR (args)))
for (; scm_is_pair (args) && scm_is_pair (CDR (args));
args = CDR (args))
{
- k = CAR (args); v = CADR (args);
+ SCM k = CAR (args), v = CADR (args);
if (!scm_is_keyword (k))
{
if (scm_is_true (rest))
for (walk = kw; scm_is_pair (walk); walk = CDR (walk))
if (scm_is_eq (k, CAAR (walk)))
{
- /* Well... ok, list-set! isn't the nicest interface, but
- hey. */
- int iset = imax - SCM_I_INUM (CDAR (walk));
- scm_list_set_x (env, SCM_I_MAKINUM (iset), v);
+ env_set (env, 0, SCM_I_INUM (CDAR (walk)), v);
args = CDR (args);
break;
}
}
if (scm_is_pair (args) && scm_is_false (rest))
error_invalid_keyword (proc, CAR (args));
-
- /* Now fill in unbound values, evaluating init expressions in their
- appropriate environment. */
- for (i = imax - kw_start_idx; scm_is_pair (inits); i--, inits = CDR (inits))
- {
- SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i));
- if (SCM_UNBNDP (CAR (tail)))
- SCM_SETCAR (tail, EVAL1 (CAR (inits), CDR (tail)));
- }
}
}
{
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
SCM new_env = BOOT_CLOSURE_ENV (proc);
- if (BOOT_CLOSURE_IS_FIXED (proc)
- || (BOOT_CLOSURE_IS_REST (proc)
- && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
+ if ((BOOT_CLOSURE_IS_FIXED (proc)
+ || (BOOT_CLOSURE_IS_REST (proc)
+ && !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
+ && nreq == argc)
{
- for (; scm_is_pair (exps); exps = CDR (exps), nreq--)
- new_env = scm_cons (EVAL1 (CAR (exps), *inout_env),
- new_env);
- if (SCM_UNLIKELY (nreq != 0))
- scm_wrong_num_args (proc);
+ int i;
+
+ new_env = make_env (nreq, SCM_UNDEFINED, new_env);
+ for (i = 0; i < nreq; exps = CDR (exps), i++)
+ env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
+
*out_body = BOOT_CLOSURE_BODY (proc);
*inout_env = new_env;
}
- else if (BOOT_CLOSURE_IS_REST (proc))
+ else if (BOOT_CLOSURE_IS_REST (proc) && argc >= nreq)
{
- if (SCM_UNLIKELY (argc < nreq))
- scm_wrong_num_args (proc);
- for (; nreq; nreq--, exps = CDR (exps))
- new_env = scm_cons (EVAL1 (CAR (exps), *inout_env),
- new_env);
- {
- SCM rest = SCM_EOL;
- for (; scm_is_pair (exps); exps = CDR (exps))
- rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
- new_env = scm_cons (scm_reverse (rest),
- new_env);
- }
+ SCM rest;
+ int i;
+
+ new_env = make_env (nreq + 1, SCM_UNDEFINED, new_env);
+ for (i = 0; i < nreq; exps = CDR (exps), i++)
+ env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env));
+ for (rest = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
+ rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest);
+ env_set (new_env, 0, i++, scm_reverse_x (rest, SCM_UNDEFINED));
+
*out_body = BOOT_CLOSURE_BODY (proc);
*inout_env = new_env;
}
boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
{
SCM args;
- scm_puts ("#<boot-closure ", port);
- scm_uintprint ((scm_t_bits)SCM2PTR (closure), 16, port);
- scm_putc (' ', port);
+ scm_puts_unlocked ("#<boot-closure ", port);
+ scm_uintprint (SCM_UNPACK (closure), 16, port);
+ scm_putc_unlocked (' ', port);
args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
scm_from_latin1_symbol ("_"));
if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
args = scm_cons_star (scm_from_latin1_symbol ("_"), args);
/* FIXME: optionals and rests */
scm_display (args, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
-/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2015 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
case scm_tc7_wvect:
case scm_tc7_pointer:
case scm_tc7_hashtable:
+ case scm_tc7_weak_set:
+ case scm_tc7_weak_table:
case scm_tc7_fluid:
case scm_tc7_dynamic_state:
case scm_tc7_frame:
- case scm_tc7_objcode:
- case scm_tc7_vm:
+ case scm_tc7_keyword:
case scm_tc7_vm_cont:
case scm_tc7_number:
case scm_tc7_string:
#ifndef SCM_EVALEXT_H
#define SCM_EVALEXT_H
-/* Copyright (C) 1998,1999,2000, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000, 2003, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
SCM_API SCM scm_self_evaluating_p (SCM obj);
SCM_INTERNAL void scm_init_evalext (void);
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-#define scm_definedp scm_defined_p
-
-#endif
-
#endif /* SCM_EVALEXT_H */
/*
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2012
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013,2014
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
SCM scm_exp_vtable_vtable;
static SCM exp_vtables[SCM_NUM_EXPANDED_TYPES];
static size_t exp_nfields[SCM_NUM_EXPANDED_TYPES];
+static SCM const_unbound;
static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
SCM_MAKE_EXPANDED_VOID(src)
#define CONST_(src, exp) \
SCM_MAKE_EXPANDED_CONST(src, exp)
-#define PRIMITIVE_REF_TYPE(src, name) \
- SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name)
+#define PRIMITIVE_REF(src, name) \
+ SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name)
#define LEXICAL_REF(src, name, gensym) \
SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
#define LEXICAL_SET(src, name, gensym, exp) \
SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
#define CONDITIONAL(src, test, consequent, alternate) \
SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
-#define APPLICATION(src, proc, exps) \
- SCM_MAKE_EXPANDED_APPLICATION(src, proc, exps)
-#define SEQUENCE(src, exps) \
- SCM_MAKE_EXPANDED_SEQUENCE(src, exps)
+#define PRIMCALL(src, name, exps) \
+ SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps)
+#define CALL(src, proc, exps) \
+ SCM_MAKE_EXPANDED_CALL(src, proc, exps)
+#define SEQ(src, head, tail) \
+ SCM_MAKE_EXPANDED_SEQ(src, head, tail)
#define LAMBDA(src, meta, body) \
SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
#define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
#define LETREC(src, in_order_p, names, gensyms, vals, body) \
SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
-#define DYNLET(src, fluids, vals, body) \
- SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
#define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x)
#define CDDDR(x) SCM_CDDDR(x)
#define CADDDR(x) SCM_CADDDR(x)
+/* Abbreviate SCM_EXPANDED_REF. */
+#define REF(x,type,field) \
+ (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
+
static const char s_bad_expression[] = "Bad expression";
static const char s_expression[] = "Missing or extra expression in";
SCM_SYNTAX ("@@", expand_atat);
SCM_SYNTAX ("begin", expand_begin);
SCM_SYNTAX ("define", expand_define);
-SCM_SYNTAX ("with-fluids", expand_with_fluids);
SCM_SYNTAX ("eval-when", expand_eval_when);
SCM_SYNTAX ("if", expand_if);
SCM_SYNTAX ("lambda", expand_lambda);
SCM_SYNTAX ("case-lambda*", expand_case_lambda_star);
-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_at_dynamic_wind, "@dynamic-wind");
-SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
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_letrec, "letrec");
SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
-SCM_GLOBAL_SYMBOL (scm_sym_at_prompt, "@prompt");
+SCM_SYMBOL (sym_call_with_prompt, "call-with-prompt");
SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
SCM_SYMBOL (sym_lambda_star, "lambda*");
SCM_SYMBOL (sym_eval, "eval");
SCM_SYMBOL (sym_load, "load");
+SCM_SYMBOL (sym_primitive, "primitive");
SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
{
SCM arg_exps = SCM_EOL;
SCM args = SCM_EOL;
- SCM proc = CAR (exp);
+ SCM proc = expand (CAR (exp), env);
for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
arg_exps = CDR (arg_exps))
args = scm_cons (expand (CAR (arg_exps), env), args);
- if (scm_is_null (arg_exps))
- return APPLICATION (scm_source_properties (exp),
- expand (proc, env),
- scm_reverse_x (args, SCM_UNDEFINED));
- else
+ args = scm_reverse_x (args, SCM_UNDEFINED);
+
+ if (!scm_is_null (arg_exps))
syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
+
+ if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF)
+ return PRIMCALL (scm_source_properties (exp),
+ SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
+ args);
+ else
+ return CALL (scm_source_properties (exp), proc, args);
}
}
else if (scm_is_symbol (exp))
if (scm_is_null (CDR (forms)))
return expand (CAR (forms), env);
else
- return SEQUENCE (SCM_BOOL_F, expand_exprs (forms, env));
+ return SEQ (scm_source_properties (forms),
+ expand (CAR (forms), env),
+ expand_sequence (CDR (forms), env));
}
expand_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);
+ if (scm_is_eq (CADR (expr), sym_primitive))
+ return PRIMITIVE_REF (scm_source_properties (expr), CADDR (expr));
+
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
return MODULE_REF (scm_source_properties (expr),
CADR (expr), CADDR (expr), SCM_BOOL_F);
}
scm_list_1 (expand (test, env)),
CONDITIONAL (SCM_BOOL_F,
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
- APPLICATION (SCM_BOOL_F,
- expand (CADDR (clause), new_env),
- scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
- tmp, tmp))),
+ CALL (SCM_BOOL_F,
+ expand (CADDR (clause), new_env),
+ scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
+ tmp, tmp))),
rest));
}
/* FIXME length == 1 case */
expand (CAR (body), env));
}
-static SCM
-expand_with_fluids (SCM expr, SCM env)
-{
- SCM binds, fluids, vals;
- ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
- binds = CADR (expr);
- ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
- for (fluids = SCM_EOL, vals = SCM_EOL;
- scm_is_pair (binds);
- binds = CDR (binds))
- {
- SCM binding = CAR (binds);
- ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
- binding, expr);
- fluids = scm_cons (expand (CAR (binding), env), fluids);
- vals = scm_cons (expand (CADR (binding), env), vals);
- }
-
- return DYNLET (scm_source_properties (expr),
- scm_reverse_x (fluids, SCM_UNDEFINED),
- scm_reverse_x (vals, SCM_UNDEFINED),
- expand_sequence (CDDR (expr), env));
-}
-
static SCM
expand_eval_when (SCM expr, SCM env)
{
scm_list_1 (name), scm_list_1 (name_sym),
scm_list_1 (LAMBDA (SCM_BOOL_F,
SCM_EOL,
- LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_BOOL_F, SCM_BOOL_F,
- SCM_BOOL_F, SCM_BOOL_F, var_syms,
+ LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F,
+ SCM_BOOL_F, SCM_EOL, var_syms,
expand_sequence (CDDDR (expr), inner_env),
SCM_BOOL_F))),
- APPLICATION (SCM_BOOL_F,
- LEXICAL_REF (SCM_BOOL_F, name, name_sym),
- expand_exprs (inits, env)));
+ CALL (SCM_BOOL_F,
+ LEXICAL_REF (SCM_BOOL_F, name, name_sym),
+ expand_exprs (inits, env)));
}
static SCM
#undef FUNC_NAME
- \f
+\f
+
+static void
+compute_assigned (SCM exp, SCM assigned)
+{
+ if (scm_is_null (exp) || scm_is_false (exp))
+ return;
+
+ if (scm_is_pair (exp))
+ {
+ compute_assigned (CAR (exp), assigned);
+ compute_assigned (CDR (exp), assigned);
+ return;
+ }
+
+ if (!SCM_EXPANDED_P (exp))
+ abort ();
+
+ switch (SCM_EXPANDED_TYPE (exp))
+ {
+ case SCM_EXPANDED_VOID:
+ case SCM_EXPANDED_CONST:
+ case SCM_EXPANDED_PRIMITIVE_REF:
+ case SCM_EXPANDED_LEXICAL_REF:
+ case SCM_EXPANDED_MODULE_REF:
+ case SCM_EXPANDED_TOPLEVEL_REF:
+ return;
+
+ case SCM_EXPANDED_LEXICAL_SET:
+ scm_hashq_set_x (assigned, REF (exp, LEXICAL_SET, GENSYM), SCM_BOOL_T);
+ compute_assigned (REF (exp, LEXICAL_SET, EXP), assigned);
+ return;
+
+ case SCM_EXPANDED_MODULE_SET:
+ compute_assigned (REF (exp, MODULE_SET, EXP), assigned);
+ return;
+
+ case SCM_EXPANDED_TOPLEVEL_SET:
+ compute_assigned (REF (exp, TOPLEVEL_SET, EXP), assigned);
+ return;
+
+ case SCM_EXPANDED_TOPLEVEL_DEFINE:
+ compute_assigned (REF (exp, TOPLEVEL_DEFINE, EXP), assigned);
+ return;
+
+ case SCM_EXPANDED_CONDITIONAL:
+ compute_assigned (REF (exp, CONDITIONAL, TEST), assigned);
+ compute_assigned (REF (exp, CONDITIONAL, CONSEQUENT), assigned);
+ compute_assigned (REF (exp, CONDITIONAL, ALTERNATE), assigned);
+ return;
+
+ case SCM_EXPANDED_CALL:
+ compute_assigned (REF (exp, CALL, PROC), assigned);
+ compute_assigned (REF (exp, CALL, ARGS), assigned);
+ return;
+
+ case SCM_EXPANDED_PRIMCALL:
+ compute_assigned (REF (exp, PRIMCALL, ARGS), assigned);
+ return;
+
+ case SCM_EXPANDED_SEQ:
+ compute_assigned (REF (exp, SEQ, HEAD), assigned);
+ compute_assigned (REF (exp, SEQ, TAIL), assigned);
+ return;
+
+ case SCM_EXPANDED_LAMBDA:
+ compute_assigned (REF (exp, LAMBDA, BODY), assigned);
+ return;
+
+ case SCM_EXPANDED_LAMBDA_CASE:
+ compute_assigned (REF (exp, LAMBDA_CASE, INITS), assigned);
+ compute_assigned (REF (exp, LAMBDA_CASE, BODY), assigned);
+ compute_assigned (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
+ return;
+
+ case SCM_EXPANDED_LET:
+ compute_assigned (REF (exp, LET, VALS), assigned);
+ compute_assigned (REF (exp, LET, BODY), assigned);
+ return;
+
+ case SCM_EXPANDED_LETREC:
+ {
+ SCM syms = REF (exp, LETREC, GENSYMS);
+ /* We lower letrec in this same pass, so mark these variables as
+ assigned. */
+ for (; scm_is_pair (syms); syms = CDR (syms))
+ scm_hashq_set_x (assigned, CAR (syms), SCM_BOOL_T);
+ }
+ compute_assigned (REF (exp, LETREC, VALS), assigned);
+ compute_assigned (REF (exp, LETREC, BODY), assigned);
+ return;
+
+ default:
+ abort ();
+ }
+}
+
+static SCM
+box_value (SCM exp)
+{
+ return PRIMCALL (SCM_BOOL_F, scm_from_latin1_symbol ("make-variable"),
+ scm_list_1 (exp));
+}
+
+static SCM
+box_lexical (SCM name, SCM sym)
+{
+ return LEXICAL_SET (SCM_BOOL_F, name, sym,
+ box_value (LEXICAL_REF (SCM_BOOL_F, name, sym)));
+}
+
+static SCM
+init_if_unbound (SCM src, SCM name, SCM sym, SCM init)
+{
+ return CONDITIONAL (src,
+ PRIMCALL (src,
+ scm_from_latin1_symbol ("eq?"),
+ scm_list_2 (LEXICAL_REF (src, name, sym),
+ const_unbound)),
+ LEXICAL_SET (src, name, sym, init),
+ VOID_ (src));
+}
+
+static SCM
+init_boxes (SCM names, SCM syms, SCM vals, SCM body)
+{
+ if (scm_is_null (names)) return body;
+
+ return SEQ (SCM_BOOL_F,
+ PRIMCALL
+ (SCM_BOOL_F,
+ scm_from_latin1_symbol ("variable-set!"),
+ scm_list_2 (LEXICAL_REF (SCM_BOOL_F, CAR (names), CAR (syms)),
+ CAR (vals))),
+ init_boxes (CDR (names), CDR (syms), CDR (vals), body));
+}
+
+static SCM
+convert_assignment (SCM exp, SCM assigned)
+{
+ if (scm_is_null (exp) || scm_is_false (exp))
+ return exp;
+
+ if (scm_is_pair (exp))
+ return scm_cons (convert_assignment (CAR (exp), assigned),
+ convert_assignment (CDR (exp), assigned));
+
+ if (!SCM_EXPANDED_P (exp))
+ abort ();
+
+ switch (SCM_EXPANDED_TYPE (exp))
+ {
+ case SCM_EXPANDED_VOID:
+ case SCM_EXPANDED_CONST:
+ case SCM_EXPANDED_PRIMITIVE_REF:
+ case SCM_EXPANDED_MODULE_REF:
+ case SCM_EXPANDED_TOPLEVEL_REF:
+ return exp;
+
+ case SCM_EXPANDED_LEXICAL_REF:
+ {
+ SCM sym = REF (exp, LEXICAL_REF, GENSYM);
+
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ return PRIMCALL
+ (REF (exp, LEXICAL_REF, SRC),
+ scm_from_latin1_symbol ("variable-ref"),
+ scm_list_1 (exp));
+ return exp;
+ }
+
+ case SCM_EXPANDED_LEXICAL_SET:
+ return PRIMCALL
+ (REF (exp, LEXICAL_SET, SRC),
+ scm_from_latin1_symbol ("variable-set!"),
+ scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, SRC),
+ REF (exp, LEXICAL_SET, NAME),
+ REF (exp, LEXICAL_SET, GENSYM)),
+ convert_assignment (REF (exp, LEXICAL_SET, EXP),
+ assigned)));
+
+ case SCM_EXPANDED_MODULE_SET:
+ return MODULE_SET
+ (REF (exp, MODULE_SET, SRC),
+ REF (exp, MODULE_SET, MOD),
+ REF (exp, MODULE_SET, NAME),
+ REF (exp, MODULE_SET, PUBLIC),
+ convert_assignment (REF (exp, MODULE_SET, EXP), assigned));
+
+ case SCM_EXPANDED_TOPLEVEL_SET:
+ return TOPLEVEL_SET
+ (REF (exp, TOPLEVEL_SET, SRC),
+ REF (exp, TOPLEVEL_SET, NAME),
+ convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned));
+
+ case SCM_EXPANDED_TOPLEVEL_DEFINE:
+ return TOPLEVEL_DEFINE
+ (REF (exp, TOPLEVEL_DEFINE, SRC),
+ REF (exp, TOPLEVEL_DEFINE, NAME),
+ convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP),
+ assigned));
+
+ case SCM_EXPANDED_CONDITIONAL:
+ return CONDITIONAL
+ (REF (exp, CONDITIONAL, SRC),
+ convert_assignment (REF (exp, CONDITIONAL, TEST), assigned),
+ convert_assignment (REF (exp, CONDITIONAL, CONSEQUENT), assigned),
+ convert_assignment (REF (exp, CONDITIONAL, ALTERNATE), assigned));
+
+ case SCM_EXPANDED_CALL:
+ return CALL
+ (REF (exp, CALL, SRC),
+ convert_assignment (REF (exp, CALL, PROC), assigned),
+ convert_assignment (REF (exp, CALL, ARGS), assigned));
+
+ case SCM_EXPANDED_PRIMCALL:
+ return PRIMCALL
+ (REF (exp, PRIMCALL, SRC),
+ REF (exp, PRIMCALL, NAME),
+ convert_assignment (REF (exp, PRIMCALL, ARGS), assigned));
+
+ case SCM_EXPANDED_SEQ:
+ return SEQ
+ (REF (exp, SEQ, SRC),
+ convert_assignment (REF (exp, SEQ, HEAD), assigned),
+ convert_assignment (REF (exp, SEQ, TAIL), assigned));
+
+ case SCM_EXPANDED_LAMBDA:
+ return LAMBDA
+ (REF (exp, LAMBDA, SRC),
+ REF (exp, LAMBDA, META),
+ scm_is_false (REF (exp, LAMBDA, BODY))
+ /* Give a body to case-lambda with no clauses. */
+ ? LAMBDA_CASE (SCM_BOOL_F, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F,
+ SCM_EOL, SCM_EOL,
+ PRIMCALL
+ (SCM_BOOL_F,
+ scm_from_latin1_symbol ("throw"),
+ scm_list_5 (CONST_ (SCM_BOOL_F, scm_args_number_key),
+ CONST_ (SCM_BOOL_F, SCM_BOOL_F),
+ CONST_ (SCM_BOOL_F, scm_from_latin1_string
+ ("Wrong number of arguments")),
+ CONST_ (SCM_BOOL_F, SCM_EOL),
+ CONST_ (SCM_BOOL_F, SCM_BOOL_F))),
+ SCM_BOOL_F)
+ : convert_assignment (REF (exp, LAMBDA, BODY), assigned));
+
+ case SCM_EXPANDED_LAMBDA_CASE:
+ {
+ SCM src, req, opt, rest, kw, inits, syms, body, alt;
+ SCM namewalk, symwalk, new_inits, seq;
+
+ /* Box assigned formals. Since initializers can capture
+ previous formals, we convert initializers to be in the body
+ instead of in the "header". */
+
+ src = REF (exp, LAMBDA_CASE, SRC);
+ req = REF (exp, LAMBDA_CASE, REQ);
+ opt = REF (exp, LAMBDA_CASE, OPT);
+ rest = REF (exp, LAMBDA_CASE, REST);
+ kw = REF (exp, LAMBDA_CASE, KW);
+ inits = convert_assignment (REF (exp, LAMBDA_CASE, INITS), assigned);
+ syms = REF (exp, LAMBDA_CASE, GENSYMS);
+ body = convert_assignment (REF (exp, LAMBDA_CASE, BODY), assigned);
+ alt = convert_assignment (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
+
+ new_inits = scm_make_list (scm_length (inits), const_unbound);
+
+ seq = SCM_EOL, symwalk = syms;
+
+ /* Required arguments may need boxing. */
+ for (namewalk = req;
+ scm_is_pair (namewalk);
+ namewalk = CDR (namewalk), symwalk = CDR (symwalk))
+ {
+ SCM name = CAR (namewalk), sym = CAR (symwalk);
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ seq = scm_cons (box_lexical (name, sym), seq);
+ }
+ /* Optional arguments may need initialization and/or boxing. */
+ for (namewalk = opt;
+ scm_is_pair (namewalk);
+ namewalk = CDR (namewalk), symwalk = CDR (symwalk),
+ inits = CDR (inits))
+ {
+ SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (inits);
+ seq = scm_cons (init_if_unbound (src, name, sym, init), seq);
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ seq = scm_cons (box_lexical (name, sym), seq);
+ }
+ /* Rest arguments may need boxing. */
+ if (scm_is_true (rest))
+ {
+ SCM sym = CAR (symwalk);
+ symwalk = CDR (symwalk);
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ seq = scm_cons (box_lexical (rest, sym), seq);
+ }
+ /* The rest of the arguments, if any, are keyword arguments,
+ which may need initialization and/or boxing. */
+ for (;
+ scm_is_pair (symwalk);
+ symwalk = CDR (symwalk), inits = CDR (inits))
+ {
+ SCM sym = CAR (symwalk), init = CAR (inits);
+ seq = scm_cons (init_if_unbound (src, SCM_BOOL_F, sym, init), seq);
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ seq = scm_cons (box_lexical (SCM_BOOL_F, sym), seq);
+ }
+
+ for (; scm_is_pair (seq); seq = CDR (seq))
+ body = SEQ (src, CAR (seq), body);
+
+ return LAMBDA_CASE
+ (src, req, opt, rest, kw, new_inits, syms, body, alt);
+ }
+
+ case SCM_EXPANDED_LET:
+ {
+ SCM src, names, syms, vals, body, new_vals, walk;
+
+ src = REF (exp, LET, SRC);
+ names = REF (exp, LET, NAMES);
+ syms = REF (exp, LET, GENSYMS);
+ vals = convert_assignment (REF (exp, LET, VALS), assigned);
+ body = convert_assignment (REF (exp, LET, BODY), assigned);
+
+ for (new_vals = SCM_EOL, walk = syms;
+ scm_is_pair (vals);
+ vals = CDR (vals), walk = CDR (walk))
+ {
+ SCM sym = CAR (walk), val = CAR (vals);
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ new_vals = scm_cons (box_value (val), new_vals);
+ else
+ new_vals = scm_cons (val, new_vals);
+ }
+ new_vals = scm_reverse (new_vals);
+
+ return LET (src, names, syms, new_vals, body);
+ }
+
+ case SCM_EXPANDED_LETREC:
+ {
+ SCM src, names, syms, vals, empty_box, boxes, body;
+
+ src = REF (exp, LETREC, SRC);
+ names = REF (exp, LETREC, NAMES);
+ syms = REF (exp, LETREC, GENSYMS);
+ vals = convert_assignment (REF (exp, LETREC, VALS), assigned);
+ body = convert_assignment (REF (exp, LETREC, BODY), assigned);
+
+ empty_box =
+ PRIMCALL (SCM_BOOL_F,
+ scm_from_latin1_symbol ("make-undefined-variable"),
+ SCM_EOL);
+ boxes = scm_make_list (scm_length (names), empty_box);
+
+ if (scm_is_true (REF (exp, LETREC, IN_ORDER_P)))
+ return LET
+ (src, names, syms, boxes,
+ init_boxes (names, syms, vals, body));
+ else
+ {
+ SCM walk, tmps = SCM_EOL, inits = SCM_EOL;
+
+ for (walk = syms; scm_is_pair (walk); walk = CDR (walk))
+ {
+ SCM tmp = scm_gensym (SCM_UNDEFINED);
+ tmps = scm_cons (tmp, tmps);
+ inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, SCM_BOOL_F, tmp),
+ inits);
+ }
+ tmps = scm_reverse (tmps);
+ inits = scm_reverse (inits);
+
+ return LET
+ (src, names, syms, boxes,
+ SEQ (src,
+ LET (src, names, tmps, vals,
+ init_boxes (names, syms, inits, VOID_ (src))),
+ body));
+ }
+ }
+
+ default:
+ abort ();
+ }
+}
+
+SCM
+scm_convert_assignment (SCM exp)
+{
+ SCM assigned = scm_c_make_hash_table (0);
+
+ compute_assigned (exp, assigned);
+ return convert_assignment (exp, assigned);
+}
+
+
+\f
#define DEFINE_NAMES(type) \
{ \
(scm_string_append (scm_make_list (scm_from_size_t (exp_nfields[n]),
scm_from_locale_string ("pw"))));
printer = SCM_BOOL_F;
- name = scm_from_locale_symbol (exp_names[n]);
+ name = scm_from_utf8_symbol (exp_names[n]);
code = scm_from_size_t (n);
fields = SCM_EOL;
{
size_t m = exp_nfields[n];
while (m--)
- fields = scm_cons (scm_from_locale_symbol (exp_field_names[n][m]), fields);
+ fields = scm_cons (scm_from_utf8_symbol (exp_field_names[n][m]), fields);
}
return scm_c_make_struct (scm_exp_vtable_vtable, 0, 5,
DEFINE_NAMES (TOPLEVEL_SET);
DEFINE_NAMES (TOPLEVEL_DEFINE);
DEFINE_NAMES (CONDITIONAL);
- DEFINE_NAMES (APPLICATION);
- DEFINE_NAMES (SEQUENCE);
+ DEFINE_NAMES (CALL);
+ DEFINE_NAMES (PRIMCALL);
+ DEFINE_NAMES (SEQ);
DEFINE_NAMES (LAMBDA);
DEFINE_NAMES (LAMBDA_CASE);
DEFINE_NAMES (LET);
DEFINE_NAMES (LETREC);
- DEFINE_NAMES (DYNLET);
scm_exp_vtable_vtable =
scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"),
while (n--)
exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list);
+ const_unbound =
+ CONST_ (SCM_BOOL_F, scm_list_1 (scm_from_latin1_symbol ("unbound")));
+
+ scm_c_define_gsubr ("convert-assignment", 1, 0, 0, scm_convert_assignment);
+
scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list));
#include "libguile/expand.x"
#ifndef SCM_EXPAND_H
#define SCM_EXPAND_H
-/* Copyright (C) 2010, 2011
+/* Copyright (C) 2010, 2011, 2013, 2014
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
SCM_EXPANDED_TOPLEVEL_SET,
SCM_EXPANDED_TOPLEVEL_DEFINE,
SCM_EXPANDED_CONDITIONAL,
- SCM_EXPANDED_APPLICATION,
- SCM_EXPANDED_SEQUENCE,
+ SCM_EXPANDED_CALL,
+ SCM_EXPANDED_PRIMCALL,
+ SCM_EXPANDED_SEQ,
SCM_EXPANDED_LAMBDA,
SCM_EXPANDED_LAMBDA_CASE,
SCM_EXPANDED_LET,
SCM_EXPANDED_LETREC,
- SCM_EXPANDED_DYNLET,
SCM_NUM_EXPANDED_TYPES,
} scm_t_expanded_type;
#define SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_CONDITIONAL], 0, SCM_NUM_EXPANDED_CONDITIONAL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (test), SCM_UNPACK (consequent), SCM_UNPACK (alternate))
-#define SCM_EXPANDED_APPLICATION_TYPE_NAME "application"
-#define SCM_EXPANDED_APPLICATION_FIELD_NAMES \
+#define SCM_EXPANDED_CALL_TYPE_NAME "call"
+#define SCM_EXPANDED_CALL_FIELD_NAMES \
{ "src", "proc", "args", }
enum
{
- SCM_EXPANDED_APPLICATION_SRC,
- SCM_EXPANDED_APPLICATION_PROC,
- SCM_EXPANDED_APPLICATION_ARGS,
- SCM_NUM_EXPANDED_APPLICATION_FIELDS,
+ SCM_EXPANDED_CALL_SRC,
+ SCM_EXPANDED_CALL_PROC,
+ SCM_EXPANDED_CALL_ARGS,
+ SCM_NUM_EXPANDED_CALL_FIELDS,
};
-#define SCM_MAKE_EXPANDED_APPLICATION(src, proc, args) \
- scm_c_make_struct (exp_vtables[SCM_EXPANDED_APPLICATION], 0, SCM_NUM_EXPANDED_APPLICATION_FIELDS, SCM_UNPACK (src), SCM_UNPACK (proc), SCM_UNPACK (args))
+#define SCM_MAKE_EXPANDED_CALL(src, proc, args) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_CALL], 0, SCM_NUM_EXPANDED_CALL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (proc), SCM_UNPACK (args))
-#define SCM_EXPANDED_SEQUENCE_TYPE_NAME "sequence"
-#define SCM_EXPANDED_SEQUENCE_FIELD_NAMES \
- { "src", "exps", }
+#define SCM_EXPANDED_PRIMCALL_TYPE_NAME "primcall"
+#define SCM_EXPANDED_PRIMCALL_FIELD_NAMES \
+ { "src", "name", "args", }
enum
{
- SCM_EXPANDED_SEQUENCE_SRC,
- SCM_EXPANDED_SEQUENCE_EXPS,
- SCM_NUM_EXPANDED_SEQUENCE_FIELDS,
+ SCM_EXPANDED_PRIMCALL_SRC,
+ SCM_EXPANDED_PRIMCALL_NAME,
+ SCM_EXPANDED_PRIMCALL_ARGS,
+ SCM_NUM_EXPANDED_PRIMCALL_FIELDS,
};
-#define SCM_MAKE_EXPANDED_SEQUENCE(src, exps) \
- scm_c_make_struct (exp_vtables[SCM_EXPANDED_SEQUENCE], 0, SCM_NUM_EXPANDED_SEQUENCE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (exps))
+#define SCM_MAKE_EXPANDED_PRIMCALL(src, name, args) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_PRIMCALL], 0, SCM_NUM_EXPANDED_PRIMCALL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (args))
+
+#define SCM_EXPANDED_SEQ_TYPE_NAME "seq"
+#define SCM_EXPANDED_SEQ_FIELD_NAMES \
+ { "src", "head", "tail", }
+enum
+ {
+ SCM_EXPANDED_SEQ_SRC,
+ SCM_EXPANDED_SEQ_HEAD,
+ SCM_EXPANDED_SEQ_TAIL,
+ SCM_NUM_EXPANDED_SEQ_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_SEQ(src, head, tail) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_SEQ], 0, SCM_NUM_EXPANDED_SEQ_FIELDS, SCM_UNPACK (src), SCM_UNPACK (head), SCM_UNPACK (tail))
#define SCM_EXPANDED_LAMBDA_TYPE_NAME "lambda"
#define SCM_EXPANDED_LAMBDA_FIELD_NAMES \
#define SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_LETREC], 0, SCM_NUM_EXPANDED_LETREC_FIELDS, SCM_UNPACK (src), SCM_UNPACK (in_order_p), SCM_UNPACK (names), SCM_UNPACK (gensyms), SCM_UNPACK (vals), SCM_UNPACK (body))
-#define SCM_EXPANDED_DYNLET_TYPE_NAME "dynlet"
-#define SCM_EXPANDED_DYNLET_FIELD_NAMES \
- { "src", "fluids", "vals", "body", }
-enum
- {
- SCM_EXPANDED_DYNLET_SRC,
- SCM_EXPANDED_DYNLET_FLUIDS,
- SCM_EXPANDED_DYNLET_VALS,
- SCM_EXPANDED_DYNLET_BODY,
- SCM_NUM_EXPANDED_DYNLET_FIELDS,
- };
-#define SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body) \
- scm_c_make_struct (exp_vtables[SCM_EXPANDED_DYNLET], 0, SCM_NUM_EXPANDED_DYNLET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (fluids), SCM_UNPACK (vals), SCM_UNPACK (body))
-
#endif /* BUILDING_LIBGUILE */
\f
SCM_INTERNAL SCM scm_macroexpand (SCM exp);
SCM_INTERNAL SCM scm_macroexpanded_p (SCM exp);
+SCM_INTERNAL SCM scm_convert_assignment (SCM exp);
+
SCM_INTERNAL void scm_init_expand (void);
scm_add_feature (const char *str)
{
SCM old = SCM_VARIABLE_REF (features_var);
- SCM new = scm_cons (scm_from_locale_symbol (str), old);
+ SCM new = scm_cons (scm_from_utf8_symbol (str), old);
SCM_VARIABLE_SET (features_var, new);
}
#ifdef vms
scm_add_feature(s_ed);
#endif
-#ifdef SICP
- scm_add_feature("sicp");
-#endif
#ifndef GO32
scm_add_feature("char-ready?");
#endif
-#ifndef CHEAP_CONTINUATIONS
- scm_add_feature ("full-continuation");
-#endif
#if SCM_USE_PTHREAD_THREADS
scm_add_feature ("threads");
#endif
#include "libguile/smob.h"
#include "libguile/feature.h"
#include "libguile/fports.h"
-#include "libguile/private-gc.h" /* for SCM_MAX */
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/dynwind.h"
eno = errno; scm_dynwind_end (); errno = eno; \
} while (0)
+
+#define MAX(A, B) ((A) > (B) ? (A) : (B))
+#define MIN(A, B) ((A) < (B) ? (A) : (B))
+
\f
#ifdef HAVE_POSIX
{
int max_fd = 0;
- if (scm_is_simple_vector (list_or_vec))
+ if (scm_is_vector (list_or_vec))
{
int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
{
SCM answer_list = ports_ready;
- if (scm_is_simple_vector (list_or_vec))
+ if (scm_is_vector (list_or_vec))
{
int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
SCM write_ports_ready = SCM_EOL;
int max_fd;
- if (scm_is_simple_vector (reads))
+ if (scm_is_vector (reads))
{
read_count = SCM_SIMPLE_VECTOR_LENGTH (reads);
}
read_count = scm_ilength (reads);
SCM_ASSERT (read_count >= 0, reads, SCM_ARG1, FUNC_NAME);
}
- if (scm_is_simple_vector (writes))
+ if (scm_is_vector (writes))
{
write_count = SCM_SIMPLE_VECTOR_LENGTH (writes);
}
write_count = scm_ilength (writes);
SCM_ASSERT (write_count >= 0, writes, SCM_ARG2, FUNC_NAME);
}
- if (scm_is_simple_vector (excepts))
+ if (scm_is_vector (excepts))
{
except_count = SCM_SIMPLE_VECTOR_LENGTH (excepts);
}
if (SCM_OPFPORTP (object))
{
- scm_flush (object);
+ scm_flush_unlocked (object);
fdes = SCM_FPORT_FDES (object);
}
else
{
size_t asked, obtained, written;
- asked = SCM_MIN (sizeof buf, left);
+ asked = MIN (sizeof buf, left);
obtained = full_read (in_fd, buf, asked);
if (obtained < asked)
{
SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
#if HAVE_READDIR_R
- /* As noted in the glibc manual, on various systems (such as Solaris) the
- d_name[] field is only 1 char and you're expected to size the dirent
- buffer for readdir_r based on NAME_MAX. The SCM_MAX expressions below
- effectively give either sizeof(d_name) or NAME_MAX+1, whichever is
- bigger.
+ /* As noted in the glibc manual, on various systems (such as Solaris)
+ the d_name[] field is only 1 char and you're expected to size the
+ dirent buffer for readdir_r based on NAME_MAX. The MAX expressions
+ below effectively give either sizeof(d_name) or NAME_MAX+1,
+ whichever is bigger.
On solaris 10 there's no NAME_MAX constant, it's necessary to use
pathconf(). We prefer NAME_MAX though, since it should be a constant
struct dirent_or_dirent64 de; /* just for sizeof */
DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port);
#ifdef NAME_MAX
- char buf [SCM_MAX (sizeof (de),
- sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)];
+ char buf [MAX (sizeof (de),
+ sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)];
#else
char *buf;
long name_max = fpathconf (dirfd (ds), _PC_NAME_MAX);
if (name_max == -1)
SCM_SYSERROR;
- buf = alloca (SCM_MAX (sizeof (de),
- sizeof (de) - sizeof (de.d_name) + name_max + 1));
+ buf = alloca (MAX (sizeof (de),
+ sizeof (de) - sizeof (de.d_name) + name_max + 1));
#endif
errno = 0;
static int
scm_dir_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
if (!SCM_DIR_OPEN_P (exp))
- scm_puts ("closed: ", port);
- scm_puts ("directory stream ", port);
+ scm_puts_unlocked ("closed: ", port);
+ scm_puts_unlocked ("directory stream ", port);
scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
#define SCM_FILESYS_H
/* Copyright (C) 1995, 1997, 1998, 1999, 2000, 2001, 2006, 2008, 2009,
- * 2010, 2013 Free Software Foundation, Inc.
+ * 2010, 2011, 2013 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_DIR_FLAG_OPEN (1L << 0)
-#define SCM_DIRP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_dir))
+#define SCM_DIRP(x) (SCM_HAS_TYP16 (x, scm_tc16_dir))
#define SCM_DIR_OPEN_P(x) (SCM_SMOB_FLAGS (x) & SCM_DIR_FLAG_OPEN)
\f
-/* Copyright (C) 2012, 2014 Free Software Foundation, Inc.
+/* Copyright (C) 2012, 2013, 2014 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 <unistd.h>
+#include <fcntl.h>
+
+#include <full-write.h>
+
#include "libguile/bdw-gc.h"
#include "libguile/_scm.h"
#include "libguile/finalizers.h"
\f
-#ifndef HAVE_GC_SET_FINALIZER_NOTIFIER
+#if SCM_USE_PTHREAD_THREADS
+
+static int finalization_pipe[2];
+static scm_i_pthread_mutex_t finalization_thread_lock =
+ SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static pthread_t finalization_thread;
+static int finalization_thread_is_running = 0;
+
static void
-GC_set_finalizer_notifier (void (*notifier) (void))
+notify_finalizers_to_run (void)
{
- GC_finalizer_notifier = notifier;
+ char byte = 0;
+ full_write (finalization_pipe[1], &byte, 1);
}
+
+static void
+notify_about_to_fork (void)
+{
+ char byte = 1;
+ full_write (finalization_pipe[1], &byte, 1);
+}
+
+struct finalization_pipe_data
+{
+ char byte;
+ ssize_t n;
+ int err;
+};
+
+static void*
+read_finalization_pipe_data (void *data)
+{
+ struct finalization_pipe_data *fdata = data;
+
+ fdata->n = read (finalization_pipe[0], &fdata->byte, 1);
+ fdata->err = errno;
+
+ return NULL;
+}
+
+static void*
+finalization_thread_proc (void *unused)
+{
+ while (1)
+ {
+ struct finalization_pipe_data data;
+
+ scm_without_guile (read_finalization_pipe_data, &data);
+
+ if (data.n <= 0 && data.err != EINTR)
+ {
+ perror ("error in finalization thread");
+ return NULL;
+ }
+
+ switch (data.byte)
+ {
+ case 0:
+ scm_run_finalizers ();
+ break;
+ case 1:
+ return NULL;
+ default:
+ abort ();
+ }
+ }
+}
+
+static void*
+run_finalization_thread (void *arg)
+{
+ return scm_with_guile (finalization_thread_proc, arg);
+}
+
+static void
+start_finalization_thread (void)
+{
+ scm_i_pthread_mutex_lock (&finalization_thread_lock);
+ if (!finalization_thread_is_running)
+ {
+ /* Use the raw pthread API and scm_with_guile, because we don't want
+ to block on any lock that scm_spawn_thread might want to take,
+ and we don't want to inherit the dynamic state (fluids) of the
+ caller. */
+ if (pthread_create (&finalization_thread, NULL,
+ run_finalization_thread, NULL))
+ perror ("error creating finalization thread");
+ else
+ finalization_thread_is_running = 1;
+ }
+ scm_i_pthread_mutex_unlock (&finalization_thread_lock);
+}
+
+static void
+stop_finalization_thread (void)
+{
+ scm_i_pthread_mutex_lock (&finalization_thread_lock);
+ if (finalization_thread_is_running)
+ {
+ notify_about_to_fork ();
+ if (pthread_join (finalization_thread, NULL))
+ perror ("joining finalization thread");
+ finalization_thread_is_running = 0;
+ }
+ scm_i_pthread_mutex_unlock (&finalization_thread_lock);
+}
+
+static void
+spawn_finalizer_thread (void)
+{
+ GC_set_finalizer_notifier (notify_finalizers_to_run);
+ start_finalization_thread ();
+}
+
+#endif /* SCM_USE_PTHREAD_THREADS */
+
+
+\f
+
+void
+scm_i_finalizer_pre_fork (void)
+{
+#if SCM_USE_PTHREAD_THREADS
+ if (automatic_finalization_p)
+ {
+ stop_finalization_thread ();
+ GC_set_finalizer_notifier (spawn_finalizer_thread);
+ }
#endif
+}
\f
+static void*
+weak_pointer_ref (void *weak_pointer)
+{
+ return *(void **) weak_pointer;
+}
+
+static void
+weak_gc_finalizer (void *ptr, void *data)
+{
+ void **weak = ptr;
+ void *val;
+ void (*callback) (SCM) = weak[1];
+
+ val = GC_call_with_alloc_lock (weak_pointer_ref, &weak[0]);
+
+ if (!val)
+ return;
+
+ callback (SCM_PACK_POINTER (val));
+
+ scm_i_set_finalizer (ptr, weak_gc_finalizer, data);
+}
+
+/* CALLBACK will be called on OBJ, as long as OBJ is accessible. It
+ will be called from a finalizer, which may be from an async or from
+ another thread.
+
+ As an implementation detail, the way this works is that we allocate
+ a fresh pointer-less object holding two words. We know that this
+ object should get collected the next time GC is run, so we attach a
+ finalizer to it so that we get a callback after GC happens.
+
+ The first word of the object holds a weak reference to OBJ, and the
+ second holds the callback pointer. When the callback is called, we
+ check if the weak reference on OBJ still holds. If it doesn't hold,
+ then OBJ is no longer accessible, and we're done. Otherwise we call
+ the callback and re-register a finalizer for our two-word GC object,
+ effectively resuscitating the object so that we will get a callback
+ on the next GC.
+
+ We could use the scm_after_gc_hook, but using a finalizer has the
+ advantage of potentially running in another thread, decreasing pause
+ time. */
+void
+scm_i_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
+{
+ void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2);
+
+ weak[0] = SCM_UNPACK_POINTER (obj);
+ weak[1] = (void*)callback;
+ GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj));
+
+ scm_i_set_finalizer (weak, weak_gc_finalizer, NULL);
+}
+
+
int
scm_set_automatic_finalization_enabled (int enabled_p)
{
return was_enabled_p;
}
- GC_set_finalizer_notifier (enabled_p ? queue_finalizer_async : 0);
+ if (enabled_p)
+ {
+#if SCM_USE_PTHREAD_THREADS
+ if (pipe2 (finalization_pipe, O_CLOEXEC) != 0)
+ scm_syserror (NULL);
+ GC_set_finalizer_notifier (spawn_finalizer_thread);
+#else
+ GC_set_finalizer_notifier (queue_finalizer_async);
+#endif
+ }
+ else
+ {
+ GC_set_finalizer_notifier (0);
+
+#if SCM_USE_PTHREAD_THREADS
+ stop_finalization_thread ();
+ close (finalization_pipe[0]);
+ close (finalization_pipe[1]);
+ finalization_pipe[0] = -1;
+ finalization_pipe[1] = -1;
+#endif
+ }
automatic_finalization_p = enabled_p;
if (automatic_finalization_p)
GC_set_finalizer_notifier (queue_finalizer_async);
}
+
+void
+scm_init_finalizer_thread (void)
+{
+#if SCM_USE_PTHREAD_THREADS
+ if (automatic_finalization_p)
+ {
+ if (pipe2 (finalization_pipe, O_CLOEXEC) != 0)
+ scm_syserror (NULL);
+ GC_set_finalizer_notifier (spawn_finalizer_thread);
+ }
+#endif
+}
#ifndef SCM_FINALIZERS_H
#define SCM_FINALIZERS_H
-/* Copyright (C) 2012, 2014 Free Software Foundation, Inc.
+/* Copyright (C) 2012, 2013, 2014 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_i_add_resuscitator (void *obj, scm_t_finalizer_proc,
void *data);
+SCM_INTERNAL void scm_i_finalizer_pre_fork (void);
+
+/* CALLBACK will be called on OBJ after each garbage collection, as long
+ as OBJ is accessible. It will be called from a finalizer, which may
+ be from an async or from another thread. */
+SCM_INTERNAL void scm_i_register_weak_gc_callback (SCM obj, void (*callback) (SCM));
+
SCM_API int scm_set_automatic_finalization_enabled (int enabled_p);
SCM_API int scm_run_finalizers (void);
SCM_INTERNAL void scm_init_finalizers (void);
+SCM_INTERNAL void scm_init_finalizer_thread (void);
#endif /* SCM_FINALIZERS_H */
# include <config.h>
#endif
-#include <alloca.h>
#include <stdio.h>
#include <string.h>
void
scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<fluid ", port);
+ scm_puts_unlocked ("#<fluid ", port);
scm_intprint ((int) FLUID_NUM (exp), 10, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
void
scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<dynamic-state ", port);
+ scm_puts_unlocked ("#<dynamic-state ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
-}
-
-void
-scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts ("#<with-fluids ", port);
- scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
\f
if (allocated_fluids[n] == NULL)
break;
- if (trial == 0 && n >= allocated_fluids_len)
+ if (trial == 0 && n >= allocated_fluids_len && allocated_fluids_len)
/* All fluid numbers are in use. Run a GC and retry. Explicitly
running the GC is costly and bad-style. We only do this because
dynamic state fluid vectors would grow unreasonably if fluid numbers
allocated_fluids_len += FLUID_GROW;
}
- allocated_fluids[n] = SCM2PTR (fluid);
+ allocated_fluids[n] = SCM_UNPACK_POINTER (fluid);
SCM_SET_CELL_WORD_0 (fluid, (scm_tc7_fluid | (n << 8)));
GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids[n],
return scm_call_0 (SCM_PACK (thunk));
}
-SCM
-scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals)
-{
- SCM ret;
-
- /* Ensure that there are no duplicates in the fluids set -- an N^2 operation,
- but N will usually be small, so perhaps that's OK. */
- {
- size_t i, j;
-
- for (j = n; j--;)
- for (i = j; i--;)
- if (scm_is_eq (fluids[i], fluids[j]))
- {
- vals[i] = vals[j]; /* later bindings win */
- n--;
- fluids[j] = fluids[n];
- vals[j] = vals[n];
- break;
- }
- }
-
- ret = scm_words (scm_tc7_with_fluids | (n << 8), 1 + n*2);
- SCM_SET_CELL_WORD_1 (ret, n);
-
- while (n--)
- {
- if (SCM_UNLIKELY (!IS_FLUID (fluids[n])))
- scm_wrong_type_arg ("with-fluids", 0, fluids[n]);
- SCM_SET_CELL_OBJECT (ret, 1 + n * 2, fluids[n]);
- SCM_SET_CELL_OBJECT (ret, 2 + n * 2, vals[n]);
- }
-
- return ret;
-}
-
void
-scm_i_swap_with_fluids (SCM wf, SCM dynstate)
+scm_swap_fluid (SCM fluid, SCM value_box, SCM dynstate)
{
- SCM fluids;
- size_t i, max = 0;
+ SCM fluid_vector, tmp;
+ size_t fluid_num;
- fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+ fluid_num = FLUID_NUM (fluid);
- /* We could cache the max in the with-fluids, but that would take more mem,
- and we're touching all the fluids anyway, so this per-swap traversal should
- be OK. */
- for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
- {
- size_t num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
- max = (max > num) ? max : num;
- }
+ fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate);
- if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+ if (SCM_UNLIKELY (fluid_num >= SCM_SIMPLE_VECTOR_LENGTH (fluid_vector)))
{
/* Lazily grow the current thread's dynamic state. */
grow_dynamic_state (dynstate);
- fluids = DYNAMIC_STATE_FLUIDS (dynstate);
+ fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate);
}
- /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */
- for (i = 0; i < SCM_WITH_FLUIDS_LEN (wf); i++)
- {
- size_t fluid_num;
- SCM x;
-
- fluid_num = FLUID_NUM (SCM_WITH_FLUIDS_NTH_FLUID (wf, i));
- x = SCM_SIMPLE_VECTOR_REF (fluids, fluid_num);
- SCM_SIMPLE_VECTOR_SET (fluids, fluid_num,
- SCM_WITH_FLUIDS_NTH_VAL (wf, i));
- SCM_WITH_FLUIDS_SET_NTH_VAL (wf, i, x);
- }
+ tmp = SCM_SIMPLE_VECTOR_REF (fluid_vector, fluid_num);
+ SCM_SIMPLE_VECTOR_SET (fluid_vector, fluid_num, SCM_VARIABLE_REF (value_box));
+ SCM_VARIABLE_SET (value_box, tmp);
}
SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0,
scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
#define FUNC_NAME "scm_c_with_fluids"
{
- SCM wf, ans;
+ SCM ans;
long flen, vlen, i;
- SCM *fluidsv, *valuesv;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
if (flen != vlen)
scm_out_of_range (s_scm_with_fluids, values);
- if (SCM_UNLIKELY (flen == 0))
- return cproc (cdata);
-
- fluidsv = alloca (sizeof(SCM)*flen);
- valuesv = alloca (sizeof(SCM)*flen);
-
for (i = 0; i < flen; i++)
{
- fluidsv[i] = SCM_CAR (fluids);
+ scm_dynstack_push_fluid (&thread->dynstack,
+ SCM_CAR (fluids), SCM_CAR (values),
+ thread->dynamic_state);
fluids = SCM_CDR (fluids);
- valuesv[i] = SCM_CAR (values);
values = SCM_CDR (values);
}
- wf = scm_i_make_with_fluids (flen, fluidsv, valuesv);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
ans = cproc (cdata);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+
+ for (i = 0; i < flen; i++)
+ scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
return ans;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_with_fluid, "with-fluid*", 3, 0, 0,
- (SCM fluid, SCM value, SCM thunk),
- "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
- "@var{thunk} must be a procedure with no argument.")
-#define FUNC_NAME s_scm_with_fluid
+SCM
+scm_with_fluid (SCM fluid, SCM value, SCM thunk)
{
return scm_c_with_fluid (fluid, value,
apply_thunk, (void *) SCM_UNPACK (thunk));
}
-#undef FUNC_NAME
SCM
scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
#define FUNC_NAME "scm_c_with_fluid"
{
- SCM ans, wf;
+ SCM ans;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
- wf = scm_i_make_with_fluids (1, &fluid, &value);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
+ scm_dynstack_push_fluid (&thread->dynstack, fluid, value,
+ thread->dynamic_state);
ans = cproc (cdata);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
return ans;
}
#ifndef SCM_FLUIDS_H
#define SCM_FLUIDS_H
-/* Copyright (C) 1996,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1996,2000,2001, 2006, 2008, 2009, 2010, 2011, 2012, 2013 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"
#include "libguile/vectors.h"
-/* These "with-fluids" objects live on the dynamic stack, and record previous
- values of fluids. Guile uses shallow binding, so the current fluid values are
- always in the same place for a given thread, in the dynamic-state vector.
- */
-
-#define SCM_WITH_FLUIDS_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_with_fluids)
-#define SCM_WITH_FLUIDS_LEN(x) (SCM_CELL_WORD ((x), 0) >> 8)
-#define SCM_WITH_FLUIDS_NTH_FLUID(x,n) (SCM_CELL_OBJECT ((x), 1 + (n)*2))
-#define SCM_WITH_FLUIDS_NTH_VAL(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2))
-#define SCM_WITH_FLUIDS_SET_NTH_VAL(x,n,v) (SCM_SET_CELL_OBJECT ((x), 2 + (n)*2, (v)))
-
/* Fluids.
grow.
*/
-#define SCM_FLUID_P(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_fluid)
+#define SCM_FLUID_P(x) (SCM_HAS_TYP7 (x, scm_tc7_fluid))
#ifdef BUILDING_LIBGUILE
#define SCM_I_FLUID_NUM(x) ((size_t)(SCM_CELL_WORD_0 (x) >> 8))
#define SCM_I_FLUID_DEFAULT(x) (SCM_CELL_OBJECT_1 (x))
SCM_API SCM scm_fluid_unset_x (SCM fluid);
SCM_API SCM scm_fluid_bound_p (SCM fluid);
-SCM_INTERNAL SCM scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals);
-SCM_INTERNAL void scm_i_swap_with_fluids (SCM with_fluids, SCM dynamic_state);
+SCM_INTERNAL void scm_swap_fluid (SCM fluid, SCM value_box, SCM dynamic_state);
SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals,
SCM (*cproc)(void *), void *cdata);
SCM_API void scm_dynwind_fluid (SCM fluid, SCM value);
#ifdef BUILDING_LIBGUILE
-#define SCM_I_DYNAMIC_STATE_P(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_dynamic_state)
+#define SCM_I_DYNAMIC_STATE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_dynamic_state))
#define SCM_I_DYNAMIC_STATE_FLUIDS(x) SCM_PACK (SCM_CELL_WORD_1 (x))
#endif
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_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_init_fluids (void);
#endif /* SCM_FLUIDS_H */
-/* Copyright (C) 2010-2014 Free Software Foundation, Inc.
+/* Copyright (C) 2010-2013 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 cell representing the null pointer. */
static SCM null_pointer;
-#if SIZEOF_VOID_P == 4
-# define scm_to_uintptr scm_to_uint32
-# define scm_from_uintptr scm_from_uint32
-#elif SIZEOF_VOID_P == 8
-# define scm_to_uintptr scm_to_uint64
-# define scm_from_uintptr scm_from_uint64
-#else
-# error unsupported pointer size
-#endif
-
/* Raise a null pointer dereference error. */
static void
static SCM pointer_weak_refs = SCM_BOOL_F;
-static scm_i_pthread_mutex_t weak_refs_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
static void
register_weak_reference (SCM from, SCM to)
{
- scm_i_pthread_mutex_lock (&weak_refs_lock);
- scm_hashq_set_x (pointer_weak_refs, from, to);
- scm_i_pthread_mutex_unlock (&weak_refs_lock);
+ scm_weak_table_putq_x (pointer_weak_refs, from, to);
}
static void
pointer_finalizer_trampoline (void *ptr, void *data)
{
scm_t_pointer_finalizer finalizer = data;
- finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
+ finalizer (SCM_POINTER_VALUE (SCM_PACK_POINTER (ptr)));
}
SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0,
void *c_finalizer;
scm_t_uintptr c_address;
- c_address = scm_to_uintptr (address);
+ c_address = scm_to_uintptr_t (address);
if (SCM_UNBNDP (finalizer))
c_finalizer = NULL;
else
{
SCM_VALIDATE_POINTER (1, pointer);
- return scm_from_uintptr ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
+ return scm_from_uintptr_t ((scm_t_uintptr) SCM_POINTER_VALUE (pointer));
}
#undef FUNC_NAME
SCM ret;
ret = scm_from_pointer ((void*) SCM_UNPACK (scm), NULL);
- if (SCM_NIMP (ret))
+ if (SCM_HEAP_OBJECT_P (ret))
register_weak_reference (ret, scm);
return ret;
blen = scm_to_size_t (len);
ret = scm_c_take_typed_bytevector ((signed char *) ptr + boffset,
- blen, btype);
- register_weak_reference (ret, pointer);
+ blen, btype, pointer);
+
return ret;
}
#undef FUNC_NAME
void
scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<pointer 0x", port);
- scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
- scm_putc ('>', port);
+ scm_puts
_unlocked ("#<pointer 0x", port);
+ scm_uintprint (scm_to_uintptr_t (scm_pointer_address (pointer)), 16, port);
+ scm_putc_unlocked ('>', port);
}
\f
{
/* a struct */
size_t off = 0;
+ size_t align = scm_to_size_t (scm_alignof(type));
while (scm_is_pair (type))
{
off = ROUND_UP (off, scm_to_size_t (scm_alignof (scm_car (type))));
off += scm_to_size_t (scm_sizeof (scm_car (type)));
type = scm_cdr (type);
}
- return scm_from_size_t (off);
+ return scm_from_size_t (ROUND_UP(off, align));
}
else
scm_wrong_type_arg (FUNC_NAME, 1, type);
\f
-/* Pre-generate trampolines for less than 10 arguments. */
+/* We support calling foreign functions with up to 100 arguments. */
-#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER(M) M (0), M (0), M (0), M (8), M (0), M (0), M (0), M (40)
-#define META_HEADER(M) M (0), M (0), M (0), M (32), M (0), M (0), M (0), M (0)
-#else
-#define OBJCODE_HEADER(M) M (8), M (0), M (0), M (0), M (40), M (0), M (0), M (0)
-#define META_HEADER(M) M (32), M (0), M (0), M (0), M (0), M (0), M (0), M (0)
-#endif
+#define CODE(nreq) \
+ SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \
+ SCM_PACK_OP_12_12 (foreign_call, 0, 1)
-#define GEN_CODE(M, nreq) \
- OBJCODE_HEADER (M), \
- /* 0 */ M (scm_op_assert_nargs_ee), M (0), M (nreq), /* assert number of args */ \
- /* 3 */ M (scm_op_object_ref), M (0), /* push the pair with the cif and the function pointer */ \
- /* 5 */ M (scm_op_foreign_call), M (nreq), /* and call (will return value as well) */ \
- /* 7 */ M (scm_op_nop), \
- /* 8 */ META (M, 3, 7, nreq)
-
-#define META(M, start, end, nreq) \
- META_HEADER (M), \
- /* 0 */ M (scm_op_make_eol), /* bindings */ \
- /* 1 */ M (scm_op_make_eol), /* sources */ \
- /* 2 */ M (scm_op_make_int8), M (start), M (scm_op_make_int8), M (end), /* arity: from ip N to ip N */ \
- /* 6 */ M (scm_op_make_int8), M (nreq), /* the arity is N required args */ \
- /* 8 */ M (scm_op_list), M (0), M (3), /* make a list of those 3 vals */ \
- /* 11 */ M (scm_op_list), M (0), M (1), /* and the arities will be a list of that one list */ \
- /* 14 */ M (scm_op_load_symbol), M (0), M (0), M (4), M ('n'), M ('a'), M ('M'), M ('e'), /* `name' */ \
- /* 22 */ M (scm_op_object_ref), M (1), /* the name from the object table */ \
- /* 24 */ M (scm_op_cons), /* make a pair for the properties */ \
- /* 25 */ M (scm_op_list), M (0), M (4), /* pack bindings, sources, and arities into list */ \
- /* 28 */ M (scm_op_return), /* and return */ \
- /* 29 */ M (scm_op_nop), M (scm_op_nop), M (scm_op_nop) \
- /* 32 */
-
-#define M_STATIC(x) (x)
-#define CODE(nreq) GEN_CODE (M_STATIC, nreq)
-
-static const struct
-{
- SCM_ALIGNED (8) scm_t_uint64 dummy; /* alignment */
- const scm_t_uint8 bytes[10 * (sizeof (struct scm_objcode) + 8
- + sizeof (struct scm_objcode) + 32)];
-} raw_bytecode = {
- 0,
- {
- CODE (0), CODE (1), CODE (2), CODE (3), CODE (4),
- CODE (5), CODE (6), CODE (7), CODE (8), CODE (9)
- }
-};
+#define CODE_10(n) \
+ CODE (n + 0), CODE (n + 1), CODE (n + 2), CODE (n + 3), CODE (n + 4), \
+ CODE (n + 5), CODE (n + 6), CODE (n + 7), CODE (n + 8), CODE (n + 9)
-static SCM
-make_objcode_trampoline (unsigned int nargs)
-{
- const int size = sizeof (struct scm_objcode) + 8
- + sizeof (struct scm_objcode) + 32;
- SCM bytecode = scm_c_make_bytevector (size);
- scm_t_uint8 *bytes = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bytecode);
- int i = 0;
-
-#define M_DYNAMIC(x) (bytes[i++] = (x))
- GEN_CODE (M_DYNAMIC, nargs);
-#undef M_DYNAMIC
-
- if (i != size)
- scm_syserror ("make_objcode_trampoline");
- return scm_bytecode_to_native_objcode (bytecode);
-}
+static const scm_t_uint32 foreign_stub_code[] =
+ {
+ CODE_10 (0), CODE_10 (10), CODE_10 (20), CODE_10 (30), CODE_10 (40),
+ CODE_10 (50), CODE_10 (60), CODE_10 (70), CODE_10 (80), CODE_10 (90)
+ };
-#undef GEN_CODE
-#undef META
-#undef M_STATIC
#undef CODE
-#undef OBJCODE_HEADER
-#undef META_HEADER
-
-/*
- (defun generate-objcode-cells (n)
- "Generate objcode cells for up to N arguments"
- (interactive "p")
- (let ((i 0))
- (while (< i n)
- (insert
- (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
- (* (+ 4 4 8 4 4 32) i)))
- (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
- (setq i (1+ i)))))
-*/
-#define STATIC_OBJCODE_TAG \
- SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
+#undef CODE_10
-static const struct
+static const scm_t_uint32 *
+get_foreign_stub_code (unsigned int nargs)
{
- SCM_ALIGNED (8) scm_t_uint64 dummy; /* alignment */
- scm_t_cell cells[10 * 2]; /* 10 double cells */
-} objcode_cells = {
- 0,
- /* C-u 1 0 M-x generate-objcode-cells RET */
- {
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 56) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 112) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 168) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 224) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 280) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 336) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 392) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 504) },
- { SCM_BOOL_F, SCM_PACK (0) }
- }
-};
-
-static const SCM objcode_trampolines[10] = {
- SCM_PACK (objcode_cells.cells+0),
- SCM_PACK (objcode_cells.cells+2),
- SCM_PACK (objcode_cells.cells+4),
- SCM_PACK (objcode_cells.cells+6),
- SCM_PACK (objcode_cells.cells+8),
- SCM_PACK (objcode_cells.cells+10),
- SCM_PACK (objcode_cells.cells+12),
- SCM_PACK (objcode_cells.cells+14),
- SCM_PACK (objcode_cells.cells+16),
- SCM_PACK (objcode_cells.cells+18),
-};
-
-static SCM large_objcode_trampolines = SCM_UNDEFINED;
-static scm_i_pthread_mutex_t large_objcode_trampolines_mutex =
- SCM_I_PTHREAD_MUTEX_INITIALIZER;
+ if (nargs >= 100)
+ scm_misc_error ("make-foreign-function", "args >= 100 currently unimplemented",
+ SCM_EOL);
-static SCM
-get_objcode_trampoline (unsigned int nargs)
+ return &foreign_stub_code[nargs * 2];
+}
+
+/* Given a foreign procedure, determine its minimum arity. */
+int
+scm_i_foreign_arity (SCM foreign, int *req, int *opt, int *rest)
{
- SCM objcode;
+ const scm_t_uint32 *code = SCM_PROGRAM_CODE (foreign);
- if (nargs < 10)
- objcode = objcode_trampolines[nargs];
- else if (nargs < 128)
- {
- scm_i_scm_pthread_mutex_lock (&large_objcode_trampolines_mutex);
- if (SCM_UNBNDP (large_objcode_trampolines))
- large_objcode_trampolines = scm_c_make_vector (128, SCM_UNDEFINED);
- objcode = scm_c_vector_ref (large_objcode_trampolines, nargs);
- if (SCM_UNBNDP (objcode))
- scm_c_vector_set_x (large_objcode_trampolines, nargs,
- objcode = make_objcode_trampoline (nargs));
- scm_i_pthread_mutex_unlock (&large_objcode_trampolines_mutex);
- }
- else
- scm_misc_error ("make-foreign-function", "args >= 128 currently unimplemented",
- SCM_EOL);
+ if (code < foreign_stub_code)
+ return 0;
+ if (code > (foreign_stub_code
+ + (sizeof(foreign_stub_code) / sizeof(scm_t_uint32))))
+ return 0;
+
+ *req = (code - foreign_stub_code) / 2;
+ *opt = 0;
+ *rest = 0;
- return objcode;
+ return 1;
}
static SCM
cif_to_procedure (SCM cif, SCM func_ptr)
{
ffi_cif *c_cif;
- SCM objcode, table, ret;
+ SCM ret;
+ scm_t_bits nfree = 2;
+ scm_t_bits flags = SCM_F_PROGRAM_IS_FOREIGN;
c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
- objcode = get_objcode_trampoline (c_cif->nargs);
-
- table = scm_c_make_vector (2, SCM_UNDEFINED);
- SCM_SIMPLE_VECTOR_SET (table, 0, scm_cons (cif, func_ptr));
- SCM_SIMPLE_VECTOR_SET (table, 1, SCM_BOOL_F); /* name */
- ret = scm_make_program (objcode, table, SCM_BOOL_F);
+
+ ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
+ SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs));
+ SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, cif);
+ SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, func_ptr);
return ret;
}
size_t i;
SCM proc, *argv, result;
- proc = PTR2SCM (data);
+ proc = SCM_PACK_POINTER (data);
argv = alloca (cif->nargs * sizeof (*argv));
closure = ffi_closure_alloc (sizeof (ffi_closure), &executable);
err = ffi_prep_closure_loc ((ffi_closure *) closure, cif,
- invoke_closure, SCM2PTR (proc),
+ invoke_closure, SCM_UNPACK_POINTER (proc),
executable);
if (err != FFI_OK)
{
"scm_init_foreign",
(scm_t_extension_init_func)scm_init_foreign,
NULL);
- pointer_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ pointer_weak_refs = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
}
/*
#ifndef SCM_FOREIGN_H
#define SCM_FOREIGN_H
-/* Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2010, 2011, 2012, 2013 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
typedef void (*scm_t_pointer_finalizer) (void *);
-#define SCM_POINTER_P(x) \
- (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_pointer)
+#define SCM_POINTER_P(x) (SCM_HAS_TYP7 (x, scm_tc7_pointer))
#define SCM_VALIDATE_POINTER(pos, x) \
SCM_MAKE_VALIDATE (pos, x, POINTER_P)
#define SCM_POINTER_VALUE(x) \
SCM_API SCM scm_alignof (SCM type);
SCM_API SCM scm_sizeof (SCM type);
SCM_API SCM scm_pointer_address (SCM pointer);
+SCM_API SCM scm_pointer_to_scm (SCM pointer);
+SCM_API SCM scm_scm_to_pointer (SCM scm);
SCM_API SCM scm_pointer_to_bytevector (SCM pointer, SCM type,
SCM offset, SCM len);
SCM_API SCM scm_set_pointer_finalizer_x (SCM pointer, SCM finalizer);
SCM_API SCM scm_procedure_to_pointer (SCM return_type, SCM func_ptr,
SCM arg_types);
SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, const SCM *argv);
+SCM_INTERNAL int scm_i_foreign_arity (SCM foreign,
+ int *req, int *opt, int *rest);
\f
size_t ndrained;
char *drained = NULL;
scm_t_port *pt;
- scm_t_port_internal *pti;
+ scm_t_ptob_descriptor *ptob;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPENPORT (1, port);
- pti = SCM_PORT_GET_INTERNAL (port);
+ ptob = SCM_PORT_DESCRIPTOR (port);
- if (pti->setvbuf == NULL)
+ if (ptob->setvbuf == NULL)
scm_wrong_type_arg_msg (FUNC_NAME, 1, port,
"port that supports 'setvbuf'");
ndrained = 0;
if (SCM_OUTPUT_PORT_P (port))
- scm_flush (port);
+ scm_flush_unlocked (port);
if (pt->read_buf == pt->putback_buf)
{
pt->read_buf_size = pt->saved_read_buf_size;
}
- pti->setvbuf (port, csize, csize);
+ ptob->setvbuf (port, csize, csize);
if (ndrained > 0)
/* Put DRAINED back to PORT. */
static SCM k_guess_encoding = SCM_UNDEFINED;
static SCM k_encoding = SCM_UNDEFINED;
+SCM_INTERNAL SCM scm_i_open_file (SCM, SCM, SCM);
+
SCM_DEFINE (scm_i_open_file, "open-file", 2, 0, 1,
(SCM filename, SCM mode, SCM keyword_args),
"Open the file whose name is @var{filename}, and return a port\n"
#define FUNC_NAME "scm_fdes_to_port"
{
SCM port;
- scm_t_port *pt;
- scm_t_port_internal *pti;
+ scm_t_fport *fp;
/* Test that fdes is valid. */
#ifdef F_GETFL
SCM_SYSERROR;
#endif
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ fp = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
+ "file port");
+ fp->fdes = fdes;
- port = scm_new_port_table_entry (scm_tc16_fport);
- SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
- pt = SCM_PTAB_ENTRY (port);
+ port = scm_c_make_port (scm_tc16_fport, mode_bits, (scm_t_bits)fp);
+
+ SCM_PTAB_ENTRY (port)->rw_random = SCM_FDES_RANDOM_P (fdes);
- /* File ports support 'setvbuf'. */
- pti = SCM_PORT_GET_INTERNAL (port);
- pti->setvbuf = scm_fport_buffer_add;
+ if (mode_bits & SCM_BUF0)
+ scm_fport_buffer_add (port, 0, 0);
+ else
+ scm_fport_buffer_add (port, -1, -1);
- {
- scm_t_fport *fp
- = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
- "file port");
-
- fp->fdes = fdes;
- pt->rw_random = SCM_FDES_RANDOM_P (fdes);
- SCM_SETSTREAM (port, fp);
- if (mode_bits & SCM_BUF0)
- scm_fport_buffer_add (port, 0, 0);
- else
- scm_fport_buffer_add (port, -1, -1);
- }
SCM_SET_FILENAME (port, name);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
return port;
}
#undef FUNC_NAME
return pollfd.revents & POLLIN ? 1 : 0;
}
+
+\f
+
+/* Revealed counts --- an oddity inherited from SCSH. */
+
+#define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed)
+
+static SCM revealed_ports = SCM_EOL;
+static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+/* Find a port in the table and return its revealed count.
+ Also used by the garbage collector.
+ */
+int
+scm_revealed_count (SCM port)
+{
+ int ret;
+
+ scm_i_pthread_mutex_lock (&revealed_lock);
+ ret = SCM_REVEALED (port);
+ scm_i_pthread_mutex_unlock (&revealed_lock);
+
+ return ret;
+}
+
+SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
+ (SCM port),
+ "Return the revealed count for @var{port}.")
+#define FUNC_NAME s_scm_port_revealed
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPFPORT (1, port);
+ return scm_from_int (scm_revealed_count (port));
+}
+#undef FUNC_NAME
+
+/* Set the revealed count for a port. */
+SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
+ (SCM port, SCM rcount),
+ "Sets the revealed count for a port to a given value.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_set_port_revealed_x
+{
+ int r, prev;
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPFPORT (1, port);
+
+ r = scm_to_int (rcount);
+
+ scm_i_pthread_mutex_lock (&revealed_lock);
+
+ prev = SCM_REVEALED (port);
+ SCM_REVEALED (port) = r;
+
+ if (r && !prev)
+ revealed_ports = scm_cons (port, revealed_ports);
+ else if (prev && !r)
+ revealed_ports = scm_delq_x (port, revealed_ports);
+
+ scm_i_pthread_mutex_unlock (&revealed_lock);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* Set the revealed count for a port. */
+SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0,
+ (SCM port, SCM addend),
+ "Add @var{addend} to the revealed count of @var{port}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_adjust_port_revealed_x
+{
+ int a;
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPFPORT (1, port);
+
+ a = scm_to_int (addend);
+ if (!a)
+ return SCM_UNSPECIFIED;
+
+ scm_i_pthread_mutex_lock (&revealed_lock);
+
+ SCM_REVEALED (port) += a;
+ if (SCM_REVEALED (port) == a)
+ revealed_ports = scm_cons (port, revealed_ports);
+ else if (!SCM_REVEALED (port))
+ revealed_ports = scm_delq_x (port, revealed_ports);
+
+ scm_i_pthread_mutex_unlock (&revealed_lock);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
\f
static int
fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
scm_print_port_mode (exp, port);
if (SCM_OPFPORTP (exp))
{
if (scm_is_string (name) || scm_is_symbol (name))
scm_display (name, port);
else
- scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
- scm_putc (' ', port);
+ scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
+ scm_putc_unlocked (' ', port);
fdes = (SCM_FSTREAM (exp))->fdes;
#if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
}
else
{
- scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
- scm_putc (' ', port);
+ scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
+ scm_putc_unlocked (' ', port);
scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
}
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
if (offset != 0 || whence != SEEK_CUR)
{
/* could expand to avoid a second seek. */
- scm_end_input (port);
+ scm_end_input_unlocked (port);
result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
}
else
pt->rw_active = SCM_PORT_NEITHER;
}
+static void
+close_the_fd (void *data)
+{
+ scm_t_fport *fp = data;
+
+ close (fp->fdes);
+ /* There's already one exception. That's probably enough! */
+ errno = 0;
+}
+
static int
fport_close (SCM port)
{
scm_t_fport *fp = SCM_FSTREAM (port);
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
int rv;
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (close_the_fd, fp, 0);
fport_flush (port);
- SCM_SYSCALL (rv = close (fp->fdes));
- if (rv == -1 && errno != EBADF)
- {
- if (scm_gc_running_p)
- /* silently ignore the error. scm_error would abort if we
- called it now. */
- ;
- else
- scm_syserror ("fport_close");
- }
- if (pt->read_buf == pt->putback_buf)
- pt->read_buf = pt->saved_read_buf;
- if (pt->read_buf != &pt->shortbuf)
- scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
- if (pt->write_buf != &pt->shortbuf)
- scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
- scm_gc_free (fp, sizeof (*fp), "file port");
- return rv;
+ scm_dynwind_end ();
+
+ scm_port_non_buffer (SCM_PTAB_ENTRY (port));
+
+ rv = close (fp->fdes);
+ if (rv)
+ /* It's not useful to retry after EINTR, as the file descriptor is
+ in an undefined state. See http://lwn.net/Articles/365294/.
+ Instead just throw an error if close fails, trusting that the fd
+ was cleaned up. */
+ scm_syserror ("fport_close");
+
+ return 0;
}
static size_t
scm_set_port_seek (tc, fport_seek);
scm_set_port_truncate (tc, fport_truncate);
scm_set_port_input_waiting (tc, fport_input_waiting);
+ scm_set_port_setvbuf (tc, scm_fport_buffer_add);
return tc;
}
#ifndef SCM_FPORTS_H
#define SCM_FPORTS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
/* struct allocated for each buffered FPORT. */
typedef struct scm_t_fport {
int fdes; /* file descriptor. */
+ int revealed; /* 0 not revealed, > 1 revealed.
+ * Revealed ports do not get GC'd.
+ */
} scm_t_fport;
SCM_API scm_t_bits scm_tc16_fport;
#define SCM_FSTREAM(x) ((scm_t_fport *) SCM_STREAM (x))
#define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes)
-#define SCM_FPORTP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_fport))
+#define SCM_FPORTP(x) (SCM_HAS_TYP16 (x, scm_tc16_fport))
#define SCM_OPFPORTP(x) (SCM_FPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN))
#define SCM_OPINFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_RDNG))
#define SCM_OPOUTFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_WRTNG))
SCM_API SCM scm_open_file (SCM filename, SCM modes);
SCM_API SCM scm_fdes_to_port (int fdes, char *mode, SCM name);
SCM_API SCM scm_file_port_p (SCM obj);
+
+\f
+/* Revealed counts. */
+SCM_API int scm_revealed_count (SCM port);
+SCM_API SCM scm_port_revealed (SCM port);
+SCM_API SCM scm_set_port_revealed_x (SCM port, SCM rcount);
+SCM_API SCM scm_adjust_port_revealed_x (SCM port, SCM addend);
+
+\f
SCM_INTERNAL void scm_init_fports_keywords (void);
SCM_INTERNAL void scm_init_fports (void);
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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 "_scm.h"
#include "frames.h"
+#include "vm.h"
#include <verify.h>
/* Make sure assumptions on the layout of `struct scm_vm_frame' hold. */
verify (sizeof (SCM) == sizeof (SCM *));
-verify (sizeof (struct scm_vm_frame) == 5 * sizeof (SCM));
+verify (sizeof (struct scm_vm_frame) == 3 * sizeof (SCM));
verify (offsetof (struct scm_vm_frame, dynamic_link) == 0);
\f
-#define RELOC(frame, val) \
- (((SCM *) (val)) + SCM_VM_FRAME_OFFSET (frame))
SCM
-scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_t_uint8 *ip, scm_t_ptrdiff offset)
+scm_c_make_frame (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
{
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;
- return scm_cell (scm_tc7_frame, (scm_t_bits)p);
+ p->stack_holder = frame->stack_holder;
+ p->fp_offset = frame->fp_offset;
+ p->sp_offset = frame->sp_offset;
+ p->ip = frame->ip;
+ return scm_cell (scm_tc7_frame | (kind << 8), (scm_t_bits)p);
}
void
scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<frame ", port);
+ scm_puts_unlocked ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
+static SCM*
+frame_stack_base (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
+{
+ switch (kind)
+ {
+ case SCM_VM_FRAME_KIND_CONT:
+ return ((struct scm_vm_cont *) frame->stack_holder)->stack_base;
+
+ case SCM_VM_FRAME_KIND_VM:
+ return ((struct scm_vm *) frame->stack_holder)->stack_base;
+
+ default:
+ abort ();
+ }
+}
+
+static scm_t_ptrdiff
+frame_offset (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
+{
+ switch (kind)
+ {
+ case SCM_VM_FRAME_KIND_CONT:
+ return ((struct scm_vm_cont *) frame->stack_holder)->reloc;
+
+ case SCM_VM_FRAME_KIND_VM:
+ return 0;
+
+ default:
+ abort ();
+ }
+}
+
+SCM*
+scm_i_frame_stack_base (SCM frame)
+#define FUNC_NAME "frame-stack-base"
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ return frame_stack_base (SCM_VM_FRAME_KIND (frame),
+ SCM_VM_FRAME_DATA (frame));
+}
+#undef FUNC_NAME
+
+scm_t_ptrdiff
+scm_i_frame_offset (SCM frame)
+#define FUNC_NAME "frame-offset"
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ return frame_offset (SCM_VM_FRAME_KIND (frame),
+ SCM_VM_FRAME_DATA (frame));
+
+}
+#undef FUNC_NAME
+
\f
/* Scheme interface */
}
#undef FUNC_NAME
+/* Retrieve the local in slot 0, which may or may not actually be a
+ procedure, and may or may not actually be the procedure being
+ applied. If you want the procedure, look it up from the IP. */
+SCM
+scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
+{
+ SCM *fp, *sp;
+
+ fp = frame_stack_base (kind, frame) + frame->fp_offset;
+ sp = frame_stack_base (kind, frame) + frame->sp_offset;
+
+ if (SCM_FRAME_NUM_LOCALS (fp, sp) > 0)
+ return SCM_FRAME_LOCAL (fp, 0);
+
+ return SCM_BOOL_F;
+}
+
SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_procedure
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
+
+ /* FIXME: Retrieve procedure from address? */
+ return scm_c_frame_closure (SCM_VM_FRAME_KIND (frame),
+ SCM_VM_FRAME_DATA (frame));
}
#undef FUNC_NAME
}
#undef FUNC_NAME
+static SCM frame_call_representation_var;
+
+static void
+init_frame_call_representation_var (void)
+{
+ frame_call_representation_var
+ = scm_c_private_lookup ("system vm frame", "frame-call-representation");
+}
+
+SCM scm_frame_call_representation (SCM frame)
+#define FUNC_NAME "frame-call-representation"
+{
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_frame_call_representation_var);
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ return scm_call_1 (scm_variable_ref (frame_call_representation_var), frame);
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_source
{
- SCM proc;
-
SCM_VALIDATE_VM_FRAME (1, frame);
- proc = scm_frame_procedure (frame);
-
- if (SCM_PROGRAM_P (proc))
- return scm_program_source (scm_frame_procedure (frame),
- scm_frame_instruction_pointer (frame),
- SCM_UNDEFINED);
-
- return SCM_BOOL_F;
+ return scm_find_source_for_addr (scm_frame_instruction_pointer (frame));
}
#undef FUNC_NAME
-/* 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_frame_num_locals
{
- SCM *sp, *p;
- unsigned int n = 0;
+ SCM *fp, *sp;
SCM_VALIDATE_VM_FRAME (1, frame);
+ fp = SCM_VM_FRAME_FP (frame);
sp = SCM_VM_FRAME_SP (frame);
- p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
- while (p <= sp)
- {
- if (SCM_UNPACK (p[0]) == 0)
- /* skip over not-yet-active frame */
- p += 3;
- else
- {
- p++;
- n++;
- }
- }
- return scm_from_uint (n);
+
+ return scm_from_ptrdiff_t (SCM_FRAME_NUM_LOCALS (fp, sp));
}
#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;
+ SCM *fp, *sp;
unsigned int i;
SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
+ fp = SCM_VM_FRAME_FP (frame);
sp = SCM_VM_FRAME_SP (frame);
- p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
- while (p <= sp)
- {
- if (SCM_UNPACK (p[0]) == 0)
- /* skip over not-yet-active frame */
- p += 3;
- else if (n == i)
- return *p;
- else
- {
- p++;
- n++;
- }
- }
+
+ if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
+ return SCM_FRAME_LOCAL (fp, i);
+
SCM_OUT_OF_RANGE (SCM_ARG2, index);
}
#undef FUNC_NAME
"")
#define FUNC_NAME s_scm_frame_local_set_x
{
- SCM *sp, *p;
- unsigned int n = 0;
+ SCM *fp, *sp;
unsigned int i;
SCM_VALIDATE_VM_FRAME (1, frame);
SCM_VALIDATE_UINT_COPY (2, index, i);
+ fp = SCM_VM_FRAME_FP (frame);
sp = SCM_VM_FRAME_SP (frame);
- p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
- while (p <= sp)
+
+ if (i < SCM_FRAME_NUM_LOCALS (fp, sp))
{
- if (SCM_UNPACK (p[0]) == 0)
- /* skip over not-yet-active frame */
- p += 3;
- else if (n == i)
- {
- *p = val;
- return SCM_UNSPECIFIED;
- }
- else
- {
- p++;
- n++;
- }
+ SCM_FRAME_LOCAL (fp, i) = val;
+ return SCM_UNSPECIFIED;
}
+
SCM_OUT_OF_RANGE (SCM_ARG2, index);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_frame_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_FRAME_FP (frame));
+ return scm_from_ptrdiff_t (SCM_VM_FRAME_FP_OFFSET (frame));
}
#undef FUNC_NAME
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_FRAME_SP (frame));
+ return scm_from_ptrdiff_t (SCM_VM_FRAME_SP_OFFSET (frame));
}
#undef FUNC_NAME
"")
#define FUNC_NAME s_scm_frame_instruction_pointer
{
- SCM program;
- const struct scm_objcode *c_objcode;
-
SCM_VALIDATE_VM_FRAME (1, frame);
- program = scm_frame_procedure (frame);
- if (!SCM_PROGRAM_P (program))
- return SCM_INUM0;
-
- c_objcode = SCM_PROGRAM_DATA (program);
- return scm_from_unsigned_integer ((SCM_VM_FRAME_IP (frame)
- - SCM_C_OBJCODE_BASE (c_objcode)));
+ return scm_from_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_IP (frame));
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_frame_return_address
{
SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_unsigned_integer ((scm_t_bits)
- (SCM_FRAME_RETURN_ADDRESS
- (SCM_VM_FRAME_FP (frame))));
+ return scm_from_uintptr_t ((scm_t_uintptr) (SCM_FRAME_RETURN_ADDRESS
+ (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_frame_mv_return_address, "frame-mv-return-address", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_frame_mv_return_address
-{
- SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_from_unsigned_integer ((scm_t_bits)
- (SCM_FRAME_MV_RETURN_ADDRESS
- (SCM_VM_FRAME_FP (frame))));
-}
-#undef FUNC_NAME
+#define RELOC(kind, frame, val) \
+ (((SCM *) (val)) + frame_offset (kind, frame))
SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
(SCM frame),
{
SCM_VALIDATE_VM_FRAME (1, frame);
/* fixme: munge fp if holder is a continuation */
- return scm_from_ulong
- ((unsigned long)
- RELOC (frame,
+ return scm_from_uintptr_t
+ ((scm_t_uintptr)
+ RELOC (SCM_VM_FRAME_KIND (frame), SCM_VM_FRAME_DATA (frame),
SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME
+int
+scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame)
+{
+ SCM *this_fp, *new_fp, *new_sp;
+ SCM *stack_base = frame_stack_base (kind, frame);
+
+ again:
+ this_fp = frame->fp_offset + stack_base;
+
+ if (this_fp == stack_base)
+ return 0;
+
+ new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
+
+ if (!new_fp)
+ return 0;
+
+ new_fp = RELOC (kind, frame, new_fp);
+
+ if (new_fp < stack_base)
+ return 0;
+
+ new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
+ frame->fp_offset = new_fp - stack_base;
+ frame->sp_offset = new_sp - stack_base;
+ frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp);
+
+ {
+ SCM proc = scm_c_frame_closure (kind, frame);
+ if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
+ goto again;
+ }
+
+ return 1;
+}
+
SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_previous
{
- SCM *this_fp, *new_fp, *new_sp;
- SCM proc;
+ enum scm_vm_frame_kind kind;
+ struct scm_frame tmp;
SCM_VALIDATE_VM_FRAME (1, frame);
- again:
- this_fp = SCM_VM_FRAME_FP (frame);
- new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
- if (new_fp)
- {
- new_fp = RELOC (frame, new_fp);
- new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
- frame = 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));
- proc = scm_frame_procedure (frame);
-
- if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
- goto again;
- else
- return frame;
- }
- else
+ kind = SCM_VM_FRAME_KIND (frame);
+ memcpy (&tmp, SCM_VM_FRAME_DATA (frame), sizeof tmp);
+
+ if (!scm_c_frame_previous (SCM_VM_FRAME_KIND (frame), &tmp))
return SCM_BOOL_F;
+
+ return scm_c_make_frame (kind, &tmp);
}
#undef FUNC_NAME
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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 "programs.h"
\f
-/*
- * VM frames
- */
+/* Stack 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.
- */
+ 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 lower-case scm_frame prefix.
-/* VM Frame Layout
- ---------------
+ Stack frame layout
+ ------------------
+
+ /------------------\
+ | Local N-1 | <- sp
| ... |
- | Intermed. val. 0 | <- fp + nargs + nlocs
- +------------------+
- | Local variable 1 |
- | Local variable 0 | <- fp + nargs
- | Argument 1 |
- | Argument 0 | <- fp = SCM_FRAME_STACK_ADDRESS (fp)
- | Program | <- fp - 1
+ | Local 1 |
+ | Local 0 | <- fp = SCM_FRAME_LOCALS_ADDRESS (fp)
+==================+
- | Return address | <- SCM_FRAME_UPPER_ADDRESS (fp)
- | MV return address|
- | Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) = SCM_FRAME_LOWER_ADDRESS (fp)
+ | Return address |
+ | Dynamic link | <- fp - 2 = SCM_FRAME_LOWER_ADDRESS (fp)
+==================+
- | |
+ | | <- fp - 3 = SCM_FRAME_PREVIOUS_SP (fp)
+
+ The calling convention is that a caller prepares a stack frame
+ consisting of the saved FP and the return address, followed by the
+ procedure and then the arguments to the call, in order. Thus in the
+ beginning of a call, the procedure being called is in slot 0, the
+ first argument is in slot 1, and the SP points to the last argument.
+ The number of arguments, including the procedure, is thus SP - FP +
+ 1.
+
+ After ensuring that the correct number of arguments have been passed,
+ a function will set the stack pointer to point to the last local
+ slot. This lets a function allocate the temporary space that it
+ needs once in the beginning of the call, instead of pushing and
+ popping the stack pointer during the call's extent.
+
+ When a program returns, it returns its values in the slots starting
+ from local 1, as if the values were arguments to a tail call. We
+ start from 1 instead of 0 for the convenience of the "values" builtin
+ function, which can just leave its arguments in place.
+
+ The callee resets the stack pointer to point to the last value. In
+ this way the caller knows how many values there are: it's the number
+ of words between the stack pointer and the slot at which the caller
+ placed the procedure.
- As can be inferred from this drawing, it is assumed that
- `sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are
- assumed to be as long as SCM objects. */
+ After checking that the number of values returned is appropriate, the
+ caller shuffles the values around (if needed), and resets the stack
+ pointer back to its original value from before the call. */
+
+
+\f
/* This structure maps to the contents of a VM stack frame. It can
alias a frame directly. */
struct scm_vm_frame
{
SCM *dynamic_link;
- scm_t_uint8 *mv_return_address;
- scm_t_uint8 *return_address;
- SCM program;
- SCM stack[1]; /* Variable-length */
+ scm_t_uint32 *return_address;
+ SCM locals[1]; /* Variable-length */
};
+#define SCM_FRAME_LOWER_ADDRESS(fp) (((SCM *) (fp)) - 2)
#define SCM_FRAME_STRUCT(fp) \
- ((struct scm_vm_frame *) SCM_FRAME_DATA_ADDRESS (fp))
+ ((struct scm_vm_frame *) SCM_FRAME_LOWER_ADDRESS (fp))
+#define SCM_FRAME_LOCALS_ADDRESS(fp) (SCM_FRAME_STRUCT (fp)->locals)
-#define SCM_FRAME_DATA_ADDRESS(fp) (((SCM *) (fp)) - 4)
-#define SCM_FRAME_STACK_ADDRESS(fp) (SCM_FRAME_STRUCT (fp)->stack)
-#define SCM_FRAME_UPPER_ADDRESS(fp) ((SCM*)&SCM_FRAME_STRUCT (fp)->return_address)
-#define SCM_FRAME_LOWER_ADDRESS(fp) ((SCM*)SCM_FRAME_STRUCT (fp))
-
-#define SCM_FRAME_BYTE_CAST(x) ((scm_t_uint8 *) SCM_UNPACK (x))
-#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
+#define SCM_FRAME_PREVIOUS_SP(fp) (((SCM *) (fp)) - 3)
#define SCM_FRAME_RETURN_ADDRESS(fp) \
(SCM_FRAME_STRUCT (fp)->return_address)
#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) \
SCM_FRAME_STRUCT (fp)->return_address = (ra)
-#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
- (SCM_FRAME_STRUCT (fp)->mv_return_address)
-#define SCM_FRAME_SET_MV_RETURN_ADDRESS(fp, mvra) \
- SCM_FRAME_STRUCT (fp)->mv_return_address = (mvra)
#define SCM_FRAME_DYNAMIC_LINK(fp) \
(SCM_FRAME_STRUCT (fp)->dynamic_link)
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
SCM_FRAME_DYNAMIC_LINK (fp) = (dl)
-#define SCM_FRAME_VARIABLE(fp,i) \
- (SCM_FRAME_STRUCT (fp)->stack[i])
-#define SCM_FRAME_PROGRAM(fp) \
- (SCM_FRAME_STRUCT (fp)->program)
+#define SCM_FRAME_LOCAL(fp,i) \
+ (SCM_FRAME_STRUCT (fp)->locals[i])
+
+#define SCM_FRAME_NUM_LOCALS(fp, sp) \
+ ((sp) + 1 - &SCM_FRAME_LOCAL (fp, 0))
\f
/*
* Heap frames
*/
+#ifdef BUILDING_LIBGUILE
+
struct scm_frame
{
- SCM stack_holder;
- SCM *fp;
- SCM *sp;
- scm_t_uint8 *ip;
- scm_t_ptrdiff offset;
+ void *stack_holder;
+ scm_t_ptrdiff fp_offset;
+ scm_t_ptrdiff sp_offset;
+ scm_t_uint32 *ip;
};
-#define SCM_VM_FRAME_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_frame)
-#define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_CELL_WORD_1 (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_IP(f) SCM_VM_FRAME_DATA(f)->ip
-#define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset
+enum scm_vm_frame_kind
+ {
+ SCM_VM_FRAME_KIND_VM,
+ SCM_VM_FRAME_KIND_CONT
+ };
+
+#define SCM_VM_FRAME_P(x) (SCM_HAS_TYP7 (x, scm_tc7_frame))
+#define SCM_VM_FRAME_KIND(x) ((enum scm_vm_frame_kind) (SCM_CELL_WORD_0 (x) >> 8))
+#define SCM_VM_FRAME_DATA(x) ((struct scm_frame *)SCM_CELL_WORD_1 (x))
+#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA (f)->stack_holder
+#define SCM_VM_FRAME_FP_OFFSET(f) SCM_VM_FRAME_DATA (f)->fp_offset
+#define SCM_VM_FRAME_SP_OFFSET(f) SCM_VM_FRAME_DATA (f)->sp_offset
+#define SCM_VM_FRAME_FP(f) (SCM_VM_FRAME_FP_OFFSET (f) + scm_i_frame_stack_base (f))
+#define SCM_VM_FRAME_SP(f) (SCM_VM_FRAME_SP_OFFSET (f) + scm_i_frame_stack_base (f))
+#define SCM_VM_FRAME_IP(f) SCM_VM_FRAME_DATA (f)->ip
+#define SCM_VM_FRAME_OFFSET(f) scm_i_frame_offset (f)
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
-SCM_API SCM scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
- scm_t_uint8 *ip, scm_t_ptrdiff offset);
+SCM_INTERNAL SCM* scm_i_frame_stack_base (SCM frame);
+SCM_INTERNAL scm_t_ptrdiff scm_i_frame_offset (SCM frame);
+
+/* See notes in frames.c before using this. */
+SCM_INTERNAL SCM scm_c_frame_closure (enum scm_vm_frame_kind kind,
+ const struct scm_frame *frame);
+
+SCM_INTERNAL SCM scm_c_make_frame (enum scm_vm_frame_kind kind,
+ const struct scm_frame *frame);
+
+SCM_INTERNAL int scm_c_frame_previous (enum scm_vm_frame_kind kind,
+ struct scm_frame *frame);
+
+#endif
+
SCM_API SCM scm_frame_p (SCM obj);
SCM_API SCM scm_frame_procedure (SCM frame);
+SCM_API SCM scm_frame_call_representation (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_stack_pointer (SCM frame);
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_frame_previous (SCM frame);
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_GC_INLINE_H
+#define SCM_GC_INLINE_H
+
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006,
+ * 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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
+ */
+
+/* Much of this file was copied from gc_inline.h, from the BDW
+ * collector. Its copyright notice is:
+ *
+ * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers
+ * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved.
+ * Copyright (c) 2005 Hewlett-Packard Development Company, L.P.
+ *
+ * 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.
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "libguile/gc.h"
+#include "libguile/bdw-gc.h"
+#include "libguile/threads.h"
+
+#include <gc/gc_inline.h> /* GC_generic_malloc_many */
+
+\f
+
+#define SCM_INLINE_GC_GRANULE_WORDS 2
+#define SCM_INLINE_GC_GRANULE_BYTES \
+ (sizeof(void *) * SCM_INLINE_GC_GRANULE_WORDS)
+
+/* A freelist set contains SCM_INLINE_GC_FREELIST_COUNT pointers to
+ singly linked lists of objects of different sizes, the ith one
+ containing objects i + 1 granules in size. This setting of
+ SCM_INLINE_GC_FREELIST_COUNT will hold freelists for allocations of
+ up to 256 bytes. */
+#define SCM_INLINE_GC_FREELIST_COUNT (256U / SCM_INLINE_GC_GRANULE_BYTES)
+
+static inline size_t
+scm_inline_gc_bytes_to_freelist_index (size_t bytes)
+{
+ return (bytes - 1U) / SCM_INLINE_GC_GRANULE_BYTES;
+}
+
+static inline size_t
+scm_inline_gc_freelist_object_size (size_t idx)
+{
+ return (idx + 1U) * SCM_INLINE_GC_GRANULE_BYTES;
+}
+
+/* The values of these must match the internal POINTERLESS and NORMAL
+ definitions in libgc, for which unfortunately there are no external
+ definitions. Alack. */
+typedef enum scm_inline_gc_kind
+ {
+ SCM_INLINE_GC_KIND_POINTERLESS,
+ SCM_INLINE_GC_KIND_NORMAL
+ } scm_inline_gc_kind;
+
+static inline void *
+scm_inline_gc_alloc (void **freelist, size_t idx, scm_inline_gc_kind kind)
+{
+ void *head = *freelist;
+
+ if (SCM_UNLIKELY (!head))
+ {
+ size_t bytes = scm_inline_gc_freelist_object_size (idx);
+ GC_generic_malloc_many (bytes, kind, freelist);
+ head = *freelist;
+ if (SCM_UNLIKELY (!head))
+ return (*GC_get_oom_fn ()) (bytes);
+ }
+
+ *freelist = *(void **)(head);
+
+ return head;
+}
+
+static inline void *
+scm_inline_gc_malloc_pointerless (scm_i_thread *thread, size_t bytes)
+{
+ size_t idx = scm_inline_gc_bytes_to_freelist_index (bytes);
+
+ if (SCM_UNLIKELY (idx >= SCM_INLINE_GC_FREELIST_COUNT))
+ return GC_malloc_atomic (bytes);
+
+ return scm_inline_gc_alloc
+ (&thread->pointerless_freelists[idx], idx, SCM_INLINE_GC_KIND_POINTERLESS);
+}
+
+static inline void *
+scm_inline_gc_malloc (scm_i_thread *thread, size_t bytes)
+{
+ size_t idx = scm_inline_gc_bytes_to_freelist_index (bytes);
+
+ if (SCM_UNLIKELY (idx >= SCM_INLINE_GC_FREELIST_COUNT))
+ return GC_malloc (bytes);
+
+ return scm_inline_gc_alloc
+ (&thread->freelists[idx], idx, SCM_INLINE_GC_KIND_NORMAL);
+}
+
+static inline void *
+scm_inline_gc_malloc_words (scm_i_thread *thread, size_t words)
+{
+ return scm_inline_gc_malloc (thread, words * sizeof (void *));
+}
+
+static inline SCM
+scm_inline_cell (scm_i_thread *thread, scm_t_bits car, scm_t_bits cdr)
+{
+ SCM cell = SCM_PACK_POINTER (scm_inline_gc_malloc_words (thread, 2));
+
+ SCM_GC_SET_CELL_WORD (cell, 0, car);
+ SCM_GC_SET_CELL_WORD (cell, 1, cdr);
+
+ return cell;
+}
+
+static inline SCM
+scm_inline_double_cell (scm_i_thread *thread, scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr)
+{
+ SCM cell = SCM_PACK_POINTER (scm_inline_gc_malloc_words (thread, 4));
+
+ SCM_GC_SET_CELL_WORD (cell, 0, car);
+ SCM_GC_SET_CELL_WORD (cell, 1, cbr);
+ SCM_GC_SET_CELL_WORD (cell, 2, ccr);
+ SCM_GC_SET_CELL_WORD (cell, 3, cdr);
+
+ return cell;
+}
+
+static inline SCM
+scm_inline_words (scm_i_thread *thread, scm_t_bits car, scm_t_uint32 n_words)
+{
+ SCM obj = SCM_PACK_POINTER (scm_inline_gc_malloc_words (thread, n_words));
+
+ SCM_GC_SET_CELL_WORD (obj, 0, car);
+
+ return obj;
+}
+
+static inline SCM
+scm_inline_cons (scm_i_thread *thread, SCM x, SCM y)
+{
+ return scm_inline_cell (thread, SCM_UNPACK (x), SCM_UNPACK (y));
+}
+
+
+#endif /* SCM_GC_INLINE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2006, 2008, 2009, 2010, 2011, 2012,
+ * 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013,
* 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#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/deprecation.h"
#include "libguile/gc.h"
-#include "libguile/private-gc.h"
-
#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
#endif
return ptr;
/* Time is hard: trigger a full, ``stop-the-world'' GC, and try again. */
-#ifdef HAVE_GC_GCOLLECT_AND_UNMAP
GC_gcollect_and_unmap ();
-#else
- GC_gcollect ();
-#endif
ptr = do_realloc (mem, size);
if (ptr)
return ptr;
- scm_memory_error ("realloc");
+ scm_report_out_of_memory ();
+
+ /* Not reached. */
+ return NULL;
}
void *
{
return scm_gc_strndup (str, strlen (str), what);
}
-
-#if SCM_ENABLE_DEPRECATED == 1
-
-/* {Deprecated front end to malloc}
- *
- * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
- * scm_done_free
- *
- * These functions provide services comparable to malloc, realloc, and
- * free.
- *
- * There has been a fair amount of confusion around the use of these functions;
- * see "Memory Blocks" in the manual. They are totally unnecessary in 2.0 given
- * the Boehm GC.
- */
-
-void *
-scm_must_malloc (size_t size, const char *what)
-{
- scm_c_issue_deprecation_warning
- ("scm_must_malloc is deprecated. "
- "Use scm_gc_malloc and scm_gc_free instead.");
-
- return scm_gc_malloc (size, what);
-}
-
-void *
-scm_must_realloc (void *where,
- size_t old_size,
- size_t size,
- const char *what)
-{
- scm_c_issue_deprecation_warning
- ("scm_must_realloc is deprecated. "
- "Use scm_gc_realloc and scm_gc_free instead.");
-
- return scm_gc_realloc (where, old_size, size, what);
-}
-
-char *
-scm_must_strndup (const char *str, size_t length)
-{
- scm_c_issue_deprecation_warning
- ("scm_must_strndup is deprecated. "
- "Use scm_gc_strndup and scm_gc_free instead.");
-
- return scm_gc_strndup (str, length, "string");
-}
-
-char *
-scm_must_strdup (const char *str)
-{
- scm_c_issue_deprecation_warning
- ("scm_must_strdup is deprecated. "
- "Use scm_gc_strdup and scm_gc_free instead.");
-
- return scm_gc_strdup (str, "string");
-}
-
-void
-scm_must_free (void *obj)
-#define FUNC_NAME "scm_must_free"
-{
- scm_c_issue_deprecation_warning
- ("scm_must_free is deprecated. "
- "Use scm_gc_malloc and scm_gc_free instead.");
-
- do_gc_free (obj);
-}
-#undef FUNC_NAME
-
-
-void
-scm_done_malloc (long size)
-{
- scm_c_issue_deprecation_warning
- ("scm_done_malloc is deprecated. "
- "Use scm_gc_register_collectable_memory instead.");
-
- if (size >= 0)
- scm_gc_register_collectable_memory (NULL, size, "foreign mallocs");
- else
- scm_gc_unregister_collectable_memory (NULL, -size, "foreign mallocs");
-}
-
-void
-scm_done_free (long size)
-{
- scm_c_issue_deprecation_warning
- ("scm_done_free is deprecated. "
- "Use scm_gc_unregister_collectable_memory instead.");
-
- if (size >= 0)
- scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs");
- else
- scm_gc_register_collectable_memory (NULL, -size, "foreign mallocs");
-}
-
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
# include <config.h>
#endif
-#define SCM_BUILDING_DEPRECATED_CODE
-
#include "libguile/gen-scmconfig.h"
#include <stdio.h>
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
+#include "libguile/simpos.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 <unistd.h>
+/* Size in bytes of the initial heap. This should be about the size of
+ result of 'guile -c "(display (assq-ref (gc-stats)
+ 'heap-total-allocated))"'. */
+
+#define DEFAULT_INITIAL_HEAP_SIZE (128 * 1024 * SIZEOF_SCM_T_BITS)
+
/* Set this to != 0 if every cell that is accessed shall be checked:
*/
int scm_debug_cell_accesses_p = 0;
*/
int scm_debug_cells_gc_interval = 0;
-#if SCM_ENABLE_DEPRECATED == 1
/* Hash table that keeps a reference to objects the user wants to protect from
- garbage collection. It could arguably be private but applications have come
- to rely on it (e.g., Lilypond 2.13.9). */
-SCM scm_protects;
-#else
+ garbage collection. */
static SCM scm_protects;
-#endif
+
#if (SCM_DEBUG_CELL_ACCESSES == 1)
#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
+
\f
-/* Compatibility. */
+static int needs_gc_after_nonlocal_exit = 0;
-#ifndef HAVE_GC_GET_HEAP_USAGE_SAFE
+/* Arrange to throw an exception on failed allocations. */
+static void*
+scm_oom_fn (size_t nbytes)
+{
+ needs_gc_after_nonlocal_exit = 1;
+ scm_report_out_of_memory ();
+ return NULL;
+}
+
+/* Called within GC -- cannot allocate GC memory. */
static void
-GC_get_heap_usage_safe (GC_word *pheap_size, GC_word *pfree_bytes,
- GC_word *punmapped_bytes, GC_word *pbytes_since_gc,
- GC_word *ptotal_bytes)
+scm_gc_warn_proc (char *fmt, GC_word arg)
{
- *pheap_size = GC_get_heap_size ();
- *pfree_bytes = GC_get_free_bytes ();
-#ifdef HAVE_GC_GET_UNMAPPED_BYTES
- *punmapped_bytes = GC_get_unmapped_bytes ();
-#else
- *punmapped_bytes = 0;
-#endif
- *pbytes_since_gc = GC_get_bytes_since_gc ();
- *ptotal_bytes = GC_get_total_bytes ();
+ SCM port;
+ FILE *stream = NULL;
+
+ port = scm_current_warning_port ();
+ if (!SCM_OPPORTP (port))
+ return;
+
+ if (SCM_FPORTP (port))
+ {
+ int fd;
+ scm_force_output (port);
+ if (!SCM_OPPORTP (port))
+ return;
+ fd = dup (SCM_FPORT_FDES (port));
+ if (fd == -1)
+ perror ("Failed to dup warning port fd");
+ else
+ {
+ stream = fdopen (fd, "a");
+ if (!stream)
+ {
+ perror ("Failed to open stream for warning port");
+ close (fd);
+ }
+ }
+ }
+
+ fprintf (stream ? stream : stderr, fmt, arg);
+
+ if (stream)
+ fclose (stream);
}
-#endif
-#ifndef HAVE_GC_GET_FREE_SPACE_DIVISOR
-static GC_word
-GC_get_free_space_divisor (void)
+void
+scm_gc_after_nonlocal_exit (void)
{
- return GC_free_space_divisor;
+ if (needs_gc_after_nonlocal_exit)
+ {
+ needs_gc_after_nonlocal_exit = 0;
+ GC_gcollect_and_unmap ();
+ }
}
-#endif
+
\f
+
/* Hooks. */
scm_t_c_hook scm_before_gc_c_hook;
scm_t_c_hook scm_before_mark_c_hook;
GC_get_heap_usage_safe (&heap_size, &free_bytes, &unmapped_bytes,
&bytes_since_gc, &total_bytes);
-#ifdef HAVE_GC_GET_GC_NO
- /* This function was added in 7.2alpha2 (June 2009). */
gc_times = GC_get_gc_no ();
-#else
- /* This symbol is deprecated as of 7.3. */
- gc_times = GC_gc_no;
-#endif
answer =
scm_list_n (scm_cons (sym_gc_time_taken, scm_from_long (gc_time_taken)),
void
scm_i_gc (const char *what)
{
-#ifndef HAVE_GC_SET_START_CALLBACK
- run_before_gc_c_hook ();
-#endif
GC_gcollect ();
}
\f
-/*
- MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC.
- */
-
-/* Get an integer from an environment variable. */
-int
-scm_getenv_int (const char *var, int def)
-{
- char *end = 0;
- char *val = getenv (var);
- long res = def;
- if (!val)
- return def;
- res = strtol (val, &end, 10);
- if (end == val)
- return def;
- return res;
-}
-
-#ifndef HAVE_GC_SET_FINALIZE_ON_DEMAND
-static void
-GC_set_finalize_on_demand (int foo)
-{
- GC_finalize_on_demand = foo;
-}
-#endif
-
void
scm_storage_prehistory ()
{
-#ifdef HAVE_GC_SET_ALL_INTERIOR_POINTERS
- /* This function was added in 7.2alpha2 (June 2009). */
GC_set_all_interior_pointers (0);
-#else
- /* This symbol is deprecated in 7.3. */
- GC_all_interior_pointers = 0;
-#endif
free_space_divisor = scm_getenv_int ("GC_FREE_SPACE_DIVISOR", 3);
minimum_free_space_divisor = free_space_divisor;
GC_set_free_space_divisor (free_space_divisor);
GC_set_finalize_on_demand (1);
- 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 ();
+#if (GC_VERSION_MAJOR == 7 && GC_VERSION_MINOR == 4 \
+ && GC_VERSION_MICRO == 0)
+ /* BDW-GC 7.4.0 has a bug making it loop indefinitely when using more
+ than one marker thread: <https://github.com/ivmai/bdwgc/pull/30>.
+ Work around it by asking for one marker thread. */
+ setenv ("GC_MARKERS", "1", 1);
#endif
- GC_expand_hp (SCM_DEFAULT_INIT_HEAP_SIZE_2);
+ GC_INIT ();
+
+ GC_expand_hp (DEFAULT_INITIAL_HEAP_SIZE);
/* 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
return NULL;
}
-/* Return some idea of the memory footprint of a process, in bytes.
- Currently only works on Linux systems. */
-static size_t
-get_image_size (void)
-{
- unsigned long size, resident, share;
- size_t ret = 0;
-
- FILE *fp = fopen ("/proc/self/statm", "r");
-
- if (fp && fscanf (fp, "%lu %lu %lu", &size, &resident, &share) == 3)
- ret = resident * 4096;
-
- if (fp)
- fclose (fp);
-
- return ret;
-}
-
-/* These are discussed later. */
-static size_t bytes_until_gc;
+static size_t bytes_until_gc = DEFAULT_INITIAL_HEAP_SIZE;
static scm_i_pthread_mutex_t bytes_until_gc_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-/* Make GC run more frequently when the process image size is growing,
- measured against the number of bytes allocated through the GC.
-
- If Guile is allocating at a GC-managed heap size H, libgc will tend
- to limit the process image size to H*N. But if at the same time the
- user program is mallocating at a rate M bytes per GC-allocated byte,
- then the process stabilizes at H*N*M -- assuming that collecting data
- will result in malloc'd data being freed. It doesn't take a very
- large M for this to be a bad situation. To limit the image size,
- Guile should GC more often -- the bigger the M, the more often.
-
- Numeric functions that produce bigger and bigger integers are
- pessimal, because M is an increasing function of time. Here is an
- example of such a function:
-
- (define (factorial n)
- (define (fac n acc)
- (if (<= n 1)
- acc
- (fac (1- n) (* n acc))))
- (fac n 1))
-
- It is possible for a process to grow for reasons that will not be
- solved by faster GC. In that case M will be estimated as
- artificially high for a while, and so GC will happen more often on
- the Guile side. But when it stabilizes, Guile can ease back the GC
- frequency.
-
- The key is to measure process image growth, not mallocation rate.
- For maximum effectiveness, Guile reacts quickly to process growth,
- and exponentially backs down when the process stops growing.
-
- See http://thread.gmane.org/gmane.lisp.guile.devel/12552/focus=12936
- for further discussion.
- */
-static void *
-adjust_gc_frequency (void * hook_data SCM_UNUSED,
- void *fn_data SCM_UNUSED,
- void *data SCM_UNUSED)
-{
- static size_t prev_image_size = 0;
- static size_t prev_bytes_alloced = 0;
- size_t image_size;
- size_t bytes_alloced;
-
- scm_i_pthread_mutex_lock (&bytes_until_gc_lock);
- bytes_until_gc = GC_get_heap_size ();
- scm_i_pthread_mutex_unlock (&bytes_until_gc_lock);
-
- image_size = get_image_size ();
- bytes_alloced = GC_get_total_bytes ();
-
-#define HEURISTICS_DEBUG 0
-
-#if HEURISTICS_DEBUG
- fprintf (stderr, "prev image / alloced: %lu / %lu\n", prev_image_size, prev_bytes_alloced);
- fprintf (stderr, " image / alloced: %lu / %lu\n", image_size, bytes_alloced);
- fprintf (stderr, "divisor %lu / %f\n", free_space_divisor, target_free_space_divisor);
-#endif
-
- if (prev_image_size && bytes_alloced != prev_bytes_alloced)
- {
- double growth_rate, new_target_free_space_divisor;
- double decay_factor = 0.5;
- double hysteresis = 0.1;
-
- growth_rate = ((double) image_size - prev_image_size)
- / ((double)bytes_alloced - prev_bytes_alloced);
-
-#if HEURISTICS_DEBUG
- fprintf (stderr, "growth rate %f\n", growth_rate);
-#endif
-
- new_target_free_space_divisor = minimum_free_space_divisor;
-
- if (growth_rate > 0)
- new_target_free_space_divisor *= 1.0 + growth_rate;
-
-#if HEURISTICS_DEBUG
- fprintf (stderr, "new divisor %f\n", new_target_free_space_divisor);
-#endif
-
- if (new_target_free_space_divisor < target_free_space_divisor)
- /* Decay down. */
- target_free_space_divisor =
- (decay_factor * target_free_space_divisor
- + (1.0 - decay_factor) * new_target_free_space_divisor);
- else
- /* Jump up. */
- target_free_space_divisor = new_target_free_space_divisor;
-
-#if HEURISTICS_DEBUG
- fprintf (stderr, "new target divisor %f\n", target_free_space_divisor);
-#endif
-
- if (free_space_divisor + 0.5 + hysteresis < target_free_space_divisor
- || free_space_divisor - 0.5 - hysteresis > target_free_space_divisor)
- {
- free_space_divisor = lround (target_free_space_divisor);
-#if HEURISTICS_DEBUG
- fprintf (stderr, "new divisor %lu\n", free_space_divisor);
-#endif
- GC_set_free_space_divisor (free_space_divisor);
- }
- }
-
- prev_image_size = image_size;
- prev_bytes_alloced = bytes_alloced;
-
- return NULL;
-}
-
-/* The adjust_gc_frequency routine handles transients in the process
- image size. It can't handle instense non-GC-managed steady-state
- allocation though, as it decays the FSD at steady-state down to its
- minimum value.
-
- The only real way to handle continuous, high non-GC allocation is to
- let the GC know about it. This routine can handle non-GC allocation
- rates that are similar in size to the GC-managed heap size.
- */
-
void
scm_gc_register_allocation (size_t size)
{
\f
-
-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_tc7_pointer:
- return "foreign";
- case scm_tc7_hashtable:
- return "hashtable";
- case scm_tc7_fluid:
- return "fluid";
- case scm_tc7_dynamic_state:
- return "dynamic state";
- case scm_tc7_frame:
- return "frame";
- case scm_tc7_objcode:
- return "objcode";
- case scm_tc7_vm:
- return "vm";
- case scm_tc7_vm_cont:
- return "vm continuation";
- 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_port:
- return "port";
- break;
- case scm_tc7_smob:
- {
- int k = 0xff & (tag >> 8);
- return (scm_smobs[k].name);
- }
- break;
- }
-
- return NULL;
-}
-
-
-
-\f
void
scm_init_gc ()
{
scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0);
scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0);
-#if HAVE_GC_GET_HEAP_USAGE_SAFE
- /* GC_get_heap_usage does not take a lock, and so can run in the GC
- start hook. */
- scm_c_hook_add (&scm_before_gc_c_hook, adjust_gc_frequency, NULL, 0);
-#else
- /* GC_get_heap_usage might take a lock (and did from 7.2alpha1 to
- 7.2alpha7), so call it in the after_gc_hook. */
- scm_c_hook_add (&scm_after_gc_c_hook, adjust_gc_frequency, NULL, 0);
-#endif
-
-#ifdef HAVE_GC_SET_START_CALLBACK
+ GC_set_oom_fn (scm_oom_fn);
+ GC_set_warn_proc (scm_gc_warn_proc);
GC_set_start_callback (run_before_gc_c_hook);
-#endif
#include "libguile/gc.x"
}
#define SCM_GC_H
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006,
- * 2007, 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+ * 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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 word_1;
} scm_t_cell;
-/* 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
- * storing the native Cray pointers like the ones that looks like scm
- * expects. This is done for any pointers that point to a cell,
- * pointers to scm_vector elts, functions, &c are not munged.
- */
-#ifdef _UNICOS
-# define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x) >> 3))
-# define PTR2SCM(x) (SCM_PACK (((scm_t_bits) (x)) << 3))
-#else
-# define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x)))
-# define PTR2SCM(x) (SCM_PACK ((scm_t_bits) (x)))
-#endif /* def _UNICOS */
-
-
+/* FIXME: deprecate. */
+#define PTR2SCM(x) (SCM_PACK_POINTER (x))
+#define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK_POINTER (x)))
/* Low level cell data accessing macros. These macros should only be used
* from within code related to garbage collection issues, since they will
\f
-#if (SCM_ENABLE_DEPRECATED == 1)
-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_init_heap_size_2 deprecated
-#define scm_default_min_yield_2 deprecated
-#define scm_default_max_segment_size deprecated
-#endif
-
SCM_API unsigned long scm_gc_ports_collected;
SCM_API SCM scm_after_gc_hook;
SCM_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
SCM_INLINE SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
scm_t_bits ccr, scm_t_bits cdr);
-SCM_INLINE SCM scm_words (scm_t_bits car, scm_t_uint16 n_words);
+SCM_INLINE SCM scm_words (scm_t_bits car, scm_t_uint32 n_words);
#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
SCM_INLINE_IMPLEMENTATION SCM
scm_cell (scm_t_bits car, scm_t_bits cdr)
{
- SCM cell = PTR2SCM (SCM_GC_MALLOC (sizeof (scm_t_cell)));
+ SCM cell = SCM_PACK_POINTER (SCM_GC_MALLOC (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
{
SCM z;
- z = PTR2SCM (SCM_GC_MALLOC (2 * sizeof (scm_t_cell)));
+ z = SCM_PACK_POINTER (SCM_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
}
SCM_INLINE_IMPLEMENTATION SCM
-scm_words (scm_t_bits car, scm_t_uint16 n_words)
+scm_words (scm_t_bits car, scm_t_uint32 n_words)
{
SCM z;
- z = PTR2SCM (SCM_GC_MALLOC (sizeof (scm_t_bits) * n_words));
+ z = SCM_PACK_POINTER (SCM_GC_MALLOC (sizeof (scm_t_bits) * n_words));
SCM_GC_SET_CELL_WORD (z, 0, car);
/* FIXME: is the following concern even relevant with BDW-GC? */
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);
-#if SCM_ENABLE_DEPRECATED == 1
-SCM_DEPRECATED SCM scm_protects;
-#endif
+SCM_INTERNAL void scm_gc_after_nonlocal_exit (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_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_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
-
#endif /* SCM_GC_H */
/*
+++ /dev/null
-/* classes: h_files */
-
-#ifndef GDB_INTERFACE_H
-#define GDB_INTERFACE_H
-/* Simple interpreter interface for GDB, the GNU debugger.
- Copyright (C) 1996, 2000, 2001, 2006 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
-
-The author can be reached at djurfeldt@nada.kth.se
-Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
-
-/* This is the header file for GDB's interpreter interface. The
- interpreter must supply definitions of all symbols declared in this
- file.
-
- Before including this file, you must #define GDB_TYPE to be the
- data type used for communication with the interpreter. */
-
-/* The following macro can be used to anchor the symbols of the
- interface in your main program. This is necessary if the interface
- is defined in a library, such as Guile. */
-
-#if !defined (__MINGW32__) && !defined (__CYGWIN__)
-#define GDB_INTERFACE \
-void *gdb_interface[] = { \
- &gdb_options, \
- &gdb_language, \
- &gdb_result, \
- &gdb_output, \
- &gdb_output_length, \
- (void *) gdb_maybe_valid_type_p, \
- (void *) gdb_read, \
- (void *) gdb_eval, \
- (void *) gdb_print, \
- (void *) gdb_binding \
-}
-#else /* __MINGW32__, __CYGWIN__ */
-/* Because the following functions are imported from a DLL (some kind of
- shared library) these are NO static initializers. That is why you need to
- define them and assign the functions and data items at run time. */
-#define GDB_INTERFACE \
-void *gdb_interface[] = \
- { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL };
-#define GDB_INTERFACE_INIT \
- do { \
- gdb_interface[0] = &gdb_options; \
- gdb_interface[1] = &gdb_language; \
- gdb_interface[2] = &gdb_result; \
- gdb_interface[3] = &gdb_output; \
- gdb_interface[4] = &gdb_output_length; \
- gdb_interface[5] = (void *) gdb_maybe_valid_type_p; \
- gdb_interface[6] = (void *) gdb_read; \
- gdb_interface[7] = (void *) gdb_eval; \
- gdb_interface[8] = (void *) gdb_print; \
- gdb_interface[9] = (void *) gdb_binding; \
- } while (0);
-#endif /* __MINGW32__ */
-
-/* GDB_OPTIONS is a set of flags informing gdb what features are present
- in the interface. Currently only one option is supported: */
-
-/* GDB_HAVE_BINDINGS: Set this bit if your interpreter can create new
- top level bindings on demand (through gdb_top_level_binding) */
-
-#define GDB_HAVE_BINDINGS 1
-
-SCM_API unsigned short gdb_options;
-
-/* GDB_LANGUAGE holds the name of the preferred language mode for this
- interpreter. For lisp interpreters, the suggested mode is "lisp/c". */
-
-SCM_API char *gdb_language;
-
-/* GDB_RESULT is used for passing results from the interpreter to GDB */
-
-SCM_API GDB_TYPE gdb_result;
-
-/* The interpreter passes strings to GDB in GDB_OUTPUT and
- GDB_OUTPUT_LENGTH. GDB_OUTPUT should hold the pointer to the
- string. GDB_OUTPUT_LENGTH should hold its length. The string
- doesn't need to be terminated by '\0'. */
-
-SCM_API char *gdb_output;
-
-SCM_API int gdb_output_length;
-
-/* Return TRUE if the interpreter regards VALUE's type as valid. A
- lazy implementation is allowed to pass TRUE always. FALSE should
- only be returned when it is certain that VALUE is not valid.
-
- In the "lisp/c" language mode, this is used to heuristically
- discriminate lisp values from C values during printing. */
-
-SCM_API int gdb_maybe_valid_type_p (GDB_TYPE value);
-
-/* Parse expression in string STR. Store result in GDB_RESULT, then
- return 0 to indicate success. On error, return -1 to indicate
- failure. An error string can be passed in GDB_OUTPUT and
- GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero if
- no message is passed. Please note that the resulting value should
- be protected against garbage collection. */
-
-SCM_API int gdb_read (char *str);
-
-/* Evaluate expression EXP. Store result in GDB_RESULT, then return 0
- to indicate success. On error, return -1 to indicate failure. Any
- output (both on success and failure) can be passed in GDB_OUTPUT
- and GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero
- if no output is passed. Please note that the resulting lisp object
- should be protected against garbage collection. */
-
-SCM_API int gdb_eval (GDB_TYPE exp);
-
-/* Print VALUE. Store output in GDB_OUTPUT and GDB_OUTPUT_LENGTH.
- Return 0 to indicate success. On error, return -1 to indicate
- failure. GDB will not look at GDB_OUTPUT or GDB_OUTPUT_LENGTH on
- failure. Note that this function should be robust against strange
- values. It could in fact be passed any kind of value. */
-
-SCM_API int gdb_print (GDB_TYPE value);
-
-/* Bind NAME to VALUE in interpreter. (GDB has previously obtained
- NAME by passing a string to gdb_read.) Return 0 to indicate
- success or -1 to indicate failure. This feature is optional. GDB
- will only call this function if the GDB_HAVE_BINDINGS flag is set
- in gdb_options. Note that GDB may call this function many times
- for the same name.
-
- For scheme interpreters, this function should introduce top-level
- bindings. */
-
-SCM_API int gdb_binding (GDB_TYPE name, GDB_TYPE value);
-
-#endif /* GDB_INTERFACE_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+++ /dev/null
-/* GDB interface for Guile
- * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009,2011,2012,
- * 2014 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/_scm.h"
-
-#include <stdio.h>
-#include <string.h>
-#include <unistd.h>
-
-#include "libguile/strports.h"
-#include "libguile/read.h"
-#include "libguile/eval.h"
-#include "libguile/chars.h"
-#include "libguile/modules.h"
-#include "libguile/ports.h"
-#include "libguile/fluids.h"
-#include "libguile/strings.h"
-#include "libguile/init.h"
-
-#include "libguile/gdbint.h"
-\f
-/* {Support for debugging with gdb}
- *
- * TODO:
- *
- * 1. Redirect outputs
- * 2. Catch errors
- * 3. Prevent print from causing segmentation fault when given broken pairs
- */
-
-#define GDB_TYPE SCM
-
-#include "libguile/gdb_interface.h"
-
-\f
-
-/* Be carefull when this macro is true.
- scm_gc_running_p is set during gc.
- */
-#define SCM_GC_P (scm_gc_running_p)
-
-/* Macros that encapsulate blocks of code which can be called by the
- * debugger.
- */
-#define SCM_BEGIN_FOREIGN_BLOCK \
-do { \
- scm_print_carefully_p = 1; \
-} while (0)
-
-
-#define SCM_END_FOREIGN_BLOCK \
-do { \
- scm_print_carefully_p = 0; \
-} while (0)
-
-
-#define RESET_STRING { gdb_output_length = 0; }
-
-#define SEND_STRING(str) \
-do { \
- gdb_output = (char *) (str); \
- gdb_output_length = strlen ((const char *) (str)); \
-} while (0)
-
-
-/* {Gdb interface}
- */
-
-unsigned short gdb_options = GDB_HAVE_BINDINGS;
-
-char *gdb_language = "lisp/c";
-
-SCM gdb_result;
-
-char *gdb_output;
-
-int gdb_output_length;
-
-int scm_print_carefully_p;
-
-static SCM gdb_input_port;
-static SCM gdb_output_port;
-
-
-int
-gdb_maybe_valid_type_p (SCM 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 (1) /* (SCM_GC_P) */ /* FIXME */
- {
- char *p;
- for (p = str; *p != '\0'; ++p)
- switch (*p)
- {
- case '(':
- case '\'':
- case '"':
- SEND_STRING ("Can't read this kind of expressions during gc");
- return -1;
- case '#':
- if (*++p == '\0')
- goto premature;
- if (*p == '\\')
- {
- if (*++p != '\0')
- continue;
- premature:
- SEND_STRING ("Premature end of lisp expression");
- return -1;
- }
- default:
- continue;
- }
- }
- SCM_BEGIN_FOREIGN_BLOCK;
- unmark_port (gdb_input_port);
- scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
- scm_puts (str, gdb_input_port);
- scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
- scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
-
- /* Read one object */
- ans = scm_read (gdb_input_port);
- if (SCM_GC_P)
- {
- if (SCM_NIMP (ans))
- {
- SEND_STRING ("Non-immediate created during gc. Memory may be trashed.");
- status = -1;
- goto exit;
- }
- }
- gdb_result = ans;
- /* 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
-}
-
-
-int
-gdb_eval (SCM exp)
-{
- RESET_STRING;
- if (SCM_GC_P)
- {
- SEND_STRING ("Can't evaluate lisp expressions during gc");
- return -1;
- }
- SCM_BEGIN_FOREIGN_BLOCK;
- {
- gdb_result = scm_permanent_object (scm_primitive_eval (exp));
- }
- SCM_END_FOREIGN_BLOCK;
- return 0;
-}
-
-
-int
-gdb_print (SCM obj)
-{
- if (!scm_initialized_p)
- SEND_STRING ("*** Guile not initialized ***");
- else
- {
- RESET_STRING;
- SCM_BEGIN_FOREIGN_BLOCK;
- /* Reset stream */
- scm_seek (gdb_output_port, SCM_INUM0, scm_from_int (SEEK_SET));
- scm_write (obj, gdb_output_port);
- scm_truncate_file (gdb_output_port, SCM_UNDEFINED);
- {
- scm_t_port *pt = SCM_PTAB_ENTRY (gdb_output_port);
-
- scm_flush (gdb_output_port);
- *(pt->write_buf + pt->read_buf_size) = 0;
- SEND_STRING (pt->read_buf);
- }
- SCM_END_FOREIGN_BLOCK;
- }
- return 0;
-}
-
-
-int
-gdb_binding (SCM name, SCM value)
-{
- RESET_STRING;
- if (SCM_GC_P)
- {
- SEND_STRING ("Can't create new bindings during gc");
- return -1;
- }
- SCM_BEGIN_FOREIGN_BLOCK;
- {
- scm_define (name, value);
- }
- SCM_END_FOREIGN_BLOCK;
- return 0;
-}
-
-void
-scm_init_gdbint ()
-{
- static char *s = "scm_init_gdb_interface";
- SCM port;
-
- scm_print_carefully_p = 0;
-
- port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
- SCM_OPN | SCM_WRTNG,
- s);
- gdb_output_port = scm_permanent_object (port);
-
- port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
- SCM_OPN | SCM_RDNG | SCM_WRTNG,
- s);
- gdb_input_port = scm_permanent_object (port);
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
- use 1 and 0 for public #defines instead of "def and undef",
i.e. use #define SCM_HAVE_FOO rather than just not defining
SCM_HAVE_FOO whenever possible. See GNU Coding Guidelines for
- rationale. The only notable non-deprecated exceptions to this
- rule are GUILE_DEBUG and GUILE_DEBUG_FREELIST which do not follow
- this convention in order to retain backward compatibility.
+ rationale. The only notable non-deprecated exception to this rule
+ is GUILE_DEBUG which does not follow this convention in order to
+ retain backward compatibility.
- in the code below, be *VERY* careful not to use or rely on any
runtime-dynamic information below. For example, you cannot use
#endif
pf ("\n");
- pf ("#if SCM_ENABLE_DEPRECATED == 1\n"
- "# define USE_THREADS 1 /* always true now */\n"
- "# define GUILE_ISELECT 1 /* always true now */\n"
- "# define READER_EXTENSIONS 1 /* always true now */\n"
- "# define DEBUG_EXTENSIONS 1 /* always true now */\n"
- "# define DYNAMIC_LINKING 1 /* always true now */\n"
- "#endif\n");
- printf ("\n");
-
pf ("#define SCM_HAVE_ARRAYS 1 /* always true now */\n");
pf ("\n");
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013, 2014 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
scm_is_array (SCM obj)
{
- return scm_i_array_implementation_for_obj (obj) ? 1 : 0;
+ if (!SCM_HEAP_OBJECT_P (obj))
+ return 0;
+
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tc7_string:
+ case scm_tc7_vector:
+ case scm_tc7_bitvector:
+ case scm_tc7_bytevector:
+ case scm_tc7_array:
+ return 1;
+ default:
+ return 0;
+ }
}
SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
scm_is_typed_array (SCM obj, SCM type)
{
int ret = 0;
- if (scm_i_array_implementation_for_obj (obj))
+ if (scm_is_array (obj))
{
scm_t_array_handle h;
}
#undef FUNC_NAME
+SCM_DEFINE (scm_array_type_code,
+ "array-type-code", 1, 0, 0,
+ (SCM array),
+ "Return the type of the elements in @var{array},\n"
+ "as an integer code.")
+#define FUNC_NAME s_scm_array_type_code
+{
+ scm_t_array_handle h;
+ scm_t_array_element_type element_type;
+
+ scm_array_get_handle (array, &h);
+ element_type = h.element_type;
+ scm_array_handle_release (&h);
+
+ return scm_from_uint16 (element_type);
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
(SCM ra, SCM args),
"Return @code{#t} if its arguments would be acceptable to\n"
#ifndef SCM_GENERALIZED_ARRAYS_H
#define SCM_GENERALIZED_ARRAYS_H
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2013, 2014 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_array_dimensions (SCM ra);
SCM_API SCM scm_array_type (SCM ra);
+SCM_API SCM scm_array_type_code (SCM ra);
SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args);
SCM_API SCM scm_c_array_ref_1 (SCM v, ssize_t idx0);
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
- * 2005, 2006, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+ * 2005, 2006, 2009, 2010, 2011, 2012, 2013, 2014 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
size_t
scm_c_generalized_vector_length (SCM v)
{
- scm_t_array_handle h;
- size_t ret;
- scm_generalized_vector_get_handle (v, &h);
- ret = h.dims[0].ubnd - h.dims[0].lbnd + 1;
- scm_array_handle_release (&h);
- return ret;
+ return scm_c_array_length (v);
}
SCM
-scm_c_generalized_vector_ref (SCM v, size_t idx)
+scm_c_generalized_vector_ref (SCM v, ssize_t idx)
{
- scm_t_array_handle h;
- size_t pos;
- SCM ret;
- scm_generalized_vector_get_handle (v, &h);
- pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc;
- ret = h.impl->vref (&h, pos);
- scm_array_handle_release (&h);
- return ret;
+ return scm_c_array_ref_1 (v, idx);
}
void
-scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
+scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val)
{
- scm_t_array_handle h;
- size_t pos;
- scm_generalized_vector_get_handle (v, &h);
- pos = h.base + h.dims[0].lbnd + idx * h.dims[0].inc;
- h.impl->vset (&h, pos, val);
- scm_array_handle_release (&h);
+ scm_c_array_set_1_x (v, val, idx);
}
void
SCM_API int scm_is_generalized_vector (SCM obj);
SCM_API size_t scm_c_generalized_vector_length (SCM v);
-SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx);
-SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val);
+SCM_API SCM scm_c_generalized_vector_ref (SCM v, ssize_t idx);
+SCM_API void scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val);
SCM_API void scm_generalized_vector_get_handle (SCM vec,
scm_t_array_handle *h);
-/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2014
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#include "libguile/strings.h"
#include "libguile/strports.h"
#include "libguile/vectors.h"
-#include "libguile/weaks.h"
#include "libguile/vm.h"
#include "libguile/validate.h"
SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
-/* FIXME, exports should come from the scm file only */
-#define DEFVAR(v, val) \
- { scm_module_define (scm_module_goops, (v), (val)); \
- scm_module_export (scm_module_goops, scm_list_1 ((v))); \
- }
-
-
/* Class redefinition protocol:
A class is represented by a heap header h1 which points to a
static SCM class_fluid;
static SCM class_dynamic_state;
static SCM class_frame;
-static SCM class_objcode;
-static SCM class_vm;
static SCM class_vm_cont;
static SCM class_bytevector;
static SCM class_uvec;
static SCM class_bitvector;
static SCM vtable_class_map = SCM_BOOL_F;
-static scm_i_pthread_mutex_t vtable_class_map_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* Port classes. Allocate 3 times the maximum number of port types so that
input ports, output ports, and in/out ports can be stored at different
{
SCM class;
- scm_i_pthread_mutex_lock (&vtable_class_map_lock);
-
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
if (scm_is_false (vtable_class_map))
- vtable_class_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
if (scm_is_false (scm_struct_vtable_p (vtable)))
abort ();
- class = scm_hashq_ref (vtable_class_map, vtable, SCM_BOOL_F);
-
- scm_i_pthread_mutex_unlock (&vtable_class_map_lock);
+ class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F);
if (scm_is_false (class))
{
/* Don't worry about races. This only happens when creating a
vtable, which happens by definition in one thread. */
- scm_i_pthread_mutex_lock (&vtable_class_map_lock);
- scm_hashq_set_x (vtable_class_map, vtable, class);
- scm_i_pthread_mutex_unlock (&vtable_class_map_lock);
+ scm_weak_table_putq_x (vtable_class_map, vtable, class);
}
return class;
return class_dynamic_state;
case scm_tc7_frame:
return class_frame;
- case scm_tc7_objcode:
- return class_objcode;
- case scm_tc7_vm:
- return class_vm;
+ case scm_tc7_keyword:
+ return scm_class_keyword;
case scm_tc7_vm_cont:
return class_vm_cont;
case scm_tc7_bytevector:
SCM_SYMBOL (sym_default_slot_definition_class, "default-slot-definition-class");
SCM_SYMBOL (sym_slots, "slots");
SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
-SCM_SYMBOL (sym_keyword_access, "keyword-access");
SCM_SYMBOL (sym_nfields, "nfields");
scm_list_1 (sym_default_slot_definition_class),
scm_list_1 (sym_slots),
scm_list_1 (sym_getters_n_setters),
- scm_list_1 (sym_keyword_access),
scm_list_1 (sym_nfields),
SCM_UNDEFINED);
}
prep_hashsets (scm_class_class);
- DEFVAR(name, scm_class_class);
+ scm_module_define (scm_module_goops, name, scm_class_class);
/**** <top> ****/
name = scm_from_latin1_symbol ("<top>");
scm_class_top = scm_basic_make_class (scm_class_class, name,
SCM_EOL, SCM_EOL);
- DEFVAR(name, scm_class_top);
+ scm_module_define (scm_module_goops, name, scm_class_top);
/**** <object> ****/
name = scm_from_latin1_symbol ("<object>");
scm_class_object = scm_basic_make_class (scm_class_class, name,
scm_list_1 (scm_class_top), SCM_EOL);
- DEFVAR (name, scm_class_object);
+ scm_module_define (scm_module_goops, name, scm_class_object);
/* <top> <object> and <class> were partially initialized. Correct them here */
SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class));
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_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 delayed_compile_var;
}
}
+/* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
+ * assumed that 'gf' is zero if uninitialized. It would be cleaner if
+ * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
+ */
+
+SCM
+scm_wta_dispatch_0 (SCM gf, const char *subr)
+{
+ if (!SCM_UNPACK (gf))
+ scm_error_num_args_subr (subr);
+
+ return scm_call_0 (gf);
+}
+
+SCM
+scm_wta_dispatch_1 (SCM gf, SCM a1, int pos, const char *subr)
+{
+ if (!SCM_UNPACK (gf))
+ scm_wrong_type_arg (subr, pos, a1);
+
+ return scm_call_1 (gf, a1);
+}
+
+SCM
+scm_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos, const char *subr)
+{
+ if (!SCM_UNPACK (gf))
+ scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
+
+ return scm_call_2 (gf, a1, a2);
+}
+
+SCM
+scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr)
+{
+ if (!SCM_UNPACK (gf))
+ scm_wrong_type_arg (subr, pos, scm_list_ref (args, scm_from_int (pos)));
+
+ return scm_apply_0 (gf, args);
+}
+
/******************************************************************************
*
* Protocol for calling a generic fumction
static void
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
{
- SCM tmp = scm_from_locale_symbol (name);
+ SCM tmp = scm_from_utf8_symbol (name);
*var = scm_basic_make_class (meta, tmp,
scm_is_pair (super) ? super : scm_list_1 (super),
slots);
- DEFVAR(tmp, *var);
+ scm_module_define (scm_module_goops, tmp, *var);
}
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_frame, "<frame>",
scm_class_class, scm_class_top, SCM_EOL);
- make_stdcls (&class_objcode, "<objcode>",
- scm_class_class, scm_class_top, SCM_EOL);
- make_stdcls (&class_vm, "<vm>",
- scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_vm_cont, "<vm-continuation>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_bytevector, "<bytevector>",
static SCM
make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep)
{
- SCM class, name;
+ SCM name;
if (type_name)
{
char buffer[100];
sprintf (buffer, template, type_name);
- name = scm_from_locale_symbol (buffer);
+ name = scm_from_utf8_symbol (buffer);
}
else
name = SCM_GOOPS_UNBOUND;
- 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_is_false (scm_module_variable (scm_module_goops, name)))
- DEFVAR (name, class);
- return class;
+ return scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
+ name, supers, SCM_EOL);
}
static SCM
make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
{
- SCM class, name;
+ SCM name;
+
if (scm_is_true (type_name_sym))
{
name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
else
name = SCM_GOOPS_UNBOUND;
- 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_is_false (scm_module_variable (scm_module_goops, name)))
- DEFVAR (name, class);
- return class;
+ return scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
+ name, supers, SCM_EOL);
}
SCM
for (i = 0; i < SCM_I_MAX_SMOB_TYPE_COUNT; ++i)
scm_smob_class[i] = SCM_BOOL_F;
- scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
-
for (i = 0; i < scm_numsmob; ++i)
if (scm_is_false (scm_smob_class[i]))
scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
{
long i;
- for (i = 0; i < scm_numptob; ++i)
+ for (i = scm_c_num_port_types () - 1; i >= 0; i--)
scm_make_port_classes (i, SCM_PTOBNAME (i));
}
SCM name = scm_from_latin1_symbol ("no-applicable-method");
scm_no_applicable_method =
scm_make (scm_list_3 (scm_class_generic, k_name, name));
- DEFVAR (name, scm_no_applicable_method);
+ scm_module_define (scm_module_goops, name, scm_no_applicable_method);
}
return SCM_UNSPECIFIED;
"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_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)
+#define scm_si_getters_n_setters (scm_vtable_offset_user + 16)
+#define scm_si_nfields (scm_vtable_offset_user + 17) /* an integer */
+#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 18)
typedef struct scm_t_method {
SCM generic_function;
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);
+
+/* These procedures are for dispatching to a generic when a primitive
+ fails to apply. They raise a wrong-type-arg error if the primitive's
+ generic has not been initialized yet. */
+SCM_API SCM scm_wta_dispatch_0 (SCM gf, const char *subr);
+SCM_API SCM scm_wta_dispatch_1 (SCM gf, SCM a1, int pos, const char *subr);
+SCM_API SCM scm_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos, const char *subr);
+SCM_API SCM scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr);
SCM_INTERNAL SCM scm_i_define_class_for_vtable (SCM vtable);
-/* Copyright (C) 1995-2001, 2006, 2008-2011,
- * 2014 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 <stdarg.h>
-
-#include "libguile/_scm.h"
-#include "libguile/gsubr.h"
-#include "libguile/foreign.h"
-#include "libguile/instructions.h"
-#include "libguile/objcodes.h"
-#include "libguile/srfi-4.h"
-#include "libguile/programs.h"
-
-#include "libguile/private-options.h"
-\f
-/*
- * gsubr.c
- * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
- * and rest arguments.
- */
-
-/* #define GSUBR_TEST */
-
-\f
-
-/* OK here goes nothing: we're going to define VM assembly trampolines for
- invoking subrs, along with their meta-information, and then wrap them into
- statically allocated objcode values. Ready? Right!
-*/
-
-/* There's a maximum of 10 args, so the number of possible combinations is:
- (REQ-OPT-REST)
- for 0 args: 1 (000) (1 + 0)
- for 1 arg: 3 (100, 010, 001) (2 + 1)
- for 2 args: 5 (200, 110, 020, 101, 011) (3 + 2)
- for 3 args: 7 (300, 210, 120, 030, 201, 111, 021) (4 + 3)
- for N args: 2N+1
-
- and the index at which N args starts:
- for 0 args: 0
- for 1 args: 1
- for 2 args: 4
- for 3 args: 9
- for N args: N^2
-
- One can prove this:
-
- (1 + 3 + 5 + ... + (2N+1))
- = ((2N+1)+1)/2 * (N+1)
- = 2(N+1)/2 * (N+1)
- = (N+1)^2
-
- Thus the total sum is 11^2 = 121. Let's just generate all of them as
- read-only data.
-*/
-
-#ifdef WORDS_BIGENDIAN
-#define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40
-#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
-#else
-#define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0
-#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
-#endif
-
-/* A: req; B: opt; C: rest */
-#define A(nreq) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 5 */ scm_op_subr_call, nreq, /* and call (will return value as well) */ \
- /* 7 */ scm_op_nop, \
- /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (3, 7, nreq, 0, 0)
-
-#define B(nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \
- /* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 8 */ scm_op_subr_call, nopt, /* and call (will return value as well) */ \
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, 0, nopt, 0)
-
-#define C() \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */ \
- /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 5 */ scm_op_subr_call, 1, /* and call (will return value as well) */ \
- /* 7 */ scm_op_nop, \
- /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (3, 7, 0, 0, 1)
-
-#define AB(nreq, nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \
- /* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \
- /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 11 */ scm_op_subr_call, nreq+nopt, /* and call (will return value as well) */ \
- /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (9, 13, nreq, nopt, 0)
-
-#define AC(nreq) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 8 */ scm_op_subr_call, nreq+1, /* and call (will return value as well) */ \
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, nreq, 0, 1)
-
-#define BC(nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \
- /* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */ \
- /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 8 */ scm_op_subr_call, nopt+1, /* and call (will return value as well) */ \
- /* 10 */ scm_op_nop, scm_op_nop, \
- /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (6, 10, 0, nopt, 1)
-
-#define ABC(nreq, nopt) \
- OBJCODE_HEADER, \
- /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
- /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \
- /* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */ \
- /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
- /* 11 */ scm_op_subr_call, nreq+nopt+1, /* and call (will return value as well) */ \
- /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \
- /* 16 */ META (9, 13, nreq, nopt, 1)
-
-#define META(start, end, nreq, nopt, rest) \
- META_HEADER, \
- /* 0 */ scm_op_make_eol, /* bindings */ \
- /* 1 */ scm_op_make_eol, /* sources */ \
- /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
- /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
- /* 8 */ scm_op_make_int8, nopt, /* N optionals */ \
- /* 10 */ rest ? scm_op_make_true : scm_op_make_false, /* maybe a rest arg */ \
- /* 11 */ scm_op_list, 0, 5, /* make a list of those 5 vals */ \
- /* 14 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
- /* 17 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
- /* 25 */ scm_op_object_ref, 1, /* the name from the object table */ \
- /* 27 */ scm_op_cons, /* make a pair for the properties */ \
- /* 28 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
- /* 31 */ scm_op_return /* and return */ \
- /* 32 */
-
-/*
- (defun generate-bytecode (n)
- "Generate bytecode for N arguments"
- (interactive "p")
- (insert (format "/\* %d arguments *\/\n " n))
- (let ((nreq n))
- (while (<= 0 nreq)
- (let ((nopt (- n nreq)))
- (insert
- (if (< 0 nreq)
- (if (< 0 nopt)
- (format "AB(%d,%d), " nreq nopt)
- (format "A(%d), " nreq))
- (if (< 0 nopt)
- (format "B(%d), " nopt)
- (format "A(0), "))))
- (setq nreq (1- nreq))))
- (insert "\n ")
- (setq nreq (1- n))
- (while (<= 0 nreq)
- (let ((nopt (- n nreq 1)))
- (insert
- (if (< 0 nreq)
- (if (< 0 nopt)
- (format "ABC(%d,%d), " nreq nopt)
- (format "AC(%d), " nreq))
- (if (< 0 nopt)
- (format "BC(%d), " nopt)
- (format "C(), "))))
- (setq nreq (1- nreq))))
- (insert "\n\n ")))
-
- (defun generate-bytecodes (n)
- "Generate bytecodes for up to N arguments"
- (interactive "p")
- (let ((i 0))
- (while (<= i n)
- (generate-bytecode i)
- (setq i (1+ i)))))
-*/
-static const struct
-{
- SCM_ALIGNED (8) scm_t_uint64 dummy; /* alignment */
- const scm_t_uint8 bytes[121 * (sizeof (struct scm_objcode) + 16
- + sizeof (struct scm_objcode) + 32)];
-} raw_bytecode = {
- 0,
- {
- /* C-u 1 0 M-x generate-bytecodes RET */
- /* 0 arguments */
- A(0),
-
- /* 1 arguments */
- A(1), B(1),
- C(),
-
- /* 2 arguments */
- A(2), AB(1,1), B(2),
- AC(1), BC(1),
-
- /* 3 arguments */
- A(3), AB(2,1), AB(1,2), B(3),
- AC(2), ABC(1,1), BC(2),
-
- /* 4 arguments */
- A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
- AC(3), ABC(2,1), ABC(1,2), BC(3),
-
- /* 5 arguments */
- A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5),
- AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4),
-
- /* 6 arguments */
- A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6),
- AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5),
-
- /* 7 arguments */
- A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7),
- AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6),
-
- /* 8 arguments */
- A(8), AB(7,1), AB(6,2), AB(5,3), AB(4,4), AB(3,5), AB(2,6), AB(1,7), B(8),
- AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7),
-
- /* 9 arguments */
- A(9), AB(8,1), AB(7,2), AB(6,3), AB(5,4), AB(4,5), AB(3,6), AB(2,7), AB(1,8), B(9),
- AC(8), ABC(7,1), ABC(6,2), ABC(5,3), ABC(4,4), ABC(3,5), ABC(2,6), ABC(1,7), BC(8),
-
- /* 10 arguments */
- A(10), AB(9,1), AB(8,2), AB(7,3), AB(6,4), AB(5,5), AB(4,6), AB(3,7), AB(2,8), AB(1,9), B(10),
- AC(9), ABC(8,1), ABC(7,2), ABC(6,3), ABC(5,4), ABC(4,5), ABC(3,6), ABC(2,7), ABC(1,8), BC(9)
- }
-};
-
-#undef A
-#undef B
-#undef C
-#undef AB
-#undef AC
-#undef BC
-#undef ABC
-#undef OBJCODE_HEADER
-#undef META_HEADER
-#undef META
-
-/*
- ;; (nargs * nargs) + nopt + rest * (nargs + 1)
- (defun generate-objcode-cells-helper (n)
- "Generate objcode cells for N arguments"
- (interactive "p")
- (insert (format " /\* %d arguments *\/\n" n))
- (let ((nreq n))
- (while (<= 0 nreq)
- (let ((nopt (- n nreq)))
- (insert
- (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
- (* (+ 4 4 16 4 4 32)
- (+ (* n n) nopt))))
- (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
- (setq nreq (1- nreq))))
- (insert "\n")
- (setq nreq (1- n))
- (while (<= 0 nreq)
- (let ((nopt (- n nreq 1)))
- (insert
- (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
- (* (+ 4 4 16 4 4 32)
- (+ (* n n) nopt n 1))))
- (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
- (setq nreq (1- nreq))))
- (insert "\n")))
-
- (defun generate-objcode-cells (n)
- "Generate objcode cells for up to N arguments"
- (interactive "p")
- (let ((i 0))
- (while (<= i n)
- (generate-objcode-cells-helper i)
- (setq i (1+ i)))))
-*/
-
-#define STATIC_OBJCODE_TAG \
- SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
-
-static const struct
-{
- SCM_ALIGNED (8) scm_t_uint64 dummy; /* alignment */
- scm_t_cell cells[121 * 2]; /* 11*11 double cells */
-} objcode_cells = {
- 0,
- /* C-u 1 0 M-x generate-objcode-cells RET */
- {
- /* 0 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
-
- /* 1 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 64) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 128) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 192) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 2 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 256) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 320) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 384) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 512) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 3 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 576) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 640) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 704) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 768) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 832) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 896) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 960) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 4 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1024) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1088) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1152) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1216) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1280) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1344) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1408) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1472) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1536) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 5 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1600) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1664) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1728) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1792) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1856) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1920) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1984) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2048) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2112) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2176) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2240) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 6 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2304) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2368) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2432) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2496) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2560) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2624) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2688) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2752) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2816) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2880) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2944) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3008) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3072) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 7 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3136) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3200) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3264) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3328) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3392) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3456) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3520) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3584) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3648) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3712) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3776) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3840) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3904) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3968) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4032) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 8 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4096) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4160) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4224) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4288) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4352) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4416) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4480) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4544) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4608) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4672) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4736) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4800) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4864) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4928) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4992) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5056) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5120) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 9 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5184) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5248) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5312) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5376) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5440) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5504) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5568) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5632) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5696) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5760) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5824) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5888) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5952) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6016) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6080) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6144) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6208) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6272) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6336) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- /* 10 arguments */
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6400) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6464) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6528) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6592) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6656) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6720) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6784) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6848) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6912) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6976) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7040) },
- { SCM_BOOL_F, SCM_PACK (0) },
-
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7104) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7168) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7232) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7296) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7360) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7424) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7488) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7552) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7616) },
- { SCM_BOOL_F, SCM_PACK (0) },
- { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7680) },
- { SCM_BOOL_F, SCM_PACK (0) }
- }
-};
-
-/*
- (defun generate-objcode (n)
- "Generate objcode for N arguments"
- (interactive "p")
- (insert (format " /\* %d arguments *\/\n" n))
- (let ((i (* n n)))
- (while (< i (* (1+ n) (1+ n)))
- (insert (format " SCM_PACK (objcode_cells.cells+%d),\n" (* i 2)))
- (setq i (1+ i)))
- (insert "\n")))
-
- (defun generate-objcodes (n)
- "Generate objcodes for up to N arguments"
- (interactive "p")
- (let ((i 0))
- (while (<= i n)
- (generate-objcode i)
- (setq i (1+ i)))))
-*/
-static const SCM scm_subr_objcode_trampolines[121] = {
- /* C-u 1 0 M-x generate-objcodes RET */
- /* 0 arguments */
- SCM_PACK (objcode_cells.cells+0),
-
- /* 1 arguments */
- SCM_PACK (objcode_cells.cells+2),
- SCM_PACK (objcode_cells.cells+4),
- SCM_PACK (objcode_cells.cells+6),
-
- /* 2 arguments */
- SCM_PACK (objcode_cells.cells+8),
- SCM_PACK (objcode_cells.cells+10),
- SCM_PACK (objcode_cells.cells+12),
- SCM_PACK (objcode_cells.cells+14),
- SCM_PACK (objcode_cells.cells+16),
-
- /* 3 arguments */
- SCM_PACK (objcode_cells.cells+18),
- SCM_PACK (objcode_cells.cells+20),
- SCM_PACK (objcode_cells.cells+22),
- SCM_PACK (objcode_cells.cells+24),
- SCM_PACK (objcode_cells.cells+26),
- SCM_PACK (objcode_cells.cells+28),
- SCM_PACK (objcode_cells.cells+30),
-
- /* 4 arguments */
- SCM_PACK (objcode_cells.cells+32),
- SCM_PACK (objcode_cells.cells+34),
- SCM_PACK (objcode_cells.cells+36),
- SCM_PACK (objcode_cells.cells+38),
- SCM_PACK (objcode_cells.cells+40),
- SCM_PACK (objcode_cells.cells+42),
- SCM_PACK (objcode_cells.cells+44),
- SCM_PACK (objcode_cells.cells+46),
- SCM_PACK (objcode_cells.cells+48),
-
- /* 5 arguments */
- SCM_PACK (objcode_cells.cells+50),
- SCM_PACK (objcode_cells.cells+52),
- SCM_PACK (objcode_cells.cells+54),
- SCM_PACK (objcode_cells.cells+56),
- SCM_PACK (objcode_cells.cells+58),
- SCM_PACK (objcode_cells.cells+60),
- SCM_PACK (objcode_cells.cells+62),
- SCM_PACK (objcode_cells.cells+64),
- SCM_PACK (objcode_cells.cells+66),
- SCM_PACK (objcode_cells.cells+68),
- SCM_PACK (objcode_cells.cells+70),
-
- /* 6 arguments */
- SCM_PACK (objcode_cells.cells+72),
- SCM_PACK (objcode_cells.cells+74),
- SCM_PACK (objcode_cells.cells+76),
- SCM_PACK (objcode_cells.cells+78),
- SCM_PACK (objcode_cells.cells+80),
- SCM_PACK (objcode_cells.cells+82),
- SCM_PACK (objcode_cells.cells+84),
- SCM_PACK (objcode_cells.cells+86),
- SCM_PACK (objcode_cells.cells+88),
- SCM_PACK (objcode_cells.cells+90),
- SCM_PACK (objcode_cells.cells+92),
- SCM_PACK (objcode_cells.cells+94),
- SCM_PACK (objcode_cells.cells+96),
-
- /* 7 arguments */
- SCM_PACK (objcode_cells.cells+98),
- SCM_PACK (objcode_cells.cells+100),
- SCM_PACK (objcode_cells.cells+102),
- SCM_PACK (objcode_cells.cells+104),
- SCM_PACK (objcode_cells.cells+106),
- SCM_PACK (objcode_cells.cells+108),
- SCM_PACK (objcode_cells.cells+110),
- SCM_PACK (objcode_cells.cells+112),
- SCM_PACK (objcode_cells.cells+114),
- SCM_PACK (objcode_cells.cells+116),
- SCM_PACK (objcode_cells.cells+118),
- SCM_PACK (objcode_cells.cells+120),
- SCM_PACK (objcode_cells.cells+122),
- SCM_PACK (objcode_cells.cells+124),
- SCM_PACK (objcode_cells.cells+126),
-
- /* 8 arguments */
- SCM_PACK (objcode_cells.cells+128),
- SCM_PACK (objcode_cells.cells+130),
- SCM_PACK (objcode_cells.cells+132),
- SCM_PACK (objcode_cells.cells+134),
- SCM_PACK (objcode_cells.cells+136),
- SCM_PACK (objcode_cells.cells+138),
- SCM_PACK (objcode_cells.cells+140),
- SCM_PACK (objcode_cells.cells+142),
- SCM_PACK (objcode_cells.cells+144),
- SCM_PACK (objcode_cells.cells+146),
- SCM_PACK (objcode_cells.cells+148),
- SCM_PACK (objcode_cells.cells+150),
- SCM_PACK (objcode_cells.cells+152),
- SCM_PACK (objcode_cells.cells+154),
- SCM_PACK (objcode_cells.cells+156),
- SCM_PACK (objcode_cells.cells+158),
- SCM_PACK (objcode_cells.cells+160),
-
- /* 9 arguments */
- SCM_PACK (objcode_cells.cells+162),
- SCM_PACK (objcode_cells.cells+164),
- SCM_PACK (objcode_cells.cells+166),
- SCM_PACK (objcode_cells.cells+168),
- SCM_PACK (objcode_cells.cells+170),
- SCM_PACK (objcode_cells.cells+172),
- SCM_PACK (objcode_cells.cells+174),
- SCM_PACK (objcode_cells.cells+176),
- SCM_PACK (objcode_cells.cells+178),
- SCM_PACK (objcode_cells.cells+180),
- SCM_PACK (objcode_cells.cells+182),
- SCM_PACK (objcode_cells.cells+184),
- SCM_PACK (objcode_cells.cells+186),
- SCM_PACK (objcode_cells.cells+188),
- SCM_PACK (objcode_cells.cells+190),
- SCM_PACK (objcode_cells.cells+192),
- SCM_PACK (objcode_cells.cells+194),
- SCM_PACK (objcode_cells.cells+196),
- SCM_PACK (objcode_cells.cells+198),
-
- /* 10 arguments */
- SCM_PACK (objcode_cells.cells+200),
- SCM_PACK (objcode_cells.cells+202),
- SCM_PACK (objcode_cells.cells+204),
- SCM_PACK (objcode_cells.cells+206),
- SCM_PACK (objcode_cells.cells+208),
- SCM_PACK (objcode_cells.cells+210),
- SCM_PACK (objcode_cells.cells+212),
- SCM_PACK (objcode_cells.cells+214),
- SCM_PACK (objcode_cells.cells+216),
- SCM_PACK (objcode_cells.cells+218),
- SCM_PACK (objcode_cells.cells+220),
- SCM_PACK (objcode_cells.cells+222),
- SCM_PACK (objcode_cells.cells+224),
- SCM_PACK (objcode_cells.cells+226),
- SCM_PACK (objcode_cells.cells+228),
- SCM_PACK (objcode_cells.cells+230),
- SCM_PACK (objcode_cells.cells+232),
- SCM_PACK (objcode_cells.cells+234),
- SCM_PACK (objcode_cells.cells+236),
- SCM_PACK (objcode_cells.cells+238),
- SCM_PACK (objcode_cells.cells+240)
-};
-
-/* (nargs * nargs) + nopt + rest * (nargs + 1) */
-#define SCM_SUBR_OBJCODE_TRAMPOLINE(nreq,nopt,rest) \
- scm_subr_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
- + nopt + rest * (nreq + nopt + rest + 1)]
-
-SCM
-scm_subr_objcode_trampoline (unsigned int nreq, unsigned int nopt,
- unsigned int rest)
-{
- if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
- scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
-
- return SCM_SUBR_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
-}
-
-static SCM
-create_gsubr (int define, const char *name,
- unsigned int nreq, unsigned int nopt, unsigned int rest,
- SCM (*fcn) (), SCM *generic_loc)
-{
- SCM ret;
- SCM sname;
- SCM table;
- scm_t_bits flags;
-
- /* make objtable */
- sname = scm_from_locale_symbol (name);
- table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
- SCM_SIMPLE_VECTOR_SET (table, 0, scm_from_pointer (fcn, NULL));
- SCM_SIMPLE_VECTOR_SET (table, 1, sname);
- if (generic_loc)
- SCM_SIMPLE_VECTOR_SET (table, 2,
- scm_from_pointer (generic_loc, NULL));
-
- /* make program */
- ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
- table, SCM_BOOL_F);
-
- /* set flags */
- flags = SCM_F_PROGRAM_IS_PRIMITIVE;
- flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
- SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | flags);
-
- /* define, if needed */
- if (define)
- scm_define (sname, ret);
-
- /* et voila. */
- return ret;
-}
-
-SCM
-scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
-{
- return create_gsubr (0, name, req, opt, rst, fcn, NULL);
-}
-
-SCM
-scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
-{
- return create_gsubr (1, name, req, opt, rst, fcn, NULL);
-}
-
-SCM
-scm_c_make_gsubr_with_generic (const char *name,
- int req,
- int opt,
- int rst,
- SCM (*fcn)(),
- SCM *gf)
-{
- return create_gsubr (0, name, req, opt, rst, fcn, gf);
-}
-
-SCM
-scm_c_define_gsubr_with_generic (const char *name,
- int req,
- int opt,
- int rst,
- SCM (*fcn)(),
- SCM *gf)
-{
- return create_gsubr (1, name, req, opt, rst, fcn, gf);
-}
-
-
-#ifdef GSUBR_TEST
-/* A silly example, taking 2 required args, 1 optional, and
- a scm_list of rest args
- */
-SCM
-gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
-{
- scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
- scm_display(req1, scm_cur_outp);
- scm_puts ("\n req2: ", scm_cur_outp);
- scm_display(req2, scm_cur_outp);
- scm_puts ("\n opt: ", scm_cur_outp);
- scm_display(opt, scm_cur_outp);
- scm_puts ("\n rest: ", scm_cur_outp);
- scm_display(rst, scm_cur_outp);
- scm_newline(scm_cur_outp);
- return SCM_UNSPECIFIED;
-}
-#endif
-
-
-void
-scm_init_gsubr()
-{
-#ifdef GSUBR_TEST
- scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
-#endif
-
-#include "libguile/gsubr.x"
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 1995-2001, 2006, 2008-2011, 2013
+ * 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 <stdarg.h>
+
+#include "libguile/_scm.h"
+#include "libguile/gsubr.h"
+#include "libguile/foreign.h"
+#include "libguile/instructions.h"
+#include "libguile/srfi-4.h"
+#include "libguile/programs.h"
+
+#include "libguile/private-options.h"
+\f
+/*
+ * gsubr.c
+ * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
+ * and rest arguments.
+ */
+
+\f
+
+/* OK here goes nothing: we're going to define VM assembly trampolines for
+ invoking subrs. Ready? Right! */
+
+/* There's a maximum of 10 args, so the number of possible combinations is:
+ (REQ-OPT-REST)
+ for 0 args: 1 (000) (1 + 0)
+ for 1 arg: 3 (100, 010, 001) (2 + 1)
+ for 2 args: 5 (200, 110, 020, 101, 011) (3 + 2)
+ for 3 args: 7 (300, 210, 120, 030, 201, 111, 021) (4 + 3)
+ for N args: 2N+1
+
+ and the index at which N args starts:
+ for 0 args: 0
+ for 1 args: 1
+ for 2 args: 4
+ for 3 args: 9
+ for N args: N^2
+
+ One can prove this:
+
+ (1 + 3 + 5 + ... + (2N+1))
+ = ((2N+1)+1)/2 * (N+1)
+ = 2(N+1)/2 * (N+1)
+ = (N+1)^2
+
+ Thus the total sum is 11^2 = 121. Let's just generate all of them as
+ read-only data.
+*/
+
+/* A: req; B: opt; C: rest */
+#define A(nreq) \
+ SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \
+ SCM_PACK_OP_24 (subr_call, 0), \
+ 0, \
+ 0
+
+#define B(nopt) \
+ SCM_PACK_OP_24 (assert_nargs_le, nopt + 1), \
+ SCM_PACK_OP_24 (alloc_frame, nopt + 1), \
+ SCM_PACK_OP_24 (subr_call, 0), \
+ 0
+
+#define C() \
+ SCM_PACK_OP_24 (bind_rest, 1), \
+ SCM_PACK_OP_24 (subr_call, 0), \
+ 0, \
+ 0
+
+#define AB(nreq, nopt) \
+ SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \
+ SCM_PACK_OP_24 (assert_nargs_le, nreq + nopt + 1), \
+ SCM_PACK_OP_24 (alloc_frame, nreq + nopt + 1), \
+ SCM_PACK_OP_24 (subr_call, 0)
+
+#define AC(nreq) \
+ SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \
+ SCM_PACK_OP_24 (bind_rest, nreq + 1), \
+ SCM_PACK_OP_24 (subr_call, 0), \
+ 0
+
+#define BC(nopt) \
+ SCM_PACK_OP_24 (bind_rest, nopt + 1), \
+ SCM_PACK_OP_24 (subr_call, 0), \
+ 0, \
+ 0
+
+#define ABC(nreq, nopt) \
+ SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \
+ SCM_PACK_OP_24 (bind_rest, nreq + nopt + 1), \
+ SCM_PACK_OP_24 (subr_call, 0), \
+ 0
+
+
+/*
+ (defun generate-bytecode (n)
+ "Generate bytecode for N arguments"
+ (interactive "p")
+ (insert (format "/\* %d arguments *\/\n " n))
+ (let ((nreq n))
+ (while (<= 0 nreq)
+ (let ((nopt (- n nreq)))
+ (insert
+ (if (< 0 nreq)
+ (if (< 0 nopt)
+ (format " AB(%d,%d)," nreq nopt)
+ (format " A(%d)," nreq))
+ (if (< 0 nopt)
+ (format " B(%d)," nopt)
+ (format " A(0),"))))
+ (setq nreq (1- nreq))))
+ (insert "\n ")
+ (setq nreq (1- n))
+ (while (<= 0 nreq)
+ (let ((nopt (- n nreq 1)))
+ (insert
+ (if (< 0 nreq)
+ (if (< 0 nopt)
+ (format " ABC(%d,%d)," nreq nopt)
+ (format " AC(%d)," nreq))
+ (if (< 0 nopt)
+ (format " BC(%d)," nopt)
+ (format " C(),"))))
+ (setq nreq (1- nreq))))
+ (insert "\n\n ")))
+
+ (defun generate-bytecodes (n)
+ "Generate bytecodes for up to N arguments"
+ (interactive "p")
+ (let ((i 0))
+ (while (<= i n)
+ (generate-bytecode i)
+ (setq i (1+ i)))))
+*/
+static const scm_t_uint32 subr_stub_code[] = {
+ /* C-u 1 0 M-x generate-bytecodes RET */
+ /* 0 arguments */
+ A(0),
+
+ /* 1 arguments */
+ A(1), B(1),
+ C(),
+
+ /* 2 arguments */
+ A(2), AB(1,1), B(2),
+ AC(1), BC(1),
+
+ /* 3 arguments */
+ A(3), AB(2,1), AB(1,2), B(3),
+ AC(2), ABC(1,1), BC(2),
+
+ /* 4 arguments */
+ A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
+ AC(3), ABC(2,1), ABC(1,2), BC(3),
+
+ /* 5 arguments */
+ A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5),
+ AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4),
+
+ /* 6 arguments */
+ A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6),
+ AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5),
+
+ /* 7 arguments */
+ A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7),
+ AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6),
+
+ /* 8 arguments */
+ A(8), AB(7,1), AB(6,2), AB(5,3), AB(4,4), AB(3,5), AB(2,6), AB(1,7), B(8),
+ AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7),
+
+ /* 9 arguments */
+ A(9), AB(8,1), AB(7,2), AB(6,3), AB(5,4), AB(4,5), AB(3,6), AB(2,7), AB(1,8), B(9),
+ AC(8), ABC(7,1), ABC(6,2), ABC(5,3), ABC(4,4), ABC(3,5), ABC(2,6), ABC(1,7), BC(8),
+
+ /* 10 arguments */
+ A(10), AB(9,1), AB(8,2), AB(7,3), AB(6,4), AB(5,5), AB(4,6), AB(3,7), AB(2,8), AB(1,9), B(10),
+ AC(9), ABC(8,1), ABC(7,2), ABC(6,3), ABC(5,4), ABC(4,5), ABC(3,6), ABC(2,7), ABC(1,8), BC(9),
+};
+
+#undef A
+#undef B
+#undef C
+#undef AB
+#undef AC
+#undef BC
+#undef ABC
+
+/* (nargs * nargs) + nopt + rest * (nargs + 1) */
+#define SUBR_STUB_CODE(nreq,nopt,rest) \
+ &subr_stub_code[((nreq + nopt + rest) * (nreq + nopt + rest) \
+ + nopt + rest * (nreq + nopt + rest + 1)) * 4]
+
+static const scm_t_uint32*
+get_subr_stub_code (unsigned int nreq, unsigned int nopt, unsigned int rest)
+{
+ if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
+ scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
+
+ return SUBR_STUB_CODE (nreq, nopt, rest);
+}
+
+static SCM
+create_subr (int define, const char *name,
+ unsigned int nreq, unsigned int nopt, unsigned int rest,
+ SCM (*fcn) (), SCM *generic_loc)
+{
+ SCM ret, sname;
+ scm_t_bits flags;
+ scm_t_bits nfree = generic_loc ? 3 : 2;
+
+ sname = scm_from_utf8_symbol (name);
+
+ flags = SCM_F_PROGRAM_IS_PRIMITIVE;
+ flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
+
+ ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
+ SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (nreq, nopt, rest));
+ SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, scm_from_pointer (fcn, NULL));
+ SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, sname);
+ if (generic_loc)
+ SCM_PROGRAM_FREE_VARIABLE_SET (ret, 2,
+ scm_from_pointer (generic_loc, NULL));
+
+ if (define)
+ scm_define (sname, ret);
+
+ return ret;
+}
+
+/* Given a program that is a primitive, determine its minimum arity.
+ This is possible because each primitive's code is 4 32-bit words
+ long, and they are laid out contiguously in an ordered pattern. */
+int
+scm_i_primitive_arity (SCM prim, int *req, int *opt, int *rest)
+{
+ const scm_t_uint32 *code = SCM_PROGRAM_CODE (prim);
+ unsigned idx, nargs, base, next;
+
+ if (code < subr_stub_code)
+ return 0;
+ if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32)))
+ return 0;
+
+ idx = (code - subr_stub_code) / 4;
+
+ nargs = -1;
+ next = 0;
+ do
+ {
+ base = next;
+ nargs++;
+ next = (nargs + 1) * (nargs + 1);
+ }
+ while (idx >= next);
+
+ *rest = (next - idx) < (idx - base);
+ *req = *rest ? (next - 1) - idx : (base + nargs) - idx;
+ *opt = *rest ? idx - (next - nargs) : idx - base;
+
+ return 1;
+}
+
+scm_t_uintptr
+scm_i_primitive_call_ip (SCM subr)
+{
+ const scm_t_uint32 *code = SCM_PROGRAM_CODE (subr);
+
+ /* A stub is 4 32-bit words long, or 16 bytes. The call will be one
+ instruction, in either the fourth, third, or second word. Return a
+ byte offset from the entry. */
+ return (scm_t_uintptr)(code + (code[3] ? 3 : code[2] ? 2 : 1));
+}
+
+SCM
+scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
+{
+ return create_subr (0, name, req, opt, rst, fcn, NULL);
+}
+
+SCM
+scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
+{
+ return create_subr (1, name, req, opt, rst, fcn, NULL);
+}
+
+SCM
+scm_c_make_gsubr_with_generic (const char *name,
+ int req,
+ int opt,
+ int rst,
+ SCM (*fcn)(),
+ SCM *gf)
+{
+ return create_subr (0, name, req, opt, rst, fcn, gf);
+}
+
+SCM
+scm_c_define_gsubr_with_generic (const char *name,
+ int req,
+ int opt,
+ int rst,
+ SCM (*fcn)(),
+ SCM *gf)
+{
+ return create_subr (1, name, req, opt, rst, fcn, gf);
+}
+
+void
+scm_init_gsubr()
+{
+#include "libguile/gsubr.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
#define SCM_GSUBR_H
/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2006, 2008, 2009,
- * 2010, 2011 Free Software Foundation, Inc.
+ * 2010, 2011, 2013 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_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
- unsigned int nopt,
- unsigned int rest);
-
-
/* Subrs
*/
#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
#define SCM_SUBRF(x) \
- ((SCM (*) (void)) \
- SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0)))
+ ((SCM (*) (void)) \
+ SCM_POINTER_VALUE (SCM_PROGRAM_FREE_VARIABLE_REF (x, 0)))
-#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1))
+#define SCM_SUBR_NAME(x) (SCM_PROGRAM_FREE_VARIABLE_REF (x, 1))
#define SCM_SUBR_GENERIC(x) \
- ((SCM *) \
- SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2)))
+ ((SCM *) SCM_POINTER_VALUE (SCM_PROGRAM_FREE_VARIABLE_REF (x, 2)))
#define SCM_SET_SUBR_GENERIC(x, g) \
(*SCM_SUBR_GENERIC (x) = (g))
\f
+SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest);
+SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr);
+
SCM_API SCM scm_c_make_gsubr (const char *name,
int req, int opt, int rst, scm_t_subr fcn);
SCM_API SCM scm_c_make_gsubr_with_generic (const char *name,
#include "libguile/validate.h"
#include "libguile/root.h"
#include "libguile/hashtab.h"
-#include "libguile/weaks.h"
#include "libguile/deprecation.h"
#include "libguile/eval.h"
{
t_guardian *g = GUARDIAN_DATA (guardian);
- scm_puts ("#<guardian ", port);
+ scm_puts_unlocked ("#<guardian ", port);
scm_uintprint ((scm_t_bits) g, 16, port);
- scm_puts (" (reachable: ", port);
+ scm_puts_unlocked (" (reachable: ", port);
scm_display (scm_from_uint (g->live), port);
- scm_puts (" unreachable: ", port);
+ scm_puts_unlocked (" unreachable: ", port);
scm_display (scm_length (g->zombies), port);
- scm_puts (")", port);
+ scm_puts_unlocked (")", port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
SCM cell_pool;
SCM obj, guardian_list, proxied_finalizer;
- obj = PTR2SCM (ptr);
- guardian_list = SCM_CDR (PTR2SCM (finalizer_data));
- proxied_finalizer = SCM_CAR (PTR2SCM (finalizer_data));
+ obj = SCM_PACK_POINTER (ptr);
+ guardian_list = SCM_CDR (SCM_PACK_POINTER (finalizer_data));
+ proxied_finalizer = SCM_CAR (SCM_PACK_POINTER (finalizer_data));
#ifdef DEBUG_GUARDIANS
printf ("finalizing guarded %p (%u guardians)\n",
guardian_list = SCM_CDR (guardian_list))
{
SCM zombies;
+ SCM guardian;
t_guardian *g;
- if (SCM_WEAK_PAIR_CAR_DELETED_P (guardian_list))
+ guardian = scm_c_weak_vector_ref (scm_car (guardian_list), 0);
+
+ if (scm_is_false (guardian))
{
/* The guardian itself vanished in the meantime. */
#ifdef DEBUG_GUARDIANS
continue;
}
- g = GUARDIAN_DATA (SCM_CAR (guardian_list));
+ g = GUARDIAN_DATA (guardian);
scm_i_pthread_mutex_lock (&g->mutex);
GC_finalization_proc finalizer, prev_finalizer;
void *finalizer_data, *prev_finalizer_data;
- finalizer = (GC_finalization_proc) SCM2PTR (SCM_CAR (proxied_finalizer));
- finalizer_data = SCM2PTR (SCM_CDR (proxied_finalizer));
+ finalizer = (GC_finalization_proc) SCM_UNPACK_POINTER (SCM_CAR (proxied_finalizer));
+ finalizer_data = SCM_UNPACK_POINTER (SCM_CDR (proxied_finalizer));
if (finalizer == NULL)
abort ();
{
t_guardian *g = GUARDIAN_DATA (guardian);
- if (SCM_NIMP (obj))
+ if (SCM_HEAP_OBJECT_P (obj))
{
/* Register a finalizer and pass a pair as the ``client data''
argument. The pair contains in its car `#f' or a pair describing a
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);
+ /* Note: GUARDIANS_FOR_OBJ holds weak references to guardians so
+ that a guardian can be collected before the objects it guards
+ (see `guardians.test'). */
+ guardians_for_obj = scm_cons (scm_make_weak_vector (SCM_INUM1, 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),
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM_UNPACK_POINTER (obj), finalize_guarded,
+ SCM_UNPACK_POINTER (finalizer_data),
&prev_finalizer, &prev_data);
if (prev_finalizer == finalize_guarded)
if (prev_data == NULL)
abort ();
- prev_finalizer_data = PTR2SCM (prev_data);
+ prev_finalizer_data = SCM_PACK_POINTER (prev_data);
if (!scm_is_pair (prev_finalizer_data))
abort ();
`finalize_guarded ()' has finished. */
SCM proxied_finalizer;
- proxied_finalizer = scm_cons (PTR2SCM (prev_finalizer),
- PTR2SCM (prev_data));
+ proxied_finalizer = scm_cons (SCM_PACK_POINTER (prev_finalizer),
+ SCM_PACK_POINTER (prev_data));
SCM_SETCAR (finalizer_data, proxied_finalizer);
}
scm_init_guardians ()
{
/* We use unordered finalization `a la Java. */
-#ifdef HAVE_GC_SET_JAVA_FINALIZATION
- /* This function was added in 7.2alpha2 (June 2009). */
GC_set_java_finalization (1);
-#else
- /* This symbol is deprecated as of 7.3. */
- GC_java_finalization = 1;
-#endif
tc16_guardian = scm_make_smob_type ("guardian", 0);
#include <winsock2.h>
#endif
-/* Debugger interface (don't change the order of the following lines) */
-#define GDB_TYPE SCM
-#include <libguile/gdb_interface.h>
-GDB_INTERFACE;
-
static void
inner_main (void *closure SCM_UNUSED, int argc, char **argv)
{
/* This is necessary to startup the Winsock API under Win32. */
WSADATA WSAData;
WSAStartup (0x0202, &WSAData);
- GDB_INTERFACE_INIT;
#endif /* __MINGW32__ */
/* module initializations would go here */
static int
should_install_locale (void)
{
- /* If the GUILE_INSTALL_LOCALE environment variable is set to a
- nonzero value, we should install the locale via setlocale(). This
- behavior is off by default for compatibility with previous 2.0.x
- releases. It will be on by default in 2.2. */
- return get_integer_from_environment ("GUILE_INSTALL_LOCALE", 0);
+ /* If the GUILE_INSTALL_LOCALE environment variable is unset,
+ or set to a nonzero value, we should install the locale via
+ setlocale(). */
+ return get_integer_from_environment ("GUILE_INSTALL_LOCALE", 1);
}
int
extern double floor();
#endif
-#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))
-#if SCM_ENABLE_DEPRECATED == 1
+/* This hash function is originally from
+ http://burtleburtle.net/bob/c/lookup3.c by Bob Jenkins, May 2006,
+ Public Domain. No warranty. */
+
+#define rot(x,k) (((x)<<(k)) | ((x)>>(32-(k))))
+#define mix(a,b,c) \
+{ \
+ a -= c; a ^= rot(c, 4); c += b; \
+ b -= a; b ^= rot(a, 6); a += c; \
+ c -= b; c ^= rot(b, 8); b += a; \
+ a -= c; a ^= rot(c,16); c += b; \
+ b -= a; b ^= rot(a,19); a += c; \
+ c -= b; c ^= rot(b, 4); b += a; \
+}
-unsigned long
-scm_string_hash (const unsigned char *str, size_t len)
-{
- /* from suggestion at: */
- /* http://srfi.schemers.org/srfi-13/mail-archive/msg00112.html */
+#define final(a,b,c) \
+{ \
+ c ^= b; c -= rot(b,14); \
+ a ^= c; a -= rot(c,11); \
+ b ^= a; b -= rot(a,25); \
+ c ^= b; c -= rot(b,16); \
+ a ^= c; a -= rot(c,4); \
+ b ^= a; b -= rot(a,14); \
+ c ^= b; c -= rot(b,24); \
+}
- unsigned long h = 0;
- while (len-- > 0)
- h = *str++ + h*37;
- return h;
+#define JENKINS_LOOKUP3_HASHWORD2(k, length, ret) \
+ do { \
+ scm_t_uint32 a, b, c; \
+ \
+ /* Set up the internal state. */ \
+ a = b = c = 0xdeadbeef + ((scm_t_uint32)(length<<2)) + 47; \
+ \
+ /* Handle most of the key. */ \
+ while (length > 3) \
+ { \
+ a += k[0]; \
+ b += k[1]; \
+ c += k[2]; \
+ mix (a, b, c); \
+ length -= 3; \
+ k += 3; \
+ } \
+ \
+ /* Handle the last 3 elements. */ \
+ switch(length) /* All the case statements fall through. */ \
+ { \
+ case 3 : c += k[2]; \
+ case 2 : b += k[1]; \
+ case 1 : a += k[0]; \
+ final (a, b, c); \
+ case 0: /* case 0: nothing left to add */ \
+ break; \
+ } \
+ \
+ if (sizeof (ret) == 8) \
+ ret = (((unsigned long) c) << 32) | b; \
+ else \
+ ret = c; \
+ } while (0)
+
+
+static unsigned long
+narrow_string_hash (const scm_t_uint8 *str, size_t len)
+{
+ unsigned long ret;
+ JENKINS_LOOKUP3_HASHWORD2 (str, len, ret);
+ ret >>= 2; /* Ensure that it fits in a fixnum. */
+ return ret;
}
-#endif
+static unsigned long
+wide_string_hash (const scm_t_wchar *str, size_t len)
+{
+ unsigned long ret;
+ JENKINS_LOOKUP3_HASHWORD2 (str, len, ret);
+ ret >>= 2; /* Ensure that it fits in a fixnum. */
+ return ret;
+}
unsigned long
scm_i_string_hash (SCM str)
{
size_t len = scm_i_string_length (str);
- size_t i = 0;
- unsigned long h = 0;
- const void *data;
-
- data = scm_i_string_data (str);
if (scm_i_is_narrow_string (str))
- {
- const unsigned char *ndata = data;
-
- for (i = 0; i < len; i++)
- h = (unsigned long) ndata[i] + h * 37;
- }
+ return narrow_string_hash ((const scm_t_uint8 *) scm_i_string_chars (str),
+ len);
else
- {
- const scm_t_wchar *wdata = data;
-
- for (i = 0; i < len; i++)
- h = (unsigned long) wdata[i] + h * 37;
- }
-
- scm_remember_upto_here_1 (str);
- return h;
+ return wide_string_hash (scm_i_string_wide_chars (str), len);
}
unsigned long
scm_i_locale_string_hash (const char *str, size_t len)
{
-#ifdef HAVE_WCHAR_H
- mbstate_t state;
- wchar_t c;
- size_t byte_idx = 0, nbytes;
- unsigned long h = 0;
-
- if (len == (size_t) -1)
- len = strlen (str);
-
- while ((nbytes = mbrtowc (&c, str + byte_idx, len - byte_idx, &state)) > 0)
- {
- if (nbytes >= (size_t) -2)
- /* Invalid input string; punt. */
- return scm_i_string_hash (scm_from_locale_stringn (str, len));
-
- h = (unsigned long) c + h * 37;
- byte_idx += nbytes;
- }
-
- return h;
-#else
return scm_i_string_hash (scm_from_locale_stringn (str, len));
-#endif
}
unsigned long
scm_i_latin1_string_hash (const char *str, size_t len)
{
- const scm_t_uint8 *ustr = (const scm_t_uint8 *) str;
- size_t i = 0;
- unsigned long h = 0;
-
if (len == (size_t) -1)
len = strlen (str);
- for (; i < len; i++)
- h = (unsigned long) ustr[i] + h * 37;
-
- return h;
+ return narrow_string_hash ((const scm_t_uint8 *) str, len);
}
+/* A tricky optimization, but probably worth it. */
unsigned long
scm_i_utf8_string_hash (const char *str, size_t len)
{
- const scm_t_uint8 *ustr = (const scm_t_uint8 *) str;
- size_t byte_idx = 0;
- unsigned long h = 0;
-
+ const scm_t_uint8 *end, *ustr = (const scm_t_uint8 *) str;
+ unsigned long ret;
+
+ /* The length of the string in characters. This name corresponds to
+ Jenkins' original name. */
+ size_t length;
+
+ scm_t_uint32 a, b, c, u32;
+
if (len == (size_t) -1)
len = strlen (str);
- while (byte_idx < len)
+ end = ustr + len;
+
+ if (u8_check (ustr, len) != NULL)
+ /* Invalid UTF-8; punt. */
+ return scm_i_string_hash (scm_from_utf8_stringn (str, len));
+
+ length = u8_strnlen (ustr, len);
+
+ /* Set up the internal state. */
+ a = b = c = 0xdeadbeef + ((scm_t_uint32)(length<<2)) + 47;
+
+ /* Handle most of the key. */
+ while (length > 3)
{
- ucs4_t c;
- int nbytes;
-
- nbytes = u8_mbtouc (&c, ustr + byte_idx, len - byte_idx);
- if (nbytes == 0)
- break;
- else if (nbytes < 0)
- /* Bad UTF-8; punt. */
- return scm_i_string_hash (scm_from_utf8_stringn (str, len));
-
- h = (unsigned long) c + h * 37;
- byte_idx += nbytes;
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ a += u32;
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ b += u32;
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ c += u32;
+ mix (a, b, c);
+ length -= 3;
+ }
+
+ /* Handle the last 3 elements's. */
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ a += u32;
+ if (--length)
+ {
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ b += u32;
+ if (--length)
+ {
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ c += u32;
+ }
}
- return h;
+ final (a, b, c);
+
+ if (sizeof (unsigned long) == 8)
+ ret = (((unsigned long) c) << 32) | b;
+ else
+ ret = c;
+
+ ret >>= 2; /* Ensure that it fits in a fixnum. */
+ return ret;
}
+static unsigned long scm_raw_ihashq (scm_t_bits key);
+static unsigned long scm_raw_ihash (SCM obj, size_t depth);
+
+/* Return the hash of struct OBJ. Traverse OBJ's fields to compute the
+ result, unless DEPTH is zero. Assumes that OBJ is a struct. */
+static unsigned long
+scm_i_struct_hash (SCM obj, size_t depth)
+{
+ SCM layout;
+ scm_t_bits *data;
+ size_t struct_size, field_num;
+ unsigned long hash;
+
+ layout = SCM_STRUCT_LAYOUT (obj);
+ struct_size = scm_i_symbol_length (layout) / 2;
+ data = SCM_STRUCT_DATA (obj);
+
+ hash = scm_raw_ihashq (SCM_UNPACK (SCM_STRUCT_VTABLE (obj)));
+ if (depth > 0)
+ for (field_num = 0; field_num < struct_size; field_num++)
+ {
+ int protection;
+
+ protection = scm_i_symbol_ref (layout, field_num * 2 + 1);
+ if (protection != 'h' && protection != 'o')
+ {
+ int type;
+ type = scm_i_symbol_ref (layout, field_num * 2);
+ switch (type)
+ {
+ case 'p':
+ hash ^= scm_raw_ihash (SCM_PACK (data[field_num]),
+ depth / 2);
+ break;
+ case 'u':
+ hash ^= scm_raw_ihashq (data[field_num]);
+ break;
+ default:
+ /* Ignore 's' fields. */;
+ }
+ }
+ }
-/* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
-/* Dirk:FIXME:: scm_hasher could be made static. */
+ /* FIXME: Tail elements should be taken into account. */
+ return hash;
+}
-unsigned long
-scm_hasher(SCM obj, unsigned long n, size_t d)
+/* Thomas Wang's integer hasher, from
+ http://www.cris.com/~Ttwang/tech/inthash.htm. */
+static unsigned long
+scm_raw_ihashq (scm_t_bits key)
{
- switch (SCM_ITAG3 (obj)) {
- case scm_tc3_int_1:
- case scm_tc3_int_2:
- return SCM_I_INUM(obj) % n; /* SCM_INUMP(obj) */
- case scm_tc3_imm24:
- if (SCM_CHARP(obj))
- return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n;
- switch (SCM_UNPACK (obj)) {
- case SCM_EOL_BITS:
- d = 256;
- break;
- case SCM_BOOL_T_BITS:
- d = 257;
- break;
- case SCM_BOOL_F_BITS:
- d = 258;
- break;
- case SCM_EOF_VAL_BITS:
- d = 259;
- break;
- default:
- d = 263; /* perhaps should be error */
+ if (sizeof (key) < 8)
+ {
+ key = (key ^ 61) ^ (key >> 16);
+ key = key + (key << 3);
+ key = key ^ (key >> 4);
+ key = key * 0x27d4eb2d;
+ key = key ^ (key >> 15);
}
- return d % n;
- default:
- return 263 % n; /* perhaps should be error */
- case scm_tc3_cons:
- switch SCM_TYP7(obj) {
- default:
- return 263 % n;
+ else
+ {
+ key = (~key) + (key << 21); // key = (key << 21) - key - 1;
+ key = key ^ (key >> 24);
+ key = (key + (key << 3)) + (key << 8); // key * 265
+ key = key ^ (key >> 14);
+ key = (key + (key << 2)) + (key << 4); // key * 21
+ key = key ^ (key >> 28);
+ key = key + (key << 31);
+ }
+ key >>= 2; /* Ensure that it fits in a fixnum. */
+ return key;
+}
+
+/* `depth' is used to limit recursion. */
+static unsigned long
+scm_raw_ihash (SCM obj, size_t depth)
+{
+ if (SCM_IMP (obj))
+ return scm_raw_ihashq (SCM_UNPACK (obj));
+
+ switch (SCM_TYP7(obj))
+ {
+ /* FIXME: do better for structs, variables, ... Also the hashes
+ are currently associative, which ain't the right thing. */
case scm_tc7_smob:
- return 263 % n;
+ return scm_raw_ihashq (SCM_TYP16 (obj));
case scm_tc7_number:
- switch SCM_TYP16 (obj) {
- case scm_tc16_big:
- return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
- case scm_tc16_real:
- {
- double r = SCM_REAL_VALUE (obj);
- if (floor (r) == r && !isinf (r) && !isnan (r))
- {
- obj = scm_inexact_to_exact (obj);
- return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
- }
- }
- /* Fall through */
- case scm_tc16_complex:
- case scm_tc16_fraction:
- obj = scm_number_to_string (obj, scm_from_int (10));
- /* Fall through */
- }
- /* Fall through */
+ if (scm_is_integer (obj))
+ {
+ SCM n = SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM);
+ if (scm_is_inexact (obj))
+ obj = scm_inexact_to_exact (obj);
+ return scm_raw_ihashq (scm_to_ulong (scm_modulo (obj, n)));
+ }
+ else
+ return scm_i_string_hash (scm_number_to_string (obj, scm_from_int (10)));
case scm_tc7_string:
- {
- unsigned long hash =
- scm_i_string_hash (obj) % n;
- return hash;
- }
+ return scm_i_string_hash (obj);
case scm_tc7_symbol:
- return scm_i_symbol_hash (obj) % n;
+ return scm_i_symbol_hash (obj);
case scm_tc7_pointer:
- {
- /* Pointer objects are typically used to store addresses of heap
- objects. On most platforms, these are at least 3-byte
- aligned (on x86_64-*-gnu, `malloc' returns 4-byte aligned
- addresses), so get rid of the least significant bits. */
- scm_t_uintptr significant_bits;
-
- significant_bits = (scm_t_uintptr) SCM_POINTER_VALUE (obj) >> 4UL;
- return (size_t) significant_bits % n;
- }
- case scm_tcs_struct:
- return scm_i_struct_hash (obj, n, d);
+ return scm_raw_ihashq ((scm_t_uintptr) SCM_POINTER_VALUE (obj));
case scm_tc7_wvect:
case scm_tc7_vector:
- if (d > 0)
- {
- size_t len, i, d2;
- unsigned long h;
-
- len = SCM_SIMPLE_VECTOR_LENGTH (obj);
- if (len > 5)
- {
- i = d / 2;
- h = 1;
- d2 = SCM_MIN (2, d - 1);
- }
- else
- {
- i = len;
- h = n - 1;
- d2 = len > 0 ? (d - 1) / len : 0;
- }
-
+ {
+ size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
+ size_t i = depth / 2;
+ unsigned long h = scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
+ if (len)
while (i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
- h = ((h << 8) + (scm_hasher (elt, n, d2))) % n;
- }
- return h;
- }
- else
- return 1;
+ h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
+ return h;
+ }
case scm_tcs_cons_imcar:
case scm_tcs_cons_nimcar:
- if (d) return (scm_hasher (SCM_CAR (obj), n, d/2)
- + scm_hasher (SCM_CDR (obj), n, d/2)) % n;
- else return 1;
- case scm_tc7_port:
- return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
- case scm_tc7_program:
- return 262 % n;
+ if (depth)
+ return (scm_raw_ihash (SCM_CAR (obj), depth / 2)
+ ^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
+ else
+ return scm_raw_ihashq (scm_tc3_cons);
+ case scm_tcs_struct:
+ return scm_i_struct_hash (obj, depth);
+ default:
+ return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
}
- }
}
\f
-
unsigned long
scm_ihashq (SCM obj, unsigned long n)
{
- return (SCM_UNPACK (obj) >> 1) % n;
+ return scm_raw_ihashq (SCM_UNPACK (obj)) % n;
}
unsigned long
scm_ihashv (SCM obj, unsigned long n)
{
- if (SCM_CHARP(obj))
- return ((unsigned long) (scm_c_downcase (SCM_CHAR (obj)))) % n; /* downcase!?!! */
-
if (SCM_NUMP(obj))
- return (unsigned long) scm_hasher(obj, n, 10);
+ return scm_raw_ihash (obj, 10) % n;
else
- return SCM_UNPACK (obj) % n;
+ return scm_raw_ihashq (SCM_UNPACK (obj)) % n;
}
unsigned long
scm_ihash (SCM obj, unsigned long n)
{
- return (unsigned long) scm_hasher (obj, n, 10);
+ return (unsigned long) scm_raw_ihash (obj, 10) % n;
}
SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
\f
-#if SCM_ENABLE_DEPRECATED == 1
-
-/* Deprecated in 2.0.12. */
-SCM_DEPRECATED unsigned long scm_string_hash (const unsigned char *str,
- size_t len);
-
-#endif
-
SCM_INTERNAL unsigned long scm_i_locale_string_hash (const char *str,
size_t len);
SCM_INTERNAL unsigned long scm_i_latin1_string_hash (const char *str,
size_t len);
SCM_INTERNAL unsigned long scm_i_string_hash (SCM str);
-SCM_API unsigned long scm_hasher (SCM obj, unsigned long n, size_t d);
SCM_API unsigned long scm_ihashq (SCM obj, unsigned long n);
SCM_API SCM scm_hashq (SCM obj, SCM n);
SCM_API unsigned long scm_ihashv (SCM obj, unsigned long n);
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
- * 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2008, 2009, 2010, 2011, 2012, 2013 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 implementation stores the upper and lower number of items which
* trigger a resize in the hashtable object.
*
- * Weak hash tables use weak pairs in the bucket lists rather than
- * normal pairs.
- *
* Possible hash table sizes (primes) are stored in the array
* hashtable_size.
*/
static char *s_hashtable = "hashtable";
-
-\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);
- alist = SCM_CDR (alist))
- {
- SCM pair = SCM_CAR (alist);
-
- if (SCM_WEAK_PAIR_DELETED_P (pair))
- {
- /* Remove from ALIST weak pair PAIR whose car/cdr has been
- nullified by the GC. */
- if (scm_is_null (prev))
- result = SCM_CDR (alist);
- else
- SCM_SETCDR (prev, SCM_CDR (alist));
-
- (*removed_items)++;
-
- /* Leave PREV unchanged. */
- }
- else
- prev = alist;
- }
-
- return result;
-}
-
-static void
-vacuum_weak_hash_table (SCM table)
-{
- SCM buckets = SCM_HASHTABLE_VECTOR (table);
- unsigned long k = SCM_SIMPLE_VECTOR_LENGTH (buckets);
- size_t len = SCM_HASHTABLE_N_ITEMS (table);
-
- while (k--)
- {
- size_t removed;
- SCM alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
- alist = scm_fixup_weak_alist (alist, &removed);
- assert (removed <= len);
- len -= removed;
- SCM_SIMPLE_VECTOR_SET (buckets, k, alist);
- }
-
- SCM_SET_HASHTABLE_N_ITEMS (table, len);
-}
-
-
-/* Packed arguments for `do_weak_bucket_fixup'. */
-struct t_fixup_args
-{
- SCM bucket;
- SCM *bucket_copy;
- size_t removed_items;
-};
-
-static void *
-do_weak_bucket_fixup (void *data)
-{
- struct t_fixup_args *args;
- SCM pair, *copy;
-
- args = (struct t_fixup_args *) data;
-
- args->bucket = scm_fixup_weak_alist (args->bucket, &args->removed_items);
-
- for (pair = args->bucket, copy = args->bucket_copy;
- scm_is_pair (pair);
- pair = SCM_CDR (pair), copy += 2)
- {
- /* At this point, all weak pairs have been removed. */
- assert (!SCM_WEAK_PAIR_DELETED_P (SCM_CAR (pair)));
-
- /* Copy the key and value. */
- copy[0] = SCM_CAAR (pair);
- copy[1] = SCM_CDAR (pair);
- }
-
- 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;
- SCM bucket, *strong_refs;
- struct t_fixup_args args;
-
- bucket = SCM_SIMPLE_VECTOR_REF (buckets, bucket_index);
-
- /* Prepare STRONG_REFS as an array large enough to hold all the keys
- and values in BUCKET. */
- strong_refs = alloca (scm_ilength (bucket) * 2 * sizeof (SCM));
-
- args.bucket = bucket;
- args.bucket_copy = strong_refs;
-
- /* Fixup BUCKET. 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.)
-
- The `do_weak_bucket_fixup' call populates STRONG_REFS with a copy
- of BUCKET's entries after it's been fixed up. Thus, all the
- entries kept in BUCKET are still reachable when ASSOC sees
- them. */
- GC_call_with_alloc_lock (do_weak_bucket_fixup, &args);
-
- bucket = args.bucket;
- SCM_SIMPLE_VECTOR_SET (buckets, bucket_index, bucket);
-
- result = assoc (object, bucket, closure);
-
- /* If we got a result, it should not have NULL fields. */
- if (scm_is_pair (result) && SCM_WEAK_PAIR_DELETED_P (result))
- abort ();
-
- scm_remember_upto_here_1 (strong_refs);
-
- if (args.removed_items > 0)
- {
- /* 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);
-
- if (remaining < SCM_HASHTABLE_LOWER (table))
- scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc");
- }
-
- return result;
-}
-
-
-/* Packed arguments for `weak_bucket_assoc_by_hash'. */
-struct assoc_by_hash_data
-{
- SCM alist;
- SCM ret;
- scm_t_hash_predicate_fn predicate;
- void *closure;
-};
-
-/* See scm_hash_fn_get_handle_by_hash below. */
-static void*
-weak_bucket_assoc_by_hash (void *args)
-{
- struct assoc_by_hash_data *data = args;
- SCM alist = data->alist;
-
- for (; scm_is_pair (alist); alist = SCM_CDR (alist))
- {
- SCM pair = SCM_CAR (alist);
-
- if (!SCM_WEAK_PAIR_DELETED_P (pair)
- && data->predicate (SCM_CAR (pair), data->closure))
- {
- data->ret = pair;
- break;
- }
- }
- return args;
-}
-
-
-\f
-static SCM
-make_hash_table (int flags, unsigned long k, const char *func_name)
+make_hash_table (unsigned long k, const char *func_name)
{
SCM vector;
scm_t_hashtable *t;
++i;
n = hashtable_size[i];
- /* 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->n_items = 0;
t->lower = 0;
t->upper = 9 * n / 10;
- t->flags = flags;
- t->hash_fn = NULL;
/* FIXME: we just need two words of storage, not three */
return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
if (i >= HASHTABLE_SIZE_N)
/* don't rehash */
return;
-
- /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
- is not needed since CLOSURE can not be guaranteed to be valid
- after this function returns.
- */
- if (closure == NULL)
- SCM_HASHTABLE (table)->hash_fn = hash_fn;
}
SCM_HASHTABLE (table)->size_index = i;
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
- this by first installing the new, empty bucket vector. Then we
- remove the elements from the old bucket vector and insert them
- into the new one.
- */
-
SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
SCM_SET_HASHTABLE_N_ITEMS (table, 0);
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));
void
scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<", port);
- if (SCM_HASHTABLE_WEAK_KEY_P (exp))
- scm_puts ("weak-key-", port);
- else if (SCM_HASHTABLE_WEAK_VALUE_P (exp))
- scm_puts ("weak-value-", port);
- else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp))
- scm_puts ("doubly-weak-", port);
- scm_puts ("hash-table ", port);
+ scm_puts_unlocked ("#<hash-table ", port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
scm_putc (' ', port);
scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
- scm_putc ('/', port);
+ scm_putc_unlocked ('/', port);
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
10, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
SCM
scm_c_make_hash_table (unsigned long k)
{
- return make_hash_table (0, k, "scm_c_make_hash_table");
+ return make_hash_table (k, "scm_c_make_hash_table");
}
SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
"Make a new abstract hash table object with minimum number of buckets @var{n}\n")
#define FUNC_NAME s_scm_make_hash_table
{
- if (SCM_UNBNDP (n))
- return make_hash_table (0, 0, FUNC_NAME);
- else
- return make_hash_table (0, scm_to_ulong (n), FUNC_NAME);
-}
-#undef FUNC_NAME
-
-/* The before-gc C hook only runs if GC_set_start_callback is available,
- so if not, fall back on a finalizer-based implementation. */
-static int
-weak_gc_callback (void **weak)
-{
- void *val = weak[0];
- void (*callback) (SCM) = weak[1];
-
- if (!val)
- return 0;
-
- callback (PTR2SCM (val));
-
- return 1;
-}
-
-#ifdef HAVE_GC_SET_START_CALLBACK
-static void*
-weak_gc_hook (void *hook_data, void *fn_data, void *data)
-{
- if (!weak_gc_callback (fn_data))
- scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data);
-
- return NULL;
-}
-#else
-static void
-weak_gc_finalizer (void *ptr, void *data)
-{
- if (weak_gc_callback (ptr))
- GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_finalizer, data, NULL, NULL);
-}
-#endif
-
-static void
-scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
-{
- void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2);
-
- weak[0] = SCM2PTR (obj);
- weak[1] = (void*)callback;
- GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj));
-
-#ifdef HAVE_GC_SET_START_CALLBACK
- scm_c_hook_add (&scm_before_gc_c_hook, weak_gc_hook, weak, 0);
-#else
- GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_finalizer, NULL, NULL, NULL);
-#endif
-}
-
-SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
- (SCM n),
- "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
- "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
- "Return a weak hash table with @var{size} buckets.\n"
- "\n"
- "You can modify weak hash tables in exactly the same way you\n"
- "would modify regular hash tables. (@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_weak_key_hash_table
-{
- SCM ret;
-
- if (SCM_UNBNDP (n))
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
- else
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR,
- scm_to_ulong (n), FUNC_NAME);
-
- scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
-
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0,
- (SCM n),
- "Return a hash table with weak values with @var{size} buckets.\n"
- "(@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_weak_value_hash_table
-{
- SCM ret;
-
- if (SCM_UNBNDP (n))
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
- else
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
- scm_to_ulong (n), FUNC_NAME);
-
- scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
-
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 0, 1, 0,
- (SCM n),
- "Return a hash table with weak keys and values with @var{size}\n"
- "buckets. (@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_doubly_weak_hash_table
-{
- SCM ret;
-
- if (SCM_UNBNDP (n))
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
- 0, FUNC_NAME);
- else
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
- scm_to_ulong (n), FUNC_NAME);
-
- scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
-
- return ret;
+ return make_hash_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), FUNC_NAME);
}
#undef FUNC_NAME
+#define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x)))
SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is an abstract hash table object.")
#define FUNC_NAME s_scm_hash_table_p
{
- return scm_from_bool (SCM_HASHTABLE_P (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
- (SCM obj),
- "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
- "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
- "Return @code{#t} if @var{obj} is the specified weak hash\n"
- "table. Note that a doubly weak hash table is neither a weak key\n"
- "nor a weak value hash table.")
-#define FUNC_NAME s_scm_weak_key_hash_table_p
-{
- return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_KEY_P (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a weak value hash table.")
-#define FUNC_NAME s_scm_weak_value_hash_table_p
-{
- return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_VALUE_P (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a doubly weak hash table.")
-#define FUNC_NAME s_scm_doubly_weak_hash_table_p
-{
- return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj));
+ return scm_from_bool (SCM_HASHTABLE_P (obj) || SCM_WEAK_TABLE_P (obj));
}
#undef FUNC_NAME
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- if (SCM_HASHTABLE_WEAK_P (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
-
-
-/* This procedure implements three optimizations, with respect to the
- raw get_handle():
-
- 1. For weak tables, it's assumed that calling the predicate in the
- allocation lock is safe. In practice this means that the predicate
- cannot call arbitrary scheme functions.
-
- 2. We don't check for overflow / underflow and rehash.
-
- 3. We don't actually have to allocate a key -- instead we get the
- hash value directly. This is useful for, for example, looking up
- strings in the symbol table.
- */
-SCM
-scm_hash_fn_get_handle_by_hash (SCM table, unsigned long raw_hash,
- scm_t_hash_predicate_fn predicate_fn,
- void *closure)
-#define FUNC_NAME "scm_hash_fn_ref_by_hash"
-{
- unsigned long k;
- SCM buckets, alist, h = SCM_BOOL_F;
-
- SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
- buckets = SCM_HASHTABLE_VECTOR (table);
-
- if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
- return SCM_BOOL_F;
-
- k = raw_hash % SCM_SIMPLE_VECTOR_LENGTH (buckets);
- alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
-
- if (SCM_HASHTABLE_WEAK_P (table))
- {
- struct assoc_by_hash_data args;
-
- args.alist = alist;
- args.ret = SCM_BOOL_F;
- args.predicate = predicate_fn;
- args.closure = closure;
- GC_call_with_alloc_lock (weak_bucket_assoc_by_hash, &args);
- h = args.ret;
- }
- else
- for (; scm_is_pair (alist); alist = SCM_CDR (alist))
- {
- SCM pair = SCM_CAR (alist);
- if (predicate_fn (SCM_CAR (pair), closure))
- {
- h = pair;
- break;
- }
- }
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
return h;
}
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
- if (SCM_HASHTABLE_WEAK_P (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);
+ it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
if (scm_is_pair (it))
return it;
scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
else
{
- /* When this is a weak hashtable, running the GC can change it.
- Thus, we must allocate the new cells first and can only then
- access BUCKETS. Also, we need to fetch the bucket vector
- again since the hashtable might have been rehashed. This
- necessitates a new hash value as well.
- */
SCM handle, new_bucket;
- if (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);
-
+ handle = scm_cons (obj, init);
new_bucket = scm_cons (handle, SCM_EOL);
if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
return dflt;
}
-struct weak_cdr_data
-{
- SCM pair;
- SCM cdr;
-};
-
-static void*
-get_weak_cdr (void *data)
-{
- struct weak_cdr_data *d = data;
-
- if (SCM_WEAK_PAIR_CDR_DELETED_P (d->pair))
- d->cdr = SCM_BOOL_F;
- else
- d->cdr = SCM_CDR (d->pair);
-
- return NULL;
-}
-
-static SCM
-weak_pair_cdr (SCM x)
-{
- struct weak_cdr_data data;
-
- data.pair = x;
- GC_call_with_alloc_lock (get_weak_cdr, &data);
-
- return data.cdr;
-}
-
SCM
scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
hash_fn, assoc_fn, closure);
if (!scm_is_eq (SCM_CDR (pair), val))
- {
- if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table)))
- {
- /* If the former value was on the heap, we need to unregister
- the weak link. */
- SCM prev = weak_pair_cdr (pair);
-
- SCM_SETCDR (pair, val);
-
- if (SCM_NIMP (prev) && !SCM_NIMP (val))
- GC_unregister_disappearing_link ((void **) SCM_CDRLOC (pair));
- else
- SCM_I_REGISTER_DISAPPEARING_LINK ((void **) SCM_CDRLOC (pair),
- SCM2PTR (val));
- }
- else
- SCM_SETCDR (pair, val);
- }
+ SCM_SETCDR (pair, val);
return val;
}
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- if (SCM_HASHTABLE_WEAK_P (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);
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
if (scm_is_true (h))
{
"Remove all items from @var{table} (without triggering a resize).")
#define FUNC_NAME s_scm_hash_clear_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_weak_table_clear_x (table);
+ return SCM_UNSPECIFIED;
+ }
+
SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
"Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_get_handle
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashq_create_handle_x
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_refq (table, key, dflt);
+
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
"store @var{val} there. Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_set_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_weak_table_putq_x (table, key, val);
+ return val;
+ }
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
"@var{table}. Uses @code{eq?} for equality tests.")
#define FUNC_NAME s_scm_hashq_remove_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_weak_table_remq_x (table, key);
+ /* This return value is for historical compatibility with
+ hash-remove!, which returns either the "handle" corresponding
+ to the entry, or #f. Since weak tables don't have handles, we
+ have to return #f. */
+ return SCM_BOOL_F;
+ }
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
"Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_get_handle
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashv_create_handle_x
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
#undef FUNC_NAME
+static int
+assv_predicate (SCM k, SCM v, void *closure)
+{
+ return scm_is_true (scm_eqv_p (k, SCM_PACK_POINTER (closure)));
+}
+
SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_c_weak_table_ref (table, scm_ihashv (key, -1),
+ assv_predicate,
+ (void *) SCM_UNPACK (key), dflt);
+
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
"store @var{value} there. Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_set_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_put_x (table, scm_ihashv (key, -1),
+ assv_predicate, (void *) SCM_UNPACK (key),
+ key, val);
+ return val;
+ }
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
"@var{table}. Uses @code{eqv?} for equality tests.")
#define FUNC_NAME s_scm_hashv_remove_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_remove_x (table, scm_ihashv (key, -1),
+ assv_predicate, (void *) SCM_UNPACK (key));
+ /* See note in hashq-remove!. */
+ return SCM_BOOL_F;
+ }
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
"Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_get_handle
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hash_create_handle_x
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
#undef FUNC_NAME
+static int
+assoc_predicate (SCM k, SCM v, void *closure)
+{
+ return scm_is_true (scm_equal_p (k, SCM_PACK_POINTER (closure)));
+}
+
SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_c_weak_table_ref (table, scm_ihash (key, -1),
+ assoc_predicate,
+ (void *) SCM_UNPACK (key), dflt);
+
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
"testing.")
#define FUNC_NAME s_scm_hash_set_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_put_x (table, scm_ihash (key, -1),
+ assoc_predicate, (void *) SCM_UNPACK (key),
+ key, val);
+ return val;
+ }
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
"@var{table}. Uses @code{equal?} for equality tests.")
#define FUNC_NAME s_scm_hash_remove_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_remove_x (table, scm_ihash (key, -1),
+ assoc_predicate, (void *) SCM_UNPACK (key));
+ /* See note in hashq-remove!. */
+ return SCM_BOOL_F;
+ }
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
{
SCM hash;
SCM assoc;
+ SCM key;
} scm_t_ihashx_closure;
-
-
static unsigned long
scm_ihashx (SCM obj, unsigned long n, void *arg)
{
return scm_to_ulong (answer);
}
-
-
static SCM
scm_sloppy_assx (SCM obj, SCM alist, void *arg)
{
return scm_call_2 (closure->assoc, obj, alist);
}
+static int
+assx_predicate (SCM k, SCM v, void *closure)
+{
+ scm_t_ihashx_closure *c = (scm_t_ihashx_closure *) closure;
+
+ /* FIXME: The hashx interface is crazy. Hash tables have nothing to
+ do with alists in principle. Instead of getting an assoc proc,
+ hashx functions should use an equality predicate. Perhaps we can
+ change this before 2.2, but until then, add a terrible, terrible
+ hack. */
+
+ return scm_is_true (scm_call_2 (c->assoc, c->key, scm_acons (k, v, SCM_EOL)));
+}
+
SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
(SCM hash, SCM assoc, SCM table, SCM key),
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
-
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+ closure.key = key;
return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
-
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+ closure.key = key;
return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
scm_sloppy_assx, (void *)&closure);
dflt = SCM_BOOL_F;
closure.hash = hash;
closure.assoc = assoc;
+ closure.key = key;
+
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
+ scm_from_ulong (-1)));
+ return scm_c_weak_table_ref (table, h, assx_predicate, &closure, dflt);
+ }
+
return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
(void *)&closure);
}
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+ closure.key = key;
+
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
+ scm_from_ulong (-1)));
+ scm_c_weak_table_put_x (table, h, assx_predicate, &closure, key, val);
+ return val;
+ }
+
return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
(void *)&closure);
}
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+ closure.key = obj;
+
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ unsigned long h = scm_to_ulong (scm_call_2 (hash, obj,
+ scm_from_ulong (-1)));
+ scm_c_weak_table_remove_x (table, h, assx_predicate, &closure);
+ /* See note in hashq-remove!. */
+ return SCM_BOOL_F;
+ }
+
return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
}
#define FUNC_NAME s_scm_hash_fold
{
SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_fold (proc, init, table);
+
SCM_VALIDATE_HASHTABLE (3, table);
return scm_internal_hash_fold ((scm_t_hash_fold_fn) scm_call_3,
(void *) SCM_UNPACK (proc), init, table);
#define FUNC_NAME s_scm_hash_for_each
{
SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_weak_table_for_each (proc, table);
+ return SCM_UNSPECIFIED;
+ }
+
SCM_VALIDATE_HASHTABLE (2, table);
scm_internal_hash_for_each_handle (for_each_proc,
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
SCM_VALIDATE_HASHTABLE (2, table);
- if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
(void *) SCM_UNPACK (proc),
table);
#define FUNC_NAME s_scm_hash_map_to_list
{
SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_map_to_list (proc, table);
+
SCM_VALIDATE_HASHTABLE (2, table);
return scm_internal_hash_fold (map_proc,
(void *) SCM_UNPACK (proc),
long i, n;
SCM buckets, result = init;
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_c_weak_table_fold (fn, closure, init, table);
+
SCM_VALIDATE_HASHTABLE (0, table);
buckets = SCM_HASHTABLE_VECTOR (table);
ls = SCM_CDR (ls))
{
handle = SCM_CAR (ls);
-
- if (SCM_HASHTABLE_WEAK_P (table) && SCM_WEAK_PAIR_DELETED_P (handle))
- /* Don't try to unlink this weak pair, as we're not within
- the allocation lock. Instead rely on
- vacuum_weak_hash_table to do its job. */
- continue;
- else
- result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
+ result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
}
}
handle = SCM_CAR (ls);
if (!scm_is_pair (handle))
SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
- if (!SCM_HASHTABLE_WEAK_P (table)
- || !SCM_WEAK_PAIR_DELETED_P (handle))
- fn (closure, handle);
+ fn (closure, handle);
ls = SCM_CDR (ls);
}
}
#ifndef SCM_HASHTAB_H
#define SCM_HASHTAB_H
-/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include "libguile/__scm.h"
-#include "weaks.h"
-
\f
-#define SCM_HASHTABLEF_WEAK_CAR SCM_WVECTF_WEAK_KEY
-#define SCM_HASHTABLEF_WEAK_CDR SCM_WVECTF_WEAK_VALUE
-
-#define SCM_HASHTABLE_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_hashtable)
+#define SCM_HASHTABLE_P(x) (SCM_HAS_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_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_HASHTABLE_WEAK_VALUE_P(x) \
- (SCM_HASHTABLE_FLAGS (x) & SCM_HASHTABLEF_WEAK_CDR)
-#define SCM_HASHTABLE_DOUBLY_WEAK_P(x) \
- ((SCM_HASHTABLE_FLAGS (x) \
- & (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR)) \
- == (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR))
-#define SCM_HASHTABLE_WEAK_P(x) SCM_HASHTABLE_FLAGS (x)
#define SCM_HASHTABLE_N_ITEMS(x) (SCM_HASHTABLE (x)->n_items)
#define SCM_SET_HASHTABLE_N_ITEMS(x, n) (SCM_HASHTABLE (x)->n_items = n)
#define SCM_HASHTABLE_INCREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)++)
some equality predicate. */
typedef SCM (*scm_t_assoc_fn) (SCM obj, SCM alist, void *closure);
-/* Function that returns true if the given object is the one we are
- looking for, for scm_hash_fn_ref_by_hash. */
-typedef int (*scm_t_hash_predicate_fn) (SCM obj, 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);
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 lower; /* when to shrink */
unsigned long upper; /* when to grow */
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_make_weak_key_hash_table (SCM k);
-SCM_API SCM scm_make_weak_value_hash_table (SCM k);
-SCM_API SCM scm_make_doubly_weak_hash_table (SCM k);
SCM_API SCM scm_hash_table_p (SCM h);
-SCM_API SCM scm_weak_key_hash_table_p (SCM h);
-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, scm_t_hash_fn hash_fn,
void *closure, const char *func_name);
scm_t_hash_fn hash_fn,
scm_t_assoc_fn assoc_fn,
void *closure);
-SCM_INTERNAL
-SCM scm_hash_fn_get_handle_by_hash (SCM table, unsigned long raw_hash,
- scm_t_hash_predicate_fn predicate_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,
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
hook_print (SCM hook, SCM port, scm_print_state *pstate)
{
SCM ls, name;
- scm_puts ("#<hook ", port);
+ scm_puts_unlocked ("#<hook ", port);
scm_intprint (SCM_HOOK_ARITY (hook), 10, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_UNPACK (hook), 16, port);
ls = SCM_HOOK_PROCEDURES (hook);
- while (SCM_NIMP (ls))
+ while (scm_is_pair (ls))
{
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
name = scm_procedure_name (SCM_CAR (ls));
if (scm_is_true (name))
scm_iprin1 (name, port, pstate);
else
- scm_putc ('?', port);
+ scm_putc_unlocked ('?', port);
ls = SCM_CDR (ls);
}
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
scm_c_run_hook (SCM hook, SCM args)
{
SCM procs = SCM_HOOK_PROCEDURES (hook);
- while (SCM_NIMP (procs))
+ while (scm_is_pair (procs))
{
scm_apply_0 (SCM_CAR (procs), args);
procs = SCM_CDR (procs);
scm_c_run_hookn (SCM hook, SCM *argv, size_t nargs)
{
SCM procs = SCM_HOOK_PROCEDURES (hook);
- while (SCM_NIMP (procs))
+ while (scm_is_pair (procs))
{
scm_call_n (SCM_CAR (procs), argv, nargs);
procs = SCM_CDR (procs);
#include "libguile/fports.h"
#include "libguile/frames.h"
#include "libguile/gc.h"
-#include "libguile/gdbint.h"
#include "libguile/generalized-arrays.h"
#include "libguile/generalized-vectors.h"
#include "libguile/goops.h"
#include "libguile/modules.h"
#include "libguile/net_db.h"
#include "libguile/numbers.h"
-#include "libguile/objcodes.h"
+#include "libguile/loader.h"
#include "libguile/objprop.h"
#include "libguile/options.h"
#include "libguile/pairs.h"
#include "libguile/version.h"
#include "libguile/vm.h"
#include "libguile/vports.h"
-#include "libguile/weaks.h"
#include "libguile/guardians.h"
#include "libguile/extensions.h"
#include "libguile/uniform.h"
{
stream_body_data *body_data = (stream_body_data *) data;
SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode, SCM_BOOL_F);
-
- SCM_REVEALED (port) = 1;
+ scm_set_port_revealed_x (port, SCM_INUM1);
return port;
}
(scm_standard_stream_to_port (1, isatty (1) ? "w0" : "w"));
scm_set_current_error_port
(scm_standard_stream_to_port (2, isatty (2) ? "w0" : "w"));
+ scm_set_current_warning_port (scm_current_error_port ());
}
scm_storage_prehistory ();
scm_threads_prehistory (base); /* requires storage_prehistory */
- scm_weaks_prehistory (); /* requires storage_prehistory */
+ scm_weak_table_prehistory (); /* requires storage_prehistory */
#ifdef GUILE_DEBUG_MALLOC
scm_debug_malloc_prehistory ();
#endif
- scm_symbols_prehistory (); /* requires weaks_prehistory */
+ scm_symbols_prehistory (); /* requires weak_table_prehistory */
scm_modules_prehistory ();
scm_init_array_handle ();
scm_bootstrap_bytevectors (); /* Requires array-handle */
scm_bootstrap_instructions ();
- scm_bootstrap_objcodes ();
+ scm_bootstrap_loader ();
scm_bootstrap_programs ();
scm_bootstrap_vm ();
scm_register_r6rs_ports ();
scm_init_stime ();
scm_init_gc (); /* Requires hooks and `get_internal_run_time' */
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 (); /* Requires smob_prehistory */
scm_init_throw (); /* Requires smob_prehistory */
scm_init_trees ();
scm_init_version ();
- scm_init_weaks ();
+ scm_init_weak_set ();
+ scm_init_weak_table ();
+ scm_init_weak_vectors ();
scm_init_guardians (); /* requires smob_prehistory */
scm_init_vports ();
scm_init_standard_ports (); /* Requires fports */
scm_initialized_p = 1;
-#ifdef STACK_CHECKING
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-#endif
scm_init_rdelim ();
scm_init_rw ();
/* Capture the dynamic state after loading boot-9, so that new threads end up
in the guile-user module. */
scm_init_threads_default_dynamic_state ();
+
+ /* Finally, cause finalizers to run in a separate thread. */
+ scm_init_finalizer_thread ();
}
/*
-/* Copyright (C) 2001, 2006, 2008, 2011, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 2008, 2011, 2012, 2013 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/array-handle.h"
#include "libguile/gc.h"
#include "libguile/smob.h"
+#include "libguile/pairs.h"
+#include "libguile/ports.h"
-/* classes: h_files */
-
-#ifndef SCM_INLINE_H
-#define SCM_INLINE_H
-
-/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010,
- * 2011, 2013 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
- */
-
-/* This file is for inline functions. On platforms that don't support
- inlining functions, they are turned into ordinary functions. On
- platforms that do support inline functions, the definitions are still
- compiled into the library, once, in inline.c. */
-
-#include <stdio.h>
-#include <string.h>
-
-#include "libguile/__scm.h"
-
-#include "libguile/pairs.h"
-#include "libguile/gc.h"
-#include "libguile/threads.h"
-#include "libguile/array-handle.h"
-#include "libguile/ports.h"
-#include "libguile/numbers.h"
-#include "libguile/error.h"
-
-
-SCM_INLINE int scm_is_pair (SCM x);
-SCM_INLINE int scm_is_string (SCM x);
-
-SCM_INLINE int scm_get_byte_or_eof (SCM port);
-SCM_INLINE int scm_peek_byte_or_eof (SCM port);
-SCM_INLINE void scm_putc (char c, SCM port);
-SCM_INLINE void scm_puts (const char *str_data, SCM port);
-
-
-SCM_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
-SCM_INLINE SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
- scm_t_bits ccr, scm_t_bits cdr);
-SCM_INLINE SCM scm_words (scm_t_bits car, scm_t_uint16 n_words);
-
-#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
-/* Either inlining, or being included from inline.c. */
-
-SCM_INLINE_IMPLEMENTATION int
-scm_is_pair (SCM x)
-{
- /* The following "workaround_for_gcc_295" avoids bad code generated by
- i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least).
-
- Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
- the fetch of the tag word from x is done before confirming it's a
- non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a
- immediate. This was seen to afflict scm_srfi1_split_at and something
- deep in the bowels of ceval(). In both cases segvs resulted from
- deferencing a random immediate value. srfi-1.test exposes the problem
- through a short list, the immediate being SCM_EOL in that case.
- Something in syntax.test exposed the ceval() problem.
-
- Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the
- problem, without even using that variable. The "w=w" is just to
- prevent a warning about it being unused.
- */
-#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95
- volatile SCM workaround_for_gcc_295 = x;
- workaround_for_gcc_295 = workaround_for_gcc_295;
-#endif
-
- return SCM_I_CONSP (x);
-}
-
-SCM_INLINE_IMPLEMENTATION int
-scm_is_string (SCM x)
-{
- return SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string);
-}
-
-/* Port I/O. */
-
-SCM_INLINE_IMPLEMENTATION int
-scm_get_byte_or_eof (SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random)
- && pt->read_pos < pt->read_end))
- return *pt->read_pos++;
- else
- return scm_slow_get_byte_or_eof (port);
-}
-
-/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */
-SCM_INLINE_IMPLEMENTATION int
-scm_peek_byte_or_eof (SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random)
- && pt->read_pos < pt->read_end))
- return *pt->read_pos;
- else
- return scm_slow_peek_byte_or_eof (port);
-}
-
-SCM_INLINE_IMPLEMENTATION void
-scm_putc (char c, SCM port)
-{
- SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
- scm_lfwrite (&c, 1, port);
-}
-
-SCM_INLINE_IMPLEMENTATION void
-scm_puts (const char *s, SCM port)
-{
- SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
- scm_lfwrite (s, strlen (s), port);
-}
-
-
-#endif
-#endif
+/* classes: h_files */
+
+#ifndef SCM_INLINE_H
+#define SCM_INLINE_H
+
+/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010,
+ * 2011, 2012, 2013 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
+ */
+
+/* This file is for inline functions. On platforms that don't support
+ inlining functions, they are turned into ordinary functions. On
+ platforms that do support inline functions, the definitions are still
+ compiled into the library, once, in inline.c. */
+
+#include "libguile/__scm.h"
+
+#include "libguile/gc.h"
+#include "libguile/threads.h"
+#include "libguile/array-handle.h"
+#include "libguile/ports.h"
+#include "libguile/numbers.h"
+#include "libguile/error.h"
+
+
+SCM_INLINE int scm_is_string (SCM x);
+
+SCM_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
+SCM_INLINE SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr);
+SCM_INLINE SCM scm_words (scm_t_bits car, scm_t_uint32 n_words);
+
+#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
+/* Either inlining, or being included from inline.c. */
+
+SCM_INLINE_IMPLEMENTATION int
+scm_is_string (SCM x)
+{
+ return SCM_HAS_TYP7 (x, scm_tc7_string);
+}
+
+#endif
+#endif
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public 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 <string.h>
-
-#include "_scm.h"
-#include "threads.h"
-#include "instructions.h"
-
-
-struct scm_instruction {
- enum scm_opcode opcode; /* opcode */
- const char *name; /* instruction name */
- signed char len; /* Instruction length. This may be -1 for
- the loader (see the `VM_LOADER'
- macro). */
- signed char npop; /* The number of values popped. This may be
- -1 for insns like `call' which can take
- any number of arguments. */
- char npush; /* the number of values pushed */
- SCM symname; /* filled in later */
-};
-
-#define SCM_VALIDATE_LOOKUP_INSTRUCTION(pos, var, cvar) \
- do { \
- cvar = scm_lookup_instruction_by_name (var); \
- SCM_ASSERT_TYPE (cvar, var, pos, FUNC_NAME, "INSTRUCTION_P"); \
- } while (0)
-
-
-static scm_i_pthread_mutex_t itable_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
-
-static struct scm_instruction*
-fetch_instruction_table ()
-{
- static struct scm_instruction *table = NULL;
-
- scm_i_pthread_mutex_lock (&itable_lock);
- if (SCM_UNLIKELY (!table))
- {
- size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_instruction);
- int i;
- table = malloc (bytes);
- memset (table, 0, bytes);
-#define VM_INSTRUCTION_TO_TABLE 1
-#include <libguile/vm-expand.h>
-#include <libguile/vm-i-system.i>
-#include <libguile/vm-i-scheme.i>
-#include <libguile/vm-i-loader.i>
-#undef VM_INSTRUCTION_TO_TABLE
- for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
- {
- table[i].opcode = i;
- if (table[i].name)
- table[i].symname = scm_from_locale_symbol (table[i].name);
- else
- table[i].symname = SCM_BOOL_F;
- }
- }
- scm_i_pthread_mutex_unlock (&itable_lock);
-
- return table;
-}
-
-static SCM instructions_by_name;
-
-static void
-init_instructions_by_name (void)
-{
- struct scm_instruction *table = fetch_instruction_table ();
- 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));
-}
-
-static struct scm_instruction *
-scm_lookup_instruction_by_name (SCM name)
-{
- static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
- struct scm_instruction *table = fetch_instruction_table ();
- SCM op;
-
- scm_i_pthread_once (&once, init_instructions_by_name);
-
- op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
- if (SCM_I_INUMP (op))
- return &table[SCM_I_INUM (op)];
-
- return NULL;
-}
-
-
-/* Scheme interface */
-
-SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
- (void),
- "")
-#define FUNC_NAME s_scm_instruction_list
-{
- SCM list = SCM_EOL;
- int i;
- struct scm_instruction *ip = fetch_instruction_table ();
- for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
- if (ip[i].name)
- list = scm_cons (ip[i].symname, list);
- return scm_reverse_x (list, SCM_EOL);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
- (SCM obj),
- "")
-#define FUNC_NAME s_scm_instruction_p
-{
- return scm_from_bool (scm_lookup_instruction_by_name (obj) != NULL);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
- (SCM inst),
- "")
-#define FUNC_NAME s_scm_instruction_length
-{
- struct scm_instruction *ip;
- SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
- return SCM_I_MAKINUM (ip->len);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
- (SCM inst),
- "")
-#define FUNC_NAME s_scm_instruction_pops
-{
- struct scm_instruction *ip;
- SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
- return SCM_I_MAKINUM (ip->npop);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
- (SCM inst),
- "")
-#define FUNC_NAME s_scm_instruction_pushes
-{
- struct scm_instruction *ip;
- SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
- return SCM_I_MAKINUM (ip->npush);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
- (SCM inst),
- "")
-#define FUNC_NAME s_scm_instruction_to_opcode
-{
- struct scm_instruction *ip;
- SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
- return SCM_I_MAKINUM (ip->opcode);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
- (SCM op),
- "")
-#define FUNC_NAME s_scm_opcode_to_instruction
-{
- scm_t_signed_bits opcode;
- SCM ret = SCM_BOOL_F;
-
- SCM_MAKE_VALIDATE (1, op, I_INUMP);
- opcode = SCM_I_INUM (op);
-
- if (opcode >= 0 && opcode < SCM_VM_NUM_INSTRUCTIONS)
- ret = fetch_instruction_table ()[opcode].symname;
-
- if (scm_is_false (ret))
- scm_wrong_type_arg_msg (FUNC_NAME, 1, op, "INSTRUCTION_P");
-
- return ret;
-}
-#undef FUNC_NAME
-
-void
-scm_bootstrap_instructions (void)
-{
- scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
- "scm_init_instructions",
- (scm_t_extension_init_func)scm_init_instructions,
- NULL);
-}
-
-void
-scm_init_instructions (void)
-{
-#ifndef SCM_MAGIC_SNARFER
-#include "libguile/instructions.x"
-#endif
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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 <string.h>
+
+#include "_scm.h"
+#include "threads.h"
+#include "instructions.h"
+
+
+SCM_SYMBOL (sym_left_arrow, "<-");
+SCM_SYMBOL (sym_bang, "!");
+
+
+#define OP_HAS_ARITY (1U << 0)
+
+#define FOR_EACH_INSTRUCTION_WORD_TYPE(M) \
+ M(X32) \
+ M(U8_X24) \
+ M(U8_U24) \
+ M(U8_L24) \
+ M(U8_U8_I16) \
+ M(U8_U8_U8_U8) \
+ M(U8_U12_U12) \
+ M(U32) /* Unsigned. */ \
+ M(I32) /* Immediate. */ \
+ M(A32) /* Immediate, high bits. */ \
+ M(B32) /* Immediate, low bits. */ \
+ M(N32) /* Non-immediate. */ \
+ M(S32) /* Scheme value (indirected). */ \
+ M(L32) /* Label. */ \
+ M(LO32) /* Label with offset. */ \
+ M(X8_U24) \
+ M(X8_U12_U12) \
+ M(X8_L24) \
+ M(B1_X7_L24) \
+ M(B1_U7_L24) \
+ M(B1_X7_U24) \
+ M(B1_X31)
+
+#define TYPE_WIDTH 5
+
+enum word_type
+ {
+#define ENUM(type) type,
+ FOR_EACH_INSTRUCTION_WORD_TYPE (ENUM)
+#undef ENUM
+ };
+
+static SCM word_type_symbols[] =
+ {
+#define FALSE(type) SCM_BOOL_F,
+ FOR_EACH_INSTRUCTION_WORD_TYPE (FALSE)
+#undef FALSE
+ };
+
+#define OP(n,type) ((type) << (n*TYPE_WIDTH))
+
+/* The VM_DEFINE_OP macro uses a CPP-based DSL to describe what kinds of
+ arguments each instruction takes. This piece of code is the only
+ bit that actually interprets that language. These macro definitions
+ encode the operand types into bits in a 32-bit integer.
+
+ (instruction-list) parses those encoded values into lists of symbols,
+ one for each 32-bit word that the operator takes. This list is used
+ by Scheme to generate assemblers and disassemblers for the
+ instructions. */
+
+#define NOP SCM_T_UINT32_MAX
+#define OP1(type0) \
+ (OP (0, type0))
+#define OP2(type0, type1) \
+ (OP (0, type0) | OP (1, type1))
+#define OP3(type0, type1, type2) \
+ (OP (0, type0) | OP (1, type1) | OP (2, type2))
+#define OP4(type0, type1, type2, type3) \
+ (OP (0, type0) | OP (1, type1) | OP (2, type2) | OP (3, type3))
+#define OP5(type0, type1, type2, type3, type4) \
+ (OP (0, type0) | OP (1, type1) | OP (2, type2) | OP (3, type3) | OP (4, type4))
+
+#define OP_DST (1 << (TYPE_WIDTH * 5))
+
+#define WORD_TYPE(n, word) \
+ (((word) >> ((n) * TYPE_WIDTH)) & ((1 << TYPE_WIDTH) - 1))
+
+/* Scheme interface */
+
+static SCM
+parse_instruction (scm_t_uint8 opcode, const char *name, scm_t_uint32 meta)
+{
+ SCM tail = SCM_EOL;
+ int len;
+
+ /* Format: (name opcode word0 word1 ...) */
+
+ if (WORD_TYPE (4, meta))
+ len = 5;
+ else if (WORD_TYPE (3, meta))
+ len = 4;
+ else if (WORD_TYPE (2, meta))
+ len = 3;
+ else if (WORD_TYPE (1, meta))
+ len = 2;
+ else if (WORD_TYPE (0, meta))
+ len = 1;
+ else
+ abort ();
+
+ switch (len)
+ {
+ case 5:
+ tail = scm_cons (word_type_symbols[WORD_TYPE (4, meta)], tail);
+ case 4:
+ tail = scm_cons (word_type_symbols[WORD_TYPE (3, meta)], tail);
+ case 3:
+ tail = scm_cons (word_type_symbols[WORD_TYPE (2, meta)], tail);
+ case 2:
+ tail = scm_cons (word_type_symbols[WORD_TYPE (1, meta)], tail);
+ case 1:
+ tail = scm_cons (word_type_symbols[WORD_TYPE (0, meta)], tail);
+ default:
+ tail = scm_cons ((meta & OP_DST) ? sym_left_arrow : sym_bang, tail);
+ tail = scm_cons (scm_from_int (opcode), tail);
+ tail = scm_cons (scm_from_utf8_symbol (name), tail);
+ return tail;
+ }
+}
+
+SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_instruction_list
+{
+ SCM list = SCM_EOL;
+
+#define INIT(opcode, tag, name, meta) \
+ if (name) list = scm_cons (parse_instruction (opcode, name, meta), list);
+ FOR_EACH_VM_OPERATION (INIT);
+#undef INIT
+
+ return scm_reverse_x (list, SCM_EOL);
+}
+#undef FUNC_NAME
+
+void
+scm_bootstrap_instructions (void)
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_instructions",
+ (scm_t_extension_init_func)scm_init_instructions,
+ NULL);
+}
+
+void
+scm_init_instructions (void)
+{
+#define INIT(type) \
+ word_type_symbols[type] = scm_from_utf8_symbol (#type);
+ FOR_EACH_INSTRUCTION_WORD_TYPE (INIT)
+#undef INIT
+
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/instructions.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2012, 2013 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_INSTRUCTIONS_H_
#include <libguile.h>
+#include <libguile/vm-operations.h>
+
+#ifdef BUILDING_LIBGUILE
+
+enum scm_opcode
+ {
+#define ENUM(opcode, tag, name, meta) scm_op_##tag = opcode,
+ FOR_EACH_VM_OPERATION(ENUM)
+#undef ENUM
+ };
+
+#define SCM_PACK_OP_24(op,arg) (scm_op_##op | (arg) << 8)
+#define SCM_PACK_OP_8_8_8(op,a,b,c) SCM_PACK_OP_24 (op, (a) | ((b) << 8) | ((c) << 16))
+#define SCM_PACK_OP_8_16(op,a,b) SCM_PACK_OP_24 (op, (a) | (b) << 8)
+#define SCM_PACK_OP_16_8(op,a,b) SCM_PACK_OP_24 (op, (a) | (b) << 16)
+#define SCM_PACK_OP_12_12(op,a,b) SCM_PACK_OP_24 (op, (a) | (b) << 12)
+#define SCM_PACK_OP_ARG_8_24(a,b) ((a) | ((b) << 8))
#define SCM_VM_NUM_INSTRUCTIONS (1<<8)
#define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1)
-enum scm_opcode {
-#define VM_INSTRUCTION_TO_OPCODE 1
-#include <libguile/vm-expand.h>
-#include <libguile/vm-i-system.i>
-#include <libguile/vm-i-scheme.i>
-#include <libguile/vm-i-loader.i>
-#undef VM_INSTRUCTION_TO_OPCODE
-};
-
-SCM_API SCM scm_instruction_list (void);
-SCM_API SCM scm_instruction_p (SCM obj);
-SCM_API SCM scm_instruction_length (SCM inst);
-SCM_API SCM scm_instruction_pops (SCM inst);
-SCM_API SCM scm_instruction_pushes (SCM inst);
-SCM_API SCM scm_instruction_to_opcode (SCM inst);
-SCM_API SCM scm_opcode_to_instruction (SCM op);
+#endif /* BUILDING_LIBGUILE */
+
+SCM_INTERNAL SCM scm_instruction_list (void);
SCM_INTERNAL void scm_bootstrap_instructions (void);
SCM_INTERNAL void scm_init_instructions (void);
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006,
- * 2014 Free Software Foundation, Inc.
+ * 2011, 2014 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_port *pt = SCM_PTAB_ENTRY (new);
scm_t_port *old_pt = SCM_PTAB_ENTRY (old);
- scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)];
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (new);
/* must flush to old fdes. */
if (pt->rw_active == SCM_PORT_WRITE)
ptob->flush (new);
else if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (new);
+ scm_end_input_unlocked (new);
ans = dup2 (oldfd, newfd);
if (ans == -1)
SCM_SYSERROR;
#undef FUNC_NAME
static SCM
-get_matching_port (void *closure, SCM port, SCM val, SCM result)
+get_matching_port (void *closure, SCM port, SCM result)
{
int fd = * (int *) closure;
scm_t_port *entry = SCM_PTAB_ENTRY (port);
SCM result = SCM_EOL;
int int_fd = scm_to_int (fd);
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
- result = scm_internal_hash_fold (get_matching_port,
- (void*) &int_fd, result,
- scm_i_port_weak_hash);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ result = scm_c_weak_set_fold (get_matching_port,
+ (void*) &int_fd, result,
+ scm_i_port_weak_set);
return result;
}
#undef FUNC_NAME
#ifndef SCM_ISELECT_H
#define SCM_ISELECT_H
-/* Copyright (C) 1997,1998,2000,2001, 2002, 2006, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1997,1998,2000,2001, 2002, 2006,
+ * 2013 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
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
- * 2006, 2008, 2009, 2013 Free Software Foundation, Inc.
+ * 2006, 2008, 2009, 2011, 2013, 2015 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 keyword_obarray;
-scm_t_bits scm_tc16_keyword;
-
-#define KEYWORDP(X) (SCM_SMOB_PREDICATE (scm_tc16_keyword, (X)))
-#define KEYWORDSYM(X) (SCM_SMOB_OBJECT (X))
-
-static int
-keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
-{
- scm_puts ("#:", port);
- scm_display (KEYWORDSYM (exp), port);
- return 1;
-}
+#define SCM_KEYWORDP(x) (SCM_HAS_TYP7 (x, scm_tc7_keyword))
+#define SCM_KEYWORD_SYMBOL(x) (SCM_CELL_OBJECT_1 (x))
SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0,
(SCM obj),
"@code{#f}.")
#define FUNC_NAME s_scm_keyword_p
{
- return scm_from_bool (KEYWORDP (obj));
+ return scm_from_bool (SCM_KEYWORDP (obj));
}
#undef FUNC_NAME
SCM_ASSERT_TYPE (scm_is_symbol (symbol), symbol, 0, NULL, "symbol");
SCM_CRITICAL_SECTION_START;
- /* njrev: NEWSMOB and hashq_set_x can raise errors */
+ /* Note: `scm_cell' and `scm_hashq_set_x' can raise an out-of-memory
+ error. */
keyword = scm_hashq_ref (keyword_obarray, symbol, SCM_BOOL_F);
if (scm_is_false (keyword))
{
- SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol));
+ keyword = scm_cell (scm_tc7_keyword, SCM_UNPACK (symbol));
scm_hashq_set_x (keyword_obarray, symbol, keyword);
}
SCM_CRITICAL_SECTION_END;
"Return the symbol with the same name as @var{keyword}.")
#define FUNC_NAME s_scm_keyword_to_symbol
{
- scm_assert_smob_type (scm_tc16_keyword, keyword);
- return KEYWORDSYM (keyword);
+ SCM_VALIDATE_KEYWORD (1, keyword);
+ return SCM_KEYWORD_SYMBOL (keyword);
}
#undef FUNC_NAME
int
scm_is_keyword (SCM val)
{
- return KEYWORDP (val);
+ return SCM_KEYWORDP (val);
}
SCM
}
}
-/* njrev: critical sections reviewed so far up to here */
void
scm_init_keywords ()
{
- scm_tc16_keyword = scm_make_smob_type ("keyword", 0);
- scm_set_smob_print (scm_tc16_keyword, keyword_print);
-
keyword_obarray = scm_c_make_hash_table (0);
#include "libguile/keywords.x"
}
#ifndef SCM_KEYWORDS_H
#define SCM_KEYWORDS_H
-/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008, 2015 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_API scm_t_bits scm_tc16_keyword;
-
-\f
-
SCM_API SCM scm_keyword_p (SCM obj);
SCM_API SCM scm_symbol_to_keyword (SCM symbol);
SCM_API SCM scm_keyword_to_symbol (SCM keyword);
(link (dereference-word backend (- fp (* 4 %word-size)))))
(values ra mvra link caller)))
-;;; libguile-2.0-gdb.scm ends here
+;;; libguile-2.2-gdb.scm ends here
while (! SCM_UNBNDP (elt))
{
#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (SCM_NIMP (elt))
+ if (SCM_HEAP_OBJECT_P (elt))
SCM_VALIDATE_CELL(elt, 0);
#endif
*pos = scm_cons (elt, SCM_EOL);
#include <stdio.h>
#include "libguile/_scm.h"
-#include "libguile/private-gc.h" /* scm_getenv_int */
#include "libguile/libpath.h"
#include "libguile/fports.h"
#include "libguile/read.h"
else
{
compiled_is_newer = 0;
- scm_puts (";;; note: source file ", scm_current_error_port ());
+ scm_puts_unlocked (";;; note: source file ", scm_current_error_port ());
scm_display (full_filename, scm_current_error_port ());
- scm_puts ("\n;;; newer than compiled ", scm_current_error_port ());
+ scm_puts_unlocked ("\n;;; newer than compiled ", scm_current_error_port ());
scm_display (compiled_filename, scm_current_error_port ());
- scm_puts ("\n", scm_current_error_port ());
+ scm_puts_unlocked ("\n", scm_current_error_port ());
}
return compiled_is_newer;
static SCM
do_try_auto_compile (void *data)
{
- SCM source = PTR2SCM (data);
+ SCM source = SCM_PACK_POINTER (data);
SCM comp_mod, compile_file;
- scm_puts (";;; compiling ", scm_current_error_port ());
+ scm_puts_unlocked (";;; compiling ", scm_current_error_port ());
scm_display (source, scm_current_error_port ());
scm_newline (scm_current_error_port ());
/* Assume `*current-warning-prefix*' has an appropriate value. */
res = scm_call_n (scm_variable_ref (compile_file), args, 5);
- scm_puts (";;; compiled ", scm_current_error_port ());
+ scm_puts_unlocked (";;; compiled ", scm_current_error_port ());
scm_display (res, scm_current_error_port ());
scm_newline (scm_current_error_port ());
return res;
}
else
{
- scm_puts (";;; it seems ", scm_current_error_port ());
+ scm_puts_unlocked (";;; it seems ", scm_current_error_port ());
scm_display (source, scm_current_error_port ());
- scm_puts ("\n;;; is part of the compiler; skipping auto-compilation\n",
+ scm_puts_unlocked ("\n;;; is part of the compiler; skipping auto-compilation\n",
scm_current_error_port ());
return SCM_BOOL_F;
}
static SCM
auto_compile_catch_handler (void *data, SCM tag, SCM throw_args)
{
- SCM source = PTR2SCM (data);
+ SCM source = SCM_PACK_POINTER (data);
SCM oport, lines;
oport = scm_open_output_string ();
scm_print_exception (oport, SCM_BOOL_F, tag, throw_args);
- scm_puts (";;; WARNING: compilation of ", scm_current_warning_port ());
+ scm_puts_unlocked (";;; WARNING: compilation of ", scm_current_warning_port ());
scm_display (source, scm_current_warning_port ());
- scm_puts (" failed:\n", scm_current_warning_port ());
+ scm_puts_unlocked (" failed:\n", scm_current_warning_port ());
lines = scm_string_split (scm_get_output_string (oport),
SCM_MAKE_CHAR ('\n'));
for (; scm_is_pair (lines); lines = scm_cdr (lines))
if (scm_c_string_length (scm_car (lines)))
{
- scm_puts (";;; ", scm_current_warning_port ());
+ scm_puts_unlocked (";;; ", scm_current_warning_port ());
scm_display (scm_car (lines), scm_current_warning_port ());
scm_newline (scm_current_warning_port ());
}
if (!message_shown)
{
- scm_puts (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n"
+ scm_puts_unlocked (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n"
";;; or pass the --no-auto-compile argument to disable.\n",
scm_current_warning_port ());
message_shown = 1;
scm_sys_warn_auto_compilation_enabled ();
return scm_c_catch (SCM_BOOL_T,
do_try_auto_compile,
- SCM2PTR (source),
+ SCM_UNPACK_POINTER (source),
auto_compile_catch_handler,
- SCM2PTR (source),
+ SCM_UNPACK_POINTER (source),
NULL, NULL);
}
if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback,
&stat_source, &stat_compiled))
{
- scm_puts (";;; found fresh local cache at ", scm_current_warning_port ());
+ scm_puts_unlocked (";;; found fresh local cache at ", scm_current_warning_port ());
scm_display (fallback, scm_current_warning_port ());
scm_newline (scm_current_warning_port ());
return scm_load_compiled_with_vm (fallback);
for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++)
{
- SCM key = scm_from_locale_symbol (info[i].name);
+ SCM key = scm_from_utf8_symbol (info[i].name);
SCM val = scm_from_locale_string (info[i].value);
*loc = scm_acons (key, val, *loc);
}
--- /dev/null
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012
+ * 2013, 2014 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 <string.h>
+#include <fcntl.h>
+#include <unistd.h>
+
+#ifdef HAVE_SYS_MMAN_H
+#include <sys/mman.h>
+#endif
+
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <assert.h>
+#include <alignof.h>
+#include <byteswap.h>
+#include <verify.h>
+
+#include <full-read.h>
+
+#include "_scm.h"
+#include "elf.h"
+#include "programs.h"
+#include "loader.h"
+
+/* This file contains the loader for Guile's on-disk format: ELF with
+ some custom tags in the dynamic segment. */
+
+#if SIZEOF_SCM_T_BITS == 4
+#define Elf_Half Elf32_Half
+#define Elf_Word Elf32_Word
+#define Elf_Ehdr Elf32_Ehdr
+#define ELFCLASS ELFCLASS32
+#define Elf_Phdr Elf32_Phdr
+#define Elf_Dyn Elf32_Dyn
+#elif SIZEOF_SCM_T_BITS == 8
+#define Elf_Half Elf64_Half
+#define Elf_Word Elf64_Word
+#define Elf_Ehdr Elf64_Ehdr
+#define ELFCLASS ELFCLASS64
+#define Elf_Phdr Elf64_Phdr
+#define Elf_Dyn Elf64_Dyn
+#else
+#error
+#endif
+
+#define DT_LOGUILE 0x37146000 /* Start of Guile-specific */
+#define DT_GUILE_GC_ROOT 0x37146000 /* Offset of GC roots */
+#define DT_GUILE_GC_ROOT_SZ 0x37146001 /* Size in machine words of GC
+ roots */
+#define DT_GUILE_ENTRY 0x37146002 /* Address of entry thunk */
+#define DT_GUILE_VM_VERSION 0x37146003 /* Bytecode version */
+#define DT_GUILE_FRAME_MAPS 0x37146004 /* Frame maps */
+#define DT_HIGUILE 0x37146fff /* End of Guile-specific */
+
+#ifdef WORDS_BIGENDIAN
+#define ELFDATA ELFDATA2MSB
+#else
+#define ELFDATA ELFDATA2LSB
+#endif
+
+static void register_elf (char *data, size_t len, char *frame_maps);
+
+enum bytecode_kind
+ {
+ BYTECODE_KIND_NONE,
+ BYTECODE_KIND_GUILE_2_2
+ };
+
+static SCM
+pointer_to_procedure (enum bytecode_kind bytecode_kind, char *ptr)
+{
+ switch (bytecode_kind)
+ {
+ case BYTECODE_KIND_GUILE_2_2:
+ {
+ return scm_i_make_program ((scm_t_uint32 *) ptr);
+ }
+ case BYTECODE_KIND_NONE:
+ default:
+ abort ();
+ }
+}
+
+static const char*
+check_elf_header (const Elf_Ehdr *header)
+{
+ if (!(header->e_ident[EI_MAG0] == ELFMAG0
+ && header->e_ident[EI_MAG1] == ELFMAG1
+ && header->e_ident[EI_MAG2] == ELFMAG2
+ && header->e_ident[EI_MAG3] == ELFMAG3))
+ return "not an ELF file";
+
+ if (header->e_ident[EI_CLASS] != ELFCLASS)
+ return "ELF file does not have native word size";
+
+ if (header->e_ident[EI_DATA] != ELFDATA)
+ return "ELF file does not have native byte order";
+
+ if (header->e_ident[EI_VERSION] != EV_CURRENT)
+ return "bad ELF version";
+
+ if (header->e_ident[EI_OSABI] != ELFOSABI_STANDALONE)
+ return "unexpected OS ABI";
+
+ if (header->e_ident[EI_ABIVERSION] != 0)
+ return "unexpected ABI version";
+
+ if (header->e_type != ET_DYN)
+ return "unexpected ELF type";
+
+ if (header->e_machine != EM_NONE)
+ return "unexpected machine";
+
+ if (header->e_version != EV_CURRENT)
+ return "unexpected ELF version";
+
+ if (header->e_ehsize != sizeof *header)
+ return "unexpected header size";
+
+ if (header->e_phentsize != sizeof (Elf_Phdr))
+ return "unexpected program header size";
+
+ return NULL;
+}
+
+#define IS_ALIGNED(offset, alignment) \
+ (!((offset) & ((alignment) - 1)))
+#define ALIGN(offset, alignment) \
+ ((offset + (alignment - 1)) & ~(alignment - 1))
+
+/* Return the alignment required by the ELF at DATA, of LEN bytes. */
+static size_t
+elf_alignment (const char *data, size_t len)
+{
+ Elf_Ehdr *header;
+ int i;
+ size_t alignment = 8;
+
+ if (len < sizeof(Elf_Ehdr))
+ return alignment;
+ header = (Elf_Ehdr *) data;
+ if (header->e_phoff + header->e_phnum * header->e_phentsize >= len)
+ return alignment;
+ for (i = 0; i < header->e_phnum; i++)
+ {
+ Elf_Phdr *phdr;
+ const char *phdr_addr = data + header->e_phoff + i * header->e_phentsize;
+
+ if (!IS_ALIGNED ((scm_t_uintptr) phdr_addr, alignof_type (Elf_Phdr)))
+ return alignment;
+ phdr = (Elf_Phdr *) phdr_addr;
+
+ if (phdr->p_align & (phdr->p_align - 1))
+ return alignment;
+
+ if (phdr->p_align > alignment)
+ alignment = phdr->p_align;
+ }
+
+ return alignment;
+}
+
+/* This function leaks the memory that it allocates. */
+static char*
+alloc_aligned (size_t len, unsigned alignment)
+{
+ char *ret;
+
+ if (alignment == 8)
+ {
+ /* FIXME: Assert that we actually have an 8-byte-aligned malloc. */
+ ret = malloc (len);
+ }
+#if defined(HAVE_SYS_MMAN_H) && defined(MMAP_ANONYMOUS)
+ else if (alignment == SCM_PAGE_SIZE)
+ {
+ ret = mmap (NULL, len, PROT_READ | PROT_WRITE, -1, 0);
+ if (ret == MAP_FAILED)
+ SCM_SYSERROR;
+ }
+#endif
+ else
+ {
+ if (len + alignment < len)
+ abort ();
+
+ ret = malloc (len + alignment - 1);
+ if (!ret)
+ abort ();
+ ret = (char *) ALIGN ((scm_t_uintptr) ret, alignment);
+ }
+
+ return ret;
+}
+
+static char*
+copy_and_align_elf_data (const char *data, size_t len)
+{
+ size_t alignment;
+ char *copy;
+
+ alignment = elf_alignment (data, len);
+ copy = alloc_aligned (len, alignment);
+ memcpy(copy, data, len);
+
+ return copy;
+}
+
+#ifdef HAVE_SYS_MMAN_H
+static int
+segment_flags_to_prot (Elf_Word flags)
+{
+ int prot = 0;
+
+ if (flags & PF_X)
+ prot |= PROT_EXEC;
+ if (flags & PF_W)
+ prot |= PROT_WRITE;
+ if (flags & PF_R)
+ prot |= PROT_READ;
+
+ return prot;
+}
+#endif
+
+static char*
+process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
+ SCM *init_out, SCM *entry_out, char **frame_maps_out)
+{
+ char *dyn_addr = base + dyn_phdr->p_vaddr;
+ Elf_Dyn *dyn = (Elf_Dyn *) dyn_addr;
+ size_t i, dyn_size = dyn_phdr->p_memsz / sizeof (Elf_Dyn);
+ char *init = 0, *gc_root = 0, *entry = 0, *frame_maps = 0;
+ scm_t_ptrdiff gc_root_size = 0;
+ enum bytecode_kind bytecode_kind = BYTECODE_KIND_NONE;
+
+ for (i = 0; i < dyn_size; i++)
+ {
+ if (dyn[i].d_tag == DT_NULL)
+ break;
+
+ switch (dyn[i].d_tag)
+ {
+ case DT_INIT:
+ if (init)
+ return "duplicate DT_INIT";
+ init = base + dyn[i].d_un.d_val;
+ break;
+ case DT_GUILE_GC_ROOT:
+ if (gc_root)
+ return "duplicate DT_GUILE_GC_ROOT";
+ gc_root = base + dyn[i].d_un.d_val;
+ break;
+ case DT_GUILE_GC_ROOT_SZ:
+ if (gc_root_size)
+ return "duplicate DT_GUILE_GC_ROOT_SZ";
+ gc_root_size = dyn[i].d_un.d_val;
+ break;
+ case DT_GUILE_ENTRY:
+ if (entry)
+ return "duplicate DT_GUILE_ENTRY";
+ entry = base + dyn[i].d_un.d_val;
+ break;
+ case DT_GUILE_VM_VERSION:
+ if (bytecode_kind != BYTECODE_KIND_NONE)
+ return "duplicate DT_GUILE_VM_VERSION";
+ {
+ scm_t_uint16 major = dyn[i].d_un.d_val >> 16;
+ scm_t_uint16 minor = dyn[i].d_un.d_val & 0xffff;
+ switch (major)
+ {
+ case 0x0202:
+ bytecode_kind = BYTECODE_KIND_GUILE_2_2;
+ /* As we get closer to 2.2, we will allow for backwards
+ compatibility and we can change this test to ">"
+ instead of "!=". However until then, to deal with VM
+ churn it's best to keep these things in
+ lock-step. */
+ if (minor != SCM_OBJCODE_MINOR_VERSION)
+ return "incompatible bytecode version";
+ break;
+ default:
+ return "incompatible bytecode kind";
+ }
+ break;
+ }
+ case DT_GUILE_FRAME_MAPS:
+ if (frame_maps)
+ return "duplicate DT_GUILE_FRAME_MAPS";
+ frame_maps = base + dyn[i].d_un.d_val;
+ break;
+ }
+ }
+
+ if (!entry)
+ return "missing DT_GUILE_ENTRY";
+
+ switch (bytecode_kind)
+ {
+ case BYTECODE_KIND_GUILE_2_2:
+ if ((scm_t_uintptr) init % 4)
+ return "unaligned DT_INIT";
+ if ((scm_t_uintptr) entry % 4)
+ return "unaligned DT_GUILE_ENTRY";
+ break;
+ case BYTECODE_KIND_NONE:
+ default:
+ return "missing DT_GUILE_VM_VERSION";
+ }
+
+ if (gc_root)
+ GC_add_roots (gc_root, gc_root + gc_root_size);
+
+ *init_out = init ? pointer_to_procedure (bytecode_kind, init) : SCM_BOOL_F;
+ *entry_out = pointer_to_procedure (bytecode_kind, entry);
+ *frame_maps_out = frame_maps;
+
+ return NULL;
+}
+
+#define ABORT(msg) do { err_msg = msg; goto cleanup; } while (0)
+
+static SCM
+load_thunk_from_memory (char *data, size_t len, int is_read_only)
+#define FUNC_NAME "load-thunk-from-memory"
+{
+ Elf_Ehdr *header;
+ Elf_Phdr *ph;
+ const char *err_msg = 0;
+ size_t n, alignment = 8;
+ int i;
+ int dynamic_segment = -1;
+ SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
+ char *frame_maps = 0;
+
+ if (len < sizeof *header)
+ ABORT ("object file too small");
+
+ header = (Elf_Ehdr*) data;
+
+ if ((err_msg = check_elf_header (header)))
+ goto cleanup;
+
+ if (header->e_phnum == 0)
+ ABORT ("no loadable segments");
+ n = header->e_phnum;
+
+ if (len < header->e_phoff + n * sizeof (Elf_Phdr))
+ ABORT ("object file too small");
+
+ ph = (Elf_Phdr*) (data + header->e_phoff);
+
+ /* Check that the segment table is sane. */
+ for (i = 0; i < n; i++)
+ {
+ if (ph[i].p_filesz != ph[i].p_memsz)
+ ABORT ("expected p_filesz == p_memsz");
+
+ if (!ph[i].p_flags)
+ ABORT ("expected nonzero segment flags");
+
+ if (ph[i].p_align < alignment)
+ {
+ if (ph[i].p_align % alignment)
+ ABORT ("expected new alignment to be multiple of old");
+ alignment = ph[i].p_align;
+ }
+
+ if (ph[i].p_type == PT_DYNAMIC)
+ {
+ if (dynamic_segment >= 0)
+ ABORT ("expected only one PT_DYNAMIC segment");
+ dynamic_segment = i;
+ continue;
+ }
+
+ if (ph[i].p_type != PT_LOAD)
+ ABORT ("unknown segment type");
+
+ if (i == 0)
+ {
+ if (ph[i].p_vaddr != 0)
+ ABORT ("first loadable vaddr is not 0");
+ }
+ else
+ {
+ if (ph[i].p_vaddr < ph[i-1].p_vaddr + ph[i-1].p_memsz)
+ ABORT ("overlapping segments");
+
+ if (ph[i].p_offset + ph[i].p_filesz > len)
+ ABORT ("segment beyond end of byte array");
+ }
+ }
+
+ if (dynamic_segment < 0)
+ ABORT ("no PT_DYNAMIC segment");
+
+ if (!IS_ALIGNED ((scm_t_uintptr) data, alignment))
+ ABORT ("incorrectly aligned base");
+
+ /* Allow writes to writable pages. */
+ if (is_read_only)
+ {
+#ifdef HAVE_SYS_MMAN_H
+ for (i = 0; i < n; i++)
+ {
+ if (ph[i].p_type != PT_LOAD)
+ continue;
+ if (ph[i].p_flags == PF_R)
+ continue;
+ if (ph[i].p_align != 4096)
+ continue;
+
+ if (mprotect (data + ph[i].p_vaddr,
+ ph[i].p_memsz,
+ segment_flags_to_prot (ph[i].p_flags)))
+ goto cleanup;
+ }
+#else
+ ABORT ("expected writable pages");
+#endif
+ }
+
+ if ((err_msg = process_dynamic_segment (data, &ph[dynamic_segment],
+ &init, &entry, &frame_maps)))
+ goto cleanup;
+
+ if (scm_is_true (init))
+ scm_call_0 (init);
+
+ register_elf (data, len, frame_maps);
+
+ /* Finally! Return the thunk. */
+ return entry;
+
+ cleanup:
+ {
+ if (errno)
+ SCM_SYSERROR;
+ scm_misc_error (FUNC_NAME, err_msg ? err_msg : "error loading ELF file",
+ SCM_EOL);
+ }
+}
+#undef FUNC_NAME
+
+#define SCM_PAGE_SIZE 4096
+
+static char*
+map_file_contents (int fd, size_t len, int *is_read_only)
+#define FUNC_NAME "load-thunk-from-file"
+{
+ char *data;
+
+#ifdef HAVE_SYS_MMAN_H
+ data = mmap (NULL, len, PROT_READ, MAP_PRIVATE, fd, 0);
+ if (data == MAP_FAILED)
+ SCM_SYSERROR;
+ *is_read_only = 1;
+#else
+ if (lseek (fd, 0, SEEK_START) < 0)
+ {
+ int errno_save = errno;
+ (void) close (fd);
+ errno = errno_save;
+ SCM_SYSERROR;
+ }
+
+ /* Given that we are using the read fallback, optimistically assume
+ that the .go files were made with 8-byte alignment.
+ alignment. */
+ data = malloc (end);
+ if (!data)
+ {
+ (void) close (fd);
+ scm_misc_error (FUNC_NAME, "failed to allocate ~A bytes",
+ scm_list_1 (scm_from_size_t (end)));
+ }
+
+ if (full_read (fd, data, end) != end)
+ {
+ int errno_save = errno;
+ (void) close (fd);
+ errno = errno_save;
+ if (errno)
+ SCM_SYSERROR;
+ scm_misc_error (FUNC_NAME, "short read while loading objcode",
+ SCM_EOL);
+ }
+
+ /* If our optimism failed, fall back. */
+ {
+ unsigned alignment = sniff_elf_alignment (data, end);
+
+ if (alignment != 8)
+ {
+ char *copy = copy_and_align_elf_data (data, end, alignment);
+ free (data);
+ data = copy;
+ }
+ }
+
+ *is_read_only = 0;
+#endif
+
+ return data;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_load_thunk_from_file, "load-thunk-from-file", 1, 0, 0,
+ (SCM filename),
+ "")
+#define FUNC_NAME s_scm_load_thunk_from_file
+{
+ char *c_filename;
+ int fd, is_read_only;
+ off_t end;
+ char *data;
+
+ SCM_VALIDATE_STRING (1, filename);
+
+ c_filename = scm_to_locale_string (filename);
+ fd = open (c_filename, O_RDONLY | O_BINARY | O_CLOEXEC);
+ free (c_filename);
+ if (fd < 0) SCM_SYSERROR;
+
+ end = lseek (fd, 0, SEEK_END);
+ if (end < 0)
+ SCM_SYSERROR;
+
+ data = map_file_contents (fd, end, &is_read_only);
+
+ (void) close (fd);
+
+ return load_thunk_from_memory (data, end, is_read_only);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_load_thunk_from_memory, "load-thunk-from-memory", 1, 0, 0,
+ (SCM bv),
+ "")
+#define FUNC_NAME s_scm_load_thunk_from_memory
+{
+ char *data;
+ size_t len;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ data = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ /* Copy data in order to align it, to trace its GC roots and
+ writable sections, and to keep it in memory. */
+
+ data = copy_and_align_elf_data (data, len);
+
+ return load_thunk_from_memory (data, len, 0);
+}
+#undef FUNC_NAME
+
+\f
+
+struct mapped_elf_image
+{
+ char *start;
+ char *end;
+ char *frame_maps;
+};
+
+static struct mapped_elf_image *mapped_elf_images = NULL;
+static size_t mapped_elf_images_count = 0;
+static size_t mapped_elf_images_allocated = 0;
+
+static size_t
+find_mapped_elf_insertion_index (char *ptr)
+{
+ /* "mapped_elf_images_count" must never be dereferenced. */
+ size_t start = 0, end = mapped_elf_images_count;
+
+ while (start < end)
+ {
+ size_t n = start + (end - start) / 2;
+
+ if (ptr < mapped_elf_images[n].end)
+ end = n;
+ else
+ start = n + 1;
+ }
+
+ return start;
+}
+
+static void
+register_elf (char *data, size_t len, char *frame_maps)
+{
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ {
+ /* My kingdom for a generic growable sorted vector library. */
+ if (mapped_elf_images_count == mapped_elf_images_allocated)
+ {
+ struct mapped_elf_image *prev;
+ size_t n;
+
+ if (mapped_elf_images_allocated)
+ mapped_elf_images_allocated *= 2;
+ else
+ mapped_elf_images_allocated = 16;
+
+ prev = mapped_elf_images;
+ mapped_elf_images =
+ scm_gc_malloc_pointerless (sizeof (*mapped_elf_images)
+ * mapped_elf_images_allocated,
+ "mapped elf images");
+
+ for (n = 0; n < mapped_elf_images_count; n++)
+ {
+ mapped_elf_images[n].start = prev[n].start;
+ mapped_elf_images[n].end = prev[n].end;
+ mapped_elf_images[n].frame_maps = prev[n].frame_maps;
+ }
+ }
+
+ {
+ size_t end;
+ size_t n = find_mapped_elf_insertion_index (data);
+
+ for (end = mapped_elf_images_count; n < end; end--)
+ {
+ const struct mapped_elf_image *prev = &mapped_elf_images[end - 1];
+ mapped_elf_images[end].start = prev->start;
+ mapped_elf_images[end].end = prev->end;
+ mapped_elf_images[end].frame_maps = prev->frame_maps;
+ }
+ mapped_elf_images_count++;
+
+ mapped_elf_images[n].start = data;
+ mapped_elf_images[n].end = data + len;
+ mapped_elf_images[n].frame_maps = frame_maps;
+ }
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+}
+
+static struct mapped_elf_image *
+find_mapped_elf_image_unlocked (char *ptr)
+{
+ size_t n = find_mapped_elf_insertion_index ((char *) ptr);
+
+ if (n < mapped_elf_images_count
+ && mapped_elf_images[n].start <= ptr
+ && ptr < mapped_elf_images[n].end)
+ return &mapped_elf_images[n];
+
+ return NULL;
+}
+
+static int
+find_mapped_elf_image (char *ptr, struct mapped_elf_image *image)
+{
+ int result;
+
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ {
+ struct mapped_elf_image *img = find_mapped_elf_image_unlocked (ptr);
+ if (img)
+ {
+ memcpy (image, img, sizeof (*image));
+ result = 1;
+ }
+ else
+ result = 0;
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
+ return result;
+}
+
+static SCM
+scm_find_mapped_elf_image (SCM ip)
+{
+ struct mapped_elf_image image;
+
+ if (find_mapped_elf_image ((char *) scm_to_uintptr_t (ip), &image))
+ {
+ signed char *data = (signed char *) image.start;
+ size_t len = image.end - image.start;
+
+ return scm_c_take_gc_bytevector (data, len, SCM_BOOL_F);
+ }
+
+ return SCM_BOOL_F;
+}
+
+static SCM
+scm_all_mapped_elf_images (void)
+{
+ SCM result = SCM_EOL;
+
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ {
+ size_t n;
+ for (n = 0; n < mapped_elf_images_count; n++)
+ {
+ signed char *data = (signed char *) mapped_elf_images[n].start;
+ size_t len = mapped_elf_images[n].end - mapped_elf_images[n].start;
+ result = scm_cons (scm_c_take_gc_bytevector (data, len, SCM_BOOL_F),
+ result);
+ }
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
+ return result;
+}
+
+struct frame_map_prefix
+{
+ scm_t_uint32 text_offset;
+ scm_t_uint32 maps_offset;
+};
+
+struct frame_map_header
+{
+ scm_t_uint32 addr;
+ scm_t_uint32 map_offset;
+};
+
+verify (sizeof (struct frame_map_prefix) == 8);
+verify (sizeof (struct frame_map_header) == 8);
+
+const scm_t_uint8 *
+scm_find_dead_slot_map_unlocked (const scm_t_uint32 *ip)
+{
+ struct mapped_elf_image *image;
+ char *base;
+ struct frame_map_prefix *prefix;
+ struct frame_map_header *headers;
+ scm_t_uintptr addr = (scm_t_uintptr) ip;
+ size_t start, end;
+
+ image = find_mapped_elf_image_unlocked ((char *) ip);
+ if (!image || !image->frame_maps)
+ return NULL;
+
+ base = image->frame_maps;
+ prefix = (struct frame_map_prefix *) base;
+ headers = (struct frame_map_header *) (base + sizeof (*prefix));
+
+ if (addr < ((scm_t_uintptr) image->start) + prefix->text_offset)
+ return NULL;
+ addr -= ((scm_t_uintptr) image->start) + prefix->text_offset;
+
+ start = 0;
+ end = (prefix->maps_offset - sizeof (*prefix)) / sizeof (*headers);
+
+ if (end == 0 || addr > headers[end - 1].addr)
+ return NULL;
+
+ while (start < end)
+ {
+ size_t n = start + (end - start) / 2;
+
+ if (addr == headers[n].addr)
+ return (const scm_t_uint8*) (base + headers[n].map_offset);
+ else if (addr < headers[n].addr)
+ end = n;
+ else
+ start = n + 1;
+ }
+
+ return NULL;
+}
+
+\f
+void
+scm_bootstrap_loader (void)
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_loader",
+ (scm_t_extension_init_func)scm_init_loader, NULL);
+}
+
+void
+scm_init_loader (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/loader.x"
+#endif
+
+ scm_c_define_gsubr ("find-mapped-elf-image", 1, 0, 0,
+ (scm_t_subr) scm_find_mapped_elf_image);
+ scm_c_define_gsubr ("all-mapped-elf-images", 0, 0, 0,
+ (scm_t_subr) scm_all_mapped_elf_images);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
-/* classes: h_files */
-
-#ifndef SCM_GDBINT_H
-#define SCM_GDBINT_H
-
-/* Copyright (C) 1996,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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
* 02110-1301 USA
*/
-\f
+#ifndef _SCM_LOADER_H_
+#define _SCM_LOADER_H_
-#include "libguile/__scm.h"
+#include <libguile.h>
-\f
+SCM_API SCM scm_load_thunk_from_file (SCM filename);
+SCM_API SCM scm_load_thunk_from_memory (SCM bv);
-SCM_API int scm_print_carefully_p;
+SCM_INTERNAL const scm_t_uint8 *
+scm_find_dead_slot_map_unlocked (const scm_t_uint32 *ip);
-SCM_INTERNAL void scm_init_gdbint (void);
+SCM_INTERNAL void scm_bootstrap_loader (void);
+SCM_INTERNAL void scm_init_loader (void);
-#endif /* SCM_GDBINT_H */
+#endif /* _SCM_LOADER_H_ */
/*
Local Variables:
macro_print (SCM macro, SCM port, scm_print_state *pstate)
{
if (scm_is_false (SCM_MACRO_TYPE (macro)))
- scm_puts ("#<primitive-syntax-transformer ", port);
+ scm_puts
_unlocked ("#<primitive-syntax-transformer ", port);
else
- scm_puts ("#<syntax-transformer ", port);
+ scm_puts_unlocked ("#<syntax-transformer ", port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
{
SCM z = scm_words (scm_tc16_macro, 5);
SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn);
- SCM_SET_SMOB_OBJECT_N (z, 2, scm_from_locale_symbol (name));
+ SCM_SET_SMOB_OBJECT_N (z, 2, scm_from_utf8_symbol (name));
SCM_SET_SMOB_OBJECT_N (z, 3, SCM_BOOL_F);
SCM_SET_SMOB_OBJECT_N (z, 4, SCM_BOOL_F);
return z;
/* classes: src_files
- * Copyright (C) 1995,1997,1998,2000,2001, 2006,
+ * Copyright (C) 1995,1997,1998,2000,2001, 2006, 2011,
* 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
static int
malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts("#<malloc ", port);
+ scm_puts_unlocked("#<malloc ", port);
scm_uintprint (SCM_SMOB_DATA (exp), 16, port);
- scm_putc('>', port);
+ scm_putc_unlocked('>', port);
return 1;
}
-/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
- * 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/_scm.h"
-#include "libguile/continuations.h"
-#include "libguile/eq.h"
-#include "libguile/expand.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
-
-
-#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)
-
-
-SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
-
-\f
-
-
-/* {Evaluator memoized expressions}
- */
-
-scm_t_bits scm_tc16_memoized;
-
-#define MAKMEMO(n, args) \
- (scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (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 FIXED_ARITY(nreq) \
- scm_list_1 (SCM_I_MAKINUM (nreq))
-#define REST_ARITY(nreq, rest) \
- scm_list_2 (SCM_I_MAKINUM (nreq), rest)
-#define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \
- scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \
- alt, SCM_UNDEFINED)
-#define MAKMEMO_LAMBDA(body, arity, docstring) \
- MAKMEMO (SCM_M_LAMBDA, \
- scm_cons (body, scm_cons (docstring, arity)))
-#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_DYNWIND(in, expr, out) \
- MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
-#define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
- MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
-#define MAKMEMO_APPLY(proc, args)\
- MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
-#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, nargs, args) \
- MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), 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))))
-#define MAKMEMO_PROMPT(tag, exp, handler) \
- MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler)))
-
-
-/* Primitives for the evaluator */
-scm_t_bits scm_tc16_memoizer;
-#define SCM_MEMOIZER_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoizer, (x)))
-#define SCM_MEMOIZER(M) (SCM_SMOB_OBJECT_1 (M))
-
-\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",
- "dynwind",
- "with-fluids",
- "apply",
- "call/cc",
- "call-with-values",
- "call",
- "lexical-ref",
- "lexical-set!",
- "toplevel-ref",
- "toplevel-set!",
- "module-ref",
- "module-set!",
- "prompt",
-};
-
-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;
-}
-
-
-\f
-
-
-static int
-lookup (SCM x, SCM env)
-{
- int i = 0;
- for (; scm_is_pair (env); env = CDR (env), i++)
- if (scm_is_eq (x, CAR (env)))
- return i; /* bound */
- abort ();
-}
-
-
-/* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
-#define REF(x,type,field) \
- (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
-
-static SCM list_of_guile = SCM_BOOL_F;
-
-static SCM memoize (SCM exp, SCM env);
-
-static SCM
-memoize_exps (SCM exps, SCM env)
-{
- SCM ret;
- for (ret = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
- ret = scm_cons (memoize (CAR (exps), env), ret);
- return scm_reverse_x (ret, SCM_UNDEFINED);
-}
-
-static SCM
-memoize (SCM exp, SCM env)
-{
- if (!SCM_EXPANDED_P (exp))
- abort ();
-
- switch (SCM_EXPANDED_TYPE (exp))
- {
- case SCM_EXPANDED_VOID:
- return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
-
- case SCM_EXPANDED_CONST:
- return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
-
- case SCM_EXPANDED_PRIMITIVE_REF:
- if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
- return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
- else
- return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
- SCM_BOOL_F);
-
- case SCM_EXPANDED_LEXICAL_REF:
- return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
-
- case SCM_EXPANDED_LEXICAL_SET:
- return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
- memoize (REF (exp, LEXICAL_SET, EXP), env));
-
- case SCM_EXPANDED_MODULE_REF:
- return MAKMEMO_MOD_REF (REF (exp, MODULE_REF, MOD),
- REF (exp, MODULE_REF, NAME),
- REF (exp, MODULE_REF, PUBLIC));
-
- case SCM_EXPANDED_MODULE_SET:
- return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env),
- REF (exp, MODULE_SET, MOD),
- REF (exp, MODULE_SET, NAME),
- REF (exp, MODULE_SET, PUBLIC));
-
- case SCM_EXPANDED_TOPLEVEL_REF:
- return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
-
- case SCM_EXPANDED_TOPLEVEL_SET:
- return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
- memoize (REF (exp, TOPLEVEL_SET, EXP), env));
-
- case SCM_EXPANDED_TOPLEVEL_DEFINE:
- return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
- memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env));
-
- case SCM_EXPANDED_CONDITIONAL:
- return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
- memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
- memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
-
- case SCM_EXPANDED_APPLICATION:
- {
- SCM proc, args;
-
- proc = REF (exp, APPLICATION, PROC);
- args = memoize_exps (REF (exp, APPLICATION, ARGS), env);
-
- if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_TOPLEVEL_REF)
- {
- SCM var = scm_module_variable (scm_current_module (),
- REF (proc, TOPLEVEL_REF, NAME));
- if (SCM_VARIABLEP (var))
- {
- SCM val = SCM_VARIABLE_REF (var);
- if (SCM_MEMOIZER_P (val))
- return scm_apply (SCM_SMOB_OBJECT_1 (val), args, SCM_EOL);
- }
- }
- /* otherwise we all fall down here */
- return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
- }
-
- case SCM_EXPANDED_SEQUENCE:
- return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env));
-
- case SCM_EXPANDED_LAMBDA:
- /* The body will be a lambda-case or #f. */
- {
- SCM meta, docstring, body, proc;
-
- meta = REF (exp, LAMBDA, META);
- docstring = scm_assoc_ref (meta, scm_sym_documentation);
-
- body = REF (exp, LAMBDA, BODY);
- if (scm_is_false (body))
- /* Give a body to case-lambda with no clauses. */
- proc = MAKMEMO_LAMBDA
- (MAKMEMO_CALL
- (MAKMEMO_MOD_REF (list_of_guile,
- scm_from_latin1_symbol ("throw"),
- SCM_BOOL_F),
- 5,
- scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
- MAKMEMO_QUOTE (SCM_BOOL_F),
- MAKMEMO_QUOTE (scm_from_latin1_string
- ("Wrong number of arguments")),
- MAKMEMO_QUOTE (SCM_EOL),
- MAKMEMO_QUOTE (SCM_BOOL_F))),
- FIXED_ARITY (0),
- SCM_BOOL_F /* docstring */);
- else
- proc = memoize (body, env);
-
- if (scm_is_string (docstring))
- {
- SCM args = SCM_MEMOIZED_ARGS (proc);
- SCM_SETCAR (SCM_CDR (args), docstring);
- }
-
- return proc;
- }
-
- case SCM_EXPANDED_LAMBDA_CASE:
- {
- SCM req, rest, opt, kw, inits, vars, body, alt;
- SCM walk, minits, arity, new_env;
- int nreq, nopt, ntotal;
-
- req = REF (exp, LAMBDA_CASE, REQ);
- rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
- opt = REF (exp, LAMBDA_CASE, OPT);
- kw = REF (exp, LAMBDA_CASE, KW);
- inits = REF (exp, LAMBDA_CASE, INITS);
- vars = REF (exp, LAMBDA_CASE, GENSYMS);
- body = REF (exp, LAMBDA_CASE, BODY);
- alt = REF (exp, LAMBDA_CASE, ALTERNATE);
-
- nreq = scm_ilength (req);
- nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
- ntotal = scm_ilength (vars);
-
- /* The vars are the gensyms, according to the divine plan. But we need
- to memoize the inits within their appropriate environment,
- complicating things. */
- new_env = env;
- for (walk = req; scm_is_pair (walk);
- walk = CDR (walk), vars = CDR (vars))
- new_env = scm_cons (CAR (vars), new_env);
-
- minits = SCM_EOL;
- for (walk = opt; scm_is_pair (walk);
- walk = CDR (walk), vars = CDR (vars), inits = CDR (inits))
- {
- minits = scm_cons (memoize (CAR (inits), new_env), minits);
- new_env = scm_cons (CAR (vars), new_env);
- }
-
- if (scm_is_true (rest))
- {
- new_env = scm_cons (CAR (vars), new_env);
- vars = CDR (vars);
- }
-
- for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits))
- {
- minits = scm_cons (memoize (CAR (inits), new_env), minits);
- new_env = scm_cons (CAR (vars), new_env);
- }
- if (!scm_is_null (vars))
- abort ();
-
- minits = scm_reverse_x (minits, SCM_UNDEFINED);
-
- if (scm_is_true (kw))
- {
- /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
- SCM aok = CAR (kw), indices = SCM_EOL;
- for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
- {
- SCM k;
- int idx;
-
- k = CAR (CAR (kw));
- idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env);
- indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
- }
- kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
- }
-
- if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
- {
- if (scm_is_false (rest))
- arity = FIXED_ARITY (nreq);
- else
- arity = REST_ARITY (nreq, SCM_BOOL_T);
- }
- else if (scm_is_true (alt))
- arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
- SCM_MEMOIZED_ARGS (memoize (alt, env)));
- else
- arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
-
- return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
- SCM_BOOL_F /* docstring */);
- }
-
- case SCM_EXPANDED_LET:
- {
- SCM vars, exps, body, inits, new_env;
-
- vars = REF (exp, LET, GENSYMS);
- exps = REF (exp, LET, VALS);
- body = REF (exp, LET, BODY);
-
- inits = SCM_EOL;
- new_env = env;
- for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps))
- {
- new_env = scm_cons (CAR (vars), new_env);
- inits = scm_cons (memoize (CAR (exps), env), inits);
- }
-
- return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED),
- memoize (body, new_env));
- }
-
- case SCM_EXPANDED_LETREC:
- {
- SCM vars, exps, body, undefs, new_env;
- int i, nvars, in_order_p;
-
- vars = REF (exp, LETREC, GENSYMS);
- exps = REF (exp, LETREC, VALS);
- body = REF (exp, LETREC, BODY);
- in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
- nvars = i = scm_ilength (vars);
- undefs = SCM_EOL;
- new_env = env;
-
- for (; scm_is_pair (vars); vars = CDR (vars))
- {
- new_env = scm_cons (CAR (vars), new_env);
- undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
- }
-
- if (in_order_p)
- {
- SCM body_exps = SCM_EOL;
- for (; scm_is_pair (exps); exps = CDR (exps), i--)
- body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
- memoize (CAR (exps), new_env)),
- body_exps);
- body_exps = scm_cons (memoize (body, new_env), body_exps);
- body_exps = scm_reverse_x (body_exps, SCM_UNDEFINED);
- return MAKMEMO_LET (undefs, MAKMEMO_BEGIN (body_exps));
- }
- else
- {
- SCM sets = SCM_EOL, inits = SCM_EOL;
- for (; scm_is_pair (exps); exps = CDR (exps), i--)
- {
- sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
- MAKMEMO_LEX_REF (i-1)),
- sets);
- inits = scm_cons (memoize (CAR (exps), new_env), inits);
- }
- inits = scm_reverse_x (inits, SCM_UNDEFINED);
- return MAKMEMO_LET
- (undefs,
- MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)),
- memoize (body, new_env))));
- }
- }
-
- case SCM_EXPANDED_DYNLET:
- return MAKMEMO_WITH_FLUIDS (memoize_exps (REF (exp, DYNLET, FLUIDS), env),
- memoize_exps (REF (exp, DYNLET, VALS), env),
- memoize (REF (exp, DYNLET, BODY), env));
-
- default:
- abort ();
- }
-}
-
-
-\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
-{
- SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
- return memoize (exp, scm_current_module ());
-}
-#undef FUNC_NAME
-
-
-\f
-
-#define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N) \
- (scm_cell (scm_tc16_memoizer, \
- SCM_UNPACK (scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
-#define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N) \
-SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
-
-#define SCM_MAKE_REST_MEMOIZER(STR, MEMOIZER, N) \
- (scm_cell (scm_tc16_memoizer, \
- SCM_UNPACK ((scm_c_make_gsubr (STR, N, 0, 1, MEMOIZER)))))
-#define SCM_DEFINE_REST_MEMOIZER(STR, MEMOIZER, N) \
-SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_REST_MEMOIZER (STR, MEMOIZER, N)))
-
-static SCM m_apply (SCM proc, SCM arg, SCM rest);
-static SCM m_call_cc (SCM proc);
-static SCM m_call_values (SCM prod, SCM cons);
-static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
-static SCM m_prompt (SCM tag, SCM exp, SCM handler);
-
-SCM_DEFINE_REST_MEMOIZER ("@apply", m_apply, 2);
-SCM_DEFINE_MEMOIZER ("@call-with-current-continuation", m_call_cc, 1);
-SCM_DEFINE_MEMOIZER ("@call-with-values", m_call_values, 2);
-SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
-SCM_DEFINE_MEMOIZER ("@prompt", m_prompt, 3);
-
-
-\f
-
-static SCM m_apply (SCM proc, SCM arg, SCM rest)
-#define FUNC_NAME "@apply"
-{
- long len;
-
- SCM_VALIDATE_MEMOIZED (1, proc);
- SCM_VALIDATE_MEMOIZED (2, arg);
- len = scm_ilength (rest);
- if (len < 0)
- abort ();
- else if (len == 0)
- return MAKMEMO_APPLY (proc, arg);
- else
- {
- SCM tail;
-
- rest = scm_reverse (rest);
- tail = scm_car (rest);
- rest = scm_cdr (rest);
- len--;
-
- while (scm_is_pair (rest))
- {
- tail = MAKMEMO_CALL (MAKMEMO_MOD_REF (scm_list_1 (scm_from_latin1_symbol ("guile")),
- scm_from_latin1_symbol ("cons"),
- SCM_BOOL_F),
- 2,
- scm_list_2 (scm_car (rest), tail));
- rest = scm_cdr (rest);
- }
- return MAKMEMO_APPLY (proc, tail);
- }
-}
-#undef FUNC_NAME
-
-static SCM m_call_cc (SCM proc)
-#define FUNC_NAME "@call-with-current-continuation"
-{
- SCM_VALIDATE_MEMOIZED (1, proc);
- return MAKMEMO_CONT (proc);
-}
-#undef FUNC_NAME
-
-static SCM m_call_values (SCM prod, SCM cons)
-#define FUNC_NAME "@call-with-values"
-{
- SCM_VALIDATE_MEMOIZED (1, prod);
- SCM_VALIDATE_MEMOIZED (2, cons);
- return MAKMEMO_CALL_WITH_VALUES (prod, cons);
-}
-#undef FUNC_NAME
-
-static SCM m_dynamic_wind (SCM in, SCM expr, SCM out)
-#define FUNC_NAME "memoize-dynwind"
-{
- SCM_VALIDATE_MEMOIZED (1, in);
- SCM_VALIDATE_MEMOIZED (2, expr);
- SCM_VALIDATE_MEMOIZED (3, out);
- return MAKMEMO_DYNWIND (in, expr, out);
-}
-#undef FUNC_NAME
-
-static SCM m_prompt (SCM tag, SCM exp, SCM handler)
-#define FUNC_NAME "@prompt"
-{
- SCM_VALIDATE_MEMOIZED (1, tag);
- SCM_VALIDATE_MEMOIZED (2, exp);
- SCM_VALIDATE_MEMOIZED (3, handler);
- return MAKMEMO_PROMPT (tag, exp, handler);
-}
-#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 scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (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_DYNWIND:
- return scm_list_4 (scm_sym_at_dynamic_wind,
- unmemoize (CAR (args)),
- unmemoize (CADR (args)),
- unmemoize (CDDR (args)));
- case SCM_M_WITH_FLUIDS:
- {
- SCM binds = SCM_EOL, fluids, vals;
- for (fluids = CAR (args), vals = CADR (args); scm_is_pair (fluids);
- fluids = CDR (fluids), vals = CDR (vals))
- binds = scm_cons (scm_list_2 (unmemoize (CAR (fluids)),
- unmemoize (CAR (vals))),
- binds);
- return scm_list_3 (scm_sym_with_fluids,
- scm_reverse_x (binds, SCM_UNDEFINED),
- unmemoize (CDDR (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:
- {
- SCM body = CAR (args), spec = CDDR (args);
-
- if (scm_is_null (CDR (spec)))
- return scm_list_3 (scm_sym_lambda,
- scm_make_list (CAR (spec), sym_placeholder),
- unmemoize (CAR (args)));
- else if (scm_is_null (SCM_CDDR (spec)))
- {
- SCM formals = scm_make_list (CAR (spec), sym_placeholder);
- return scm_list_3 (scm_sym_lambda,
- scm_is_true (CADR (spec))
- ? scm_cons_star (sym_placeholder, formals)
- : formals,
- unmemoize (CAR (args)));
- }
- else
- {
- SCM alt, tail;
-
- alt = CADDR (CDDDR (spec));
- if (scm_is_true (alt))
- tail = CDR (unmemoize (alt));
- else
- tail = SCM_EOL;
-
- return scm_cons
- (sym_case_lambda_star,
- scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
- CADR (spec),
- CADDR (spec),
- CADDDR (spec),
- unmemoize_exprs (CADR (CDDDR (spec)))),
- unmemoize (body)),
- tail));
- }
- }
- 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_VARIABLEP (args) ? args
- : 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_VARIABLEP (CDR (args)) ? CDR (args)
- : 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)));
- case SCM_M_PROMPT:
- return scm_list_4 (scm_sym_at_prompt,
- unmemoize (CAR (args)),
- unmemoize (CADR (args)),
- unmemoize (CDDR (args)));
- default:
- abort ();
- }
-}
-
-
-\f
-
-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);
-
- /* The tag is a 16-bit integer so it fits in an inum. */
- return SCM_I_MAKINUM (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_print (scm_tc16_memoized, scm_print_memoized);
-
- scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0);
-
-#include "libguile/memoize.x"
-
- list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014
+ * 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/_scm.h"
+#include "libguile/continuations.h"
+#include "libguile/eq.h"
+#include "libguile/expand.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
+
+
+#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)
+
+#define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
+#define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
+#define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
+
+SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
+
+\f
+
+
+/* Primitives not exposed to general Scheme. */
+static SCM wind;
+static SCM unwind;
+static SCM push_fluid;
+static SCM pop_fluid;
+
+static SCM
+do_wind (SCM in, SCM out)
+{
+ scm_dynstack_push_dynwind (&SCM_I_CURRENT_THREAD->dynstack, in, out);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+do_unwind (void)
+{
+ scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+do_push_fluid (SCM fluid, SCM val)
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_dynstack_push_fluid (&thread->dynstack, fluid, val,
+ thread->dynamic_state);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+do_pop_fluid (void)
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
+ return SCM_UNSPECIFIED;
+}
+
+
+\f
+
+/* {Evaluator memoized expressions}
+ */
+
+scm_t_bits scm_tc16_memoized;
+
+#define MAKMEMO(n, args) \
+ (scm_cons (SCM_I_MAKINUM (n), args))
+
+#define MAKMEMO_SEQ(head,tail) \
+ MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
+#define MAKMEMO_IF(test, then, else_) \
+ MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
+#define FIXED_ARITY(nreq) \
+ scm_list_1 (SCM_I_MAKINUM (nreq))
+#define REST_ARITY(nreq, rest) \
+ scm_list_2 (SCM_I_MAKINUM (nreq), rest)
+#define FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \
+ scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \
+ SCM_I_MAKINUM (ninits), unbound, alt, SCM_UNDEFINED)
+#define MAKMEMO_LAMBDA(body, arity, meta) \
+ MAKMEMO (SCM_M_LAMBDA, \
+ scm_cons (body, scm_cons (meta, arity)))
+#define MAKMEMO_CAPTURE_ENV(vars, body) \
+ MAKMEMO (SCM_M_CAPTURE_ENV, scm_cons (vars, 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_CAPTURE_MODULE(exp) \
+ MAKMEMO (SCM_M_CAPTURE_MODULE, exp)
+#define MAKMEMO_APPLY(proc, args)\
+ MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
+#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, nargs, args) \
+ MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
+#define MAKMEMO_LEX_REF(pos) \
+ MAKMEMO (SCM_M_LEXICAL_REF, pos)
+#define MAKMEMO_LEX_SET(pos, val) \
+ MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val))
+#define MAKMEMO_BOX_REF(box) \
+ MAKMEMO (SCM_M_BOX_REF, box)
+#define MAKMEMO_BOX_SET(box, val) \
+ MAKMEMO (SCM_M_BOX_SET, scm_cons (box, val))
+#define MAKMEMO_TOP_BOX(mode, var) \
+ MAKMEMO (SCM_M_RESOLVE, scm_cons (SCM_I_MAKINUM (mode), var))
+#define MAKMEMO_MOD_BOX(mode, mod, var, public) \
+ MAKMEMO (SCM_M_RESOLVE, \
+ scm_cons (SCM_I_MAKINUM (mode), \
+ scm_cons (mod, scm_cons (var, public))))
+#define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
+ MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
+
+
+\f
+
+/* This table must agree with the list of M_ constants in memoize.h */
+static const char *const memoized_tags[] =
+{
+ "seq",
+ "if",
+ "lambda",
+ "capture-env",
+ "let",
+ "quote",
+ "capture-module",
+ "apply",
+ "call/cc",
+ "call-with-values",
+ "call",
+ "lexical-ref",
+ "lexical-set!",
+ "box-ref",
+ "box-set!",
+ "resolve",
+ "call-with-prompt",
+};
+
+
+\f
+
+
+/* Memoization-time environments mirror the structure of eval-time
+ environments. Each link in the chain at memoization-time corresponds
+ to a link at eval-time.
+
+ env := module | (link, env)
+ module := #f | #t
+ link := flat-link . nested-link
+ flat-link := (#t . ((var . pos) ...))
+ nested-link := (#f . #(var ...))
+
+ A module of #f indicates that the current module has not yet been
+ captured. Memoizing a capture-module expression will capture the
+ module.
+
+ Flat environments copy the values for a set of free variables into a
+ flat environment, via the capture-env expression. During memoization
+ a flat link collects the values of free variables, along with their
+ resolved outer locations. We are able to copy values because the
+ incoming expression has already been assignment-converted. Flat
+ environments prevent closures from hanging on to too much memory.
+
+ Nested environments have a rib of "let" bindings, and link to an
+ outer environment.
+*/
+
+static int
+try_lookup_rib (SCM x, SCM rib)
+{
+ int idx = 0;
+ for (; idx < VECTOR_LENGTH (rib); idx++)
+ if (scm_is_eq (x, VECTOR_REF (rib, idx)))
+ return idx; /* bound */
+ return -1;
+}
+
+static int
+lookup_rib (SCM x, SCM rib)
+{
+ int idx = try_lookup_rib (x, rib);
+ if (idx < 0)
+ abort ();
+ return idx;
+}
+
+static SCM
+make_pos (int depth, int width)
+{
+ return scm_cons (SCM_I_MAKINUM (depth), SCM_I_MAKINUM (width));
+}
+
+static SCM
+push_nested_link (SCM vars, SCM env)
+{
+ return scm_acons (SCM_BOOL_F, vars, env);
+}
+
+static SCM
+push_flat_link (SCM env)
+{
+ return scm_acons (SCM_BOOL_T, SCM_EOL, env);
+}
+
+static int
+env_link_is_flat (SCM env_link)
+{
+ return scm_is_true (CAR (env_link));
+}
+
+static SCM
+env_link_vars (SCM env_link)
+{
+ return CDR (env_link);
+}
+
+static void
+env_link_add_flat_var (SCM env_link, SCM var, SCM pos)
+{
+ SCM vars = env_link_vars (env_link);
+ if (scm_is_false (scm_assq (var, vars)))
+ scm_set_cdr_x (env_link, scm_acons (var, pos, vars));
+}
+
+static SCM
+lookup (SCM x, SCM env)
+{
+ int d = 0;
+ for (; scm_is_pair (env); env = CDR (env), d++)
+ {
+ SCM link = CAR (env);
+ if (env_link_is_flat (link))
+ {
+ int w;
+ SCM vars;
+
+ for (vars = env_link_vars (link), w = scm_ilength (vars) - 1;
+ scm_is_pair (vars);
+ vars = CDR (vars), w--)
+ if (scm_is_eq (x, (CAAR (vars))))
+ return make_pos (d, w);
+
+ env_link_add_flat_var (link, x, lookup (x, CDR (env)));
+ return make_pos (d, scm_ilength (env_link_vars (link)) - 1);
+ }
+ else
+ {
+ int w = try_lookup_rib (x, env_link_vars (link));
+ if (w < 0)
+ continue;
+ return make_pos (d, w);
+ }
+ }
+ abort ();
+}
+
+static SCM
+capture_flat_env (SCM lambda, SCM env)
+{
+ int nenv;
+ SCM vars, link, locs;
+
+ link = CAR (env);
+ vars = env_link_vars (link);
+ nenv = scm_ilength (vars);
+ locs = scm_c_make_vector (nenv, SCM_BOOL_F);
+
+ for (; scm_is_pair (vars); vars = CDR (vars))
+ scm_c_vector_set_x (locs, --nenv, CDAR (vars));
+
+ return MAKMEMO_CAPTURE_ENV (locs, lambda);
+}
+
+/* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
+#define REF(x,type,field) \
+ (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
+
+static SCM list_of_guile = SCM_BOOL_F;
+
+static SCM memoize (SCM exp, SCM env);
+
+static SCM
+memoize_exps (SCM exps, SCM env)
+{
+ SCM ret;
+ for (ret = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
+ ret = scm_cons (memoize (CAR (exps), env), ret);
+ return scm_reverse_x (ret, SCM_UNDEFINED);
+}
+
+static SCM
+capture_env (SCM env)
+{
+ if (scm_is_false (env))
+ return SCM_BOOL_T;
+ return env;
+}
+
+static SCM
+maybe_makmemo_capture_module (SCM exp, SCM env)
+{
+ if (scm_is_false (env))
+ return MAKMEMO_CAPTURE_MODULE (exp);
+ return exp;
+}
+
+static SCM
+memoize (SCM exp, SCM env)
+{
+ if (!SCM_EXPANDED_P (exp))
+ abort ();
+
+ switch (SCM_EXPANDED_TYPE (exp))
+ {
+ case SCM_EXPANDED_VOID:
+ return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
+
+ case SCM_EXPANDED_CONST:
+ return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
+
+ case SCM_EXPANDED_PRIMITIVE_REF:
+ if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
+ return maybe_makmemo_capture_module
+ (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
+ REF (exp, PRIMITIVE_REF, NAME))),
+ env);
+ else
+ return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
+ list_of_guile,
+ REF (exp, PRIMITIVE_REF, NAME),
+ SCM_BOOL_F));
+
+ case SCM_EXPANDED_LEXICAL_REF:
+ return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
+
+ case SCM_EXPANDED_LEXICAL_SET:
+ return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
+ memoize (REF (exp, LEXICAL_SET, EXP), env));
+
+ case SCM_EXPANDED_MODULE_REF:
+ return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX
+ (SCM_EXPANDED_MODULE_REF,
+ REF (exp, MODULE_REF, MOD),
+ REF (exp, MODULE_REF, NAME),
+ REF (exp, MODULE_REF, PUBLIC)));
+
+ case SCM_EXPANDED_MODULE_SET:
+ return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX
+ (SCM_EXPANDED_MODULE_SET,
+ REF (exp, MODULE_SET, MOD),
+ REF (exp, MODULE_SET, NAME),
+ REF (exp, MODULE_SET, PUBLIC)),
+ memoize (REF (exp, MODULE_SET, EXP), env));
+
+ case SCM_EXPANDED_TOPLEVEL_REF:
+ return maybe_makmemo_capture_module
+ (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
+ REF (exp, TOPLEVEL_REF, NAME))),
+ env);
+
+ case SCM_EXPANDED_TOPLEVEL_SET:
+ return maybe_makmemo_capture_module
+ (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET,
+ REF (exp, TOPLEVEL_SET, NAME)),
+ memoize (REF (exp, TOPLEVEL_SET, EXP),
+ capture_env (env))),
+ env);
+
+ case SCM_EXPANDED_TOPLEVEL_DEFINE:
+ return maybe_makmemo_capture_module
+ (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE,
+ REF (exp, TOPLEVEL_DEFINE, NAME)),
+ memoize (REF (exp, TOPLEVEL_DEFINE, EXP),
+ capture_env (env))),
+ env);
+
+ case SCM_EXPANDED_CONDITIONAL:
+ return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
+ memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
+ memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
+
+ case SCM_EXPANDED_CALL:
+ {
+ SCM proc, args;
+
+ proc = REF (exp, CALL, PROC);
+ args = memoize_exps (REF (exp, CALL, ARGS), env);
+
+ return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
+ }
+
+ case SCM_EXPANDED_PRIMCALL:
+ {
+ SCM name, args;
+ int nargs;
+
+ name = REF (exp, PRIMCALL, NAME);
+ args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
+ nargs = scm_ilength (args);
+
+ if (nargs == 3
+ && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
+ return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
+ CADR (args),
+ CADDR (args));
+ else if (nargs == 2
+ && scm_is_eq (name, scm_from_latin1_symbol ("apply")))
+ return MAKMEMO_APPLY (CAR (args), CADR (args));
+ else if (nargs == 1
+ && scm_is_eq (name,
+ scm_from_latin1_symbol
+ ("call-with-current-continuation")))
+ return MAKMEMO_CONT (CAR (args));
+ else if (nargs == 2
+ && scm_is_eq (name,
+ scm_from_latin1_symbol ("call-with-values")))
+ return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
+ else if (nargs == 1
+ && scm_is_eq (name,
+ scm_from_latin1_symbol ("variable-ref")))
+ return MAKMEMO_BOX_REF (CAR (args));
+ else if (nargs == 2
+ && scm_is_eq (name,
+ scm_from_latin1_symbol ("variable-set!")))
+ return MAKMEMO_BOX_SET (CAR (args), CADR (args));
+ else if (nargs == 2
+ && scm_is_eq (name, scm_from_latin1_symbol ("wind")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
+ else if (nargs == 0
+ && scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
+ else if (nargs == 2
+ && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args);
+ else if (nargs == 0
+ && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
+ else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
+ return MAKMEMO_CALL (maybe_makmemo_capture_module
+ (MAKMEMO_BOX_REF
+ (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
+ name)),
+ env),
+ nargs, args);
+ else
+ return MAKMEMO_CALL (MAKMEMO_BOX_REF
+ (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
+ list_of_guile,
+ name,
+ SCM_BOOL_F)),
+ nargs,
+ args);
+ }
+
+ case SCM_EXPANDED_SEQ:
+ return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
+ memoize (REF (exp, SEQ, TAIL), env));
+
+ case SCM_EXPANDED_LAMBDA:
+ /* The body will be a lambda-case. */
+ {
+ SCM meta, body, proc, new_env;
+
+ meta = REF (exp, LAMBDA, META);
+ body = REF (exp, LAMBDA, BODY);
+ new_env = push_flat_link (capture_env (env));
+ proc = memoize (body, new_env);
+ SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
+
+ return maybe_makmemo_capture_module (capture_flat_env (proc, new_env),
+ env);
+ }
+
+ case SCM_EXPANDED_LAMBDA_CASE:
+ {
+ SCM req, rest, opt, kw, inits, vars, body, alt;
+ SCM unbound, arity, rib, new_env;
+ int nreq, nopt, ninits;
+
+ req = REF (exp, LAMBDA_CASE, REQ);
+ rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
+ opt = REF (exp, LAMBDA_CASE, OPT);
+ kw = REF (exp, LAMBDA_CASE, KW);
+ inits = REF (exp, LAMBDA_CASE, INITS);
+ vars = REF (exp, LAMBDA_CASE, GENSYMS);
+ body = REF (exp, LAMBDA_CASE, BODY);
+ alt = REF (exp, LAMBDA_CASE, ALTERNATE);
+
+ nreq = scm_ilength (req);
+ nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
+ ninits = scm_ilength (inits);
+ /* This relies on assignment conversion turning inits into a
+ sequence of CONST expressions whose values are a unique
+ "unbound" token. */
+ unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F;
+ rib = scm_vector (vars);
+ new_env = push_nested_link (rib, env);
+
+ if (scm_is_true (kw))
+ {
+ /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
+ SCM aok = CAR (kw), indices = SCM_EOL;
+ for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
+ {
+ SCM k;
+ int idx;
+
+ k = CAR (CAR (kw));
+ idx = lookup_rib (CADDR (CAR (kw)), rib);
+ indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
+ }
+ kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
+ }
+
+ if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
+ {
+ if (scm_is_false (rest))
+ arity = FIXED_ARITY (nreq);
+ else
+ arity = REST_ARITY (nreq, SCM_BOOL_T);
+ }
+ else if (scm_is_true (alt))
+ arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
+ SCM_MEMOIZED_ARGS (memoize (alt, env)));
+ else
+ arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
+ SCM_BOOL_F);
+
+ return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
+ SCM_EOL /* meta, filled in later */);
+ }
+
+ case SCM_EXPANDED_LET:
+ {
+ SCM vars, exps, body, varsv, inits, new_env;
+ int i;
+
+ vars = REF (exp, LET, GENSYMS);
+ exps = REF (exp, LET, VALS);
+ body = REF (exp, LET, BODY);
+
+ varsv = scm_vector (vars);
+ inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
+ SCM_BOOL_F);
+ new_env = push_nested_link (varsv, capture_env (env));
+ for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
+ VECTOR_SET (inits, i, memoize (CAR (exps), env));
+
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (inits, memoize (body, new_env)), env);
+ }
+
+ default:
+ abort ();
+ }
+}
+
+
+\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
+{
+ SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
+ return memoize (scm_convert_assignment (exp), SCM_BOOL_F);
+}
+#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 = SCM_EOL;
+ int n = scm_c_vector_length (inits);
+
+ while (n--)
+ ret = scm_cons (unmemoize (scm_c_vector_ref (inits, n)), ret);
+
+ return ret;
+}
+
+static SCM
+unmemoize_lexical (SCM n)
+{
+ char buf[32];
+ buf[31] = 0;
+ snprintf (buf, 31, "<%u,%u>", scm_to_uint32 (CAR (n)),
+ scm_to_uint32 (CDR (n)));
+ return scm_from_utf8_symbol (buf);
+}
+
+static SCM
+unmemoize (const SCM expr)
+{
+ SCM args;
+
+ args = SCM_MEMOIZED_ARGS (expr);
+ switch (SCM_MEMOIZED_TAG (expr))
+ {
+ case SCM_M_APPLY:
+ return scm_cons (scm_from_latin1_symbol ("apply"),
+ unmemoize_exprs (args));
+ case SCM_M_SEQ:
+ return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
+ unmemoize (CDR (args)));
+ case SCM_M_CALL:
+ return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args)));
+ case SCM_M_CONT:
+ return scm_list_2 (scm_from_latin1_symbol
+ ("call-with-current_continuation"),
+ unmemoize (args));
+ case SCM_M_CALL_WITH_VALUES:
+ return scm_list_3 (scm_from_latin1_symbol ("call-with-values"),
+ unmemoize (CAR (args)), unmemoize (CDR (args)));
+ case SCM_M_CAPTURE_MODULE:
+ return scm_list_2 (scm_from_latin1_symbol ("capture-module"),
+ unmemoize (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:
+ {
+ SCM body = CAR (args), spec = CDDR (args);
+
+ if (scm_is_null (CDR (spec)))
+ return scm_list_3 (scm_sym_lambda,
+ scm_make_list (CAR (spec), sym_placeholder),
+ unmemoize (CAR (args)));
+ else if (scm_is_null (SCM_CDDR (spec)))
+ {
+ SCM formals = scm_make_list (CAR (spec), sym_placeholder);
+ return scm_list_3 (scm_sym_lambda,
+ scm_is_true (CADR (spec))
+ ? scm_cons_star (sym_placeholder, formals)
+ : formals,
+ unmemoize (CAR (args)));
+ }
+ else
+ {
+ SCM alt, tail;
+
+ alt = CADDDR (CDDDR (spec));
+ if (scm_is_true (alt))
+ tail = CDR (unmemoize (alt));
+ else
+ tail = SCM_EOL;
+
+ return scm_cons
+ (sym_case_lambda_star,
+ scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
+ CADR (spec),
+ CADDR (spec),
+ CADDDR (spec),
+ CADR (CDDDR (spec))),
+ unmemoize (body)),
+ tail));
+ }
+ }
+ case SCM_M_CAPTURE_ENV:
+ return scm_list_3 (scm_from_latin1_symbol ("capture-env"),
+ CAR (args),
+ unmemoize (CDR (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_BOX_REF:
+ return scm_list_2 (scm_from_latin1_symbol ("variable-ref"),
+ unmemoize (args));
+ case SCM_M_BOX_SET:
+ return scm_list_3 (scm_from_latin1_symbol ("variable-set!"),
+ unmemoize (CAR (args)),
+ unmemoize (CDR (args)));
+ case SCM_M_RESOLVE:
+ if (SCM_VARIABLEP (args))
+ return args;
+ else if (scm_is_symbol (CDR (args)))
+ return CDR (args);
+ else
+ return scm_list_3
+ (scm_is_true (CDDDR (args)) ? scm_sym_at : scm_sym_atat,
+ scm_i_finite_list_copy (CADR (args)),
+ CADDR (args));
+ case SCM_M_CALL_WITH_PROMPT:
+ return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
+ unmemoize (CAR (args)),
+ unmemoize (CADR (args)),
+ unmemoize (CDDR (args)));
+ default:
+ abort ();
+ }
+}
+
+
+\f
+
+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
+{
+ return unmemoize (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_sys_resolve_variable, "%resolve-variable", 2, 0, 0,
+ (SCM loc, SCM mod),
+ "Look up and return the variable for @var{loc}.")
+#define FUNC_NAME s_scm_sys_resolve_variable
+{
+ int mode;
+
+ if (scm_is_false (mod))
+ mod = scm_the_root_module ();
+
+ mode = scm_to_int (scm_car (loc));
+ loc = scm_cdr (loc);
+
+ switch (mode)
+ {
+ case SCM_EXPANDED_TOPLEVEL_REF:
+ case SCM_EXPANDED_TOPLEVEL_SET:
+ {
+ SCM var = scm_module_variable (mod, loc);
+ if (scm_is_false (var)
+ || (mode == SCM_EXPANDED_TOPLEVEL_REF
+ && scm_is_false (scm_variable_bound_p (var))))
+ error_unbound_variable (loc);
+ return var;
+ }
+
+ case SCM_EXPANDED_TOPLEVEL_DEFINE:
+ {
+ return scm_module_ensure_local_variable (mod, loc);
+ }
+
+ case SCM_EXPANDED_MODULE_REF:
+ case SCM_EXPANDED_MODULE_SET:
+ {
+ SCM var;
+ mod = scm_resolve_module (scm_car (loc));
+ if (scm_is_true (scm_cddr (loc)))
+ mod = scm_module_public_interface (mod);
+ var = scm_module_lookup (mod, scm_cadr (loc));
+ if (mode == SCM_EXPANDED_MODULE_SET
+ && scm_is_false (scm_variable_bound_p (var)))
+ error_unbound_variable (scm_cadr (loc));
+ return var;
+ }
+
+ default:
+ scm_wrong_type_arg (FUNC_NAME, 1, loc);
+ return SCM_BOOL_F;
+ }
+}
+#undef FUNC_NAME
+
+
+\f
+
+void
+scm_init_memoize ()
+{
+#include "libguile/memoize.x"
+
+ wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
+ unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
+ push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid);
+ pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid);
+
+ list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
#ifndef SCM_MEMOIZE_H
#define SCM_MEMOIZE_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2013,2014
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
SCM_API SCM scm_sym_quasiquote;
SCM_API SCM scm_sym_unquote;
SCM_API SCM scm_sym_uq_splicing;
-SCM_API SCM scm_sym_with_fluids;
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_at_prompt;
SCM_API SCM scm_sym_delay;
-SCM_API SCM scm_sym_at_dynamic_wind;
SCM_API SCM scm_sym_eval_when;
SCM_API SCM scm_sym_arrow;
SCM_API SCM scm_sym_else;
/* {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))
+#define SCM_MEMOIZED_TAG(x) (scm_to_uint16 (scm_car (x)))
+#define SCM_MEMOIZED_ARGS(x) (scm_cdr (x))
enum
{
- SCM_M_BEGIN,
+ SCM_M_SEQ,
SCM_M_IF,
SCM_M_LAMBDA,
+ SCM_M_CAPTURE_ENV,
SCM_M_LET,
SCM_M_QUOTE,
- SCM_M_DEFINE,
- SCM_M_DYNWIND,
- SCM_M_WITH_FLUIDS,
+ SCM_M_CAPTURE_MODULE,
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,
- SCM_M_PROMPT
+ SCM_M_BOX_REF,
+ SCM_M_BOX_SET,
+ SCM_M_RESOLVE,
+ SCM_M_CALL_WITH_PROMPT
};
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 SCM scm_sys_resolve_variable (SCM loc, SCM module);
SCM_INTERNAL void scm_init_memoize (void);
ptr++;
if (ptr > name)
{
- SCM sym = scm_from_locale_symboln (name, ptr-name);
+ SCM sym = scm_from_utf8_symboln (name, ptr-name);
*tail = scm_cons (sym, SCM_EOL);
tail = SCM_CDRLOC (*tail);
}
if (name)
{
va_list ap;
- SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL);
+ SCM names = scm_cons (scm_from_utf8_symbol (name), SCM_EOL);
SCM *tail = SCM_CDRLOC (names);
va_start (ap, name);
while (1)
const char *n = va_arg (ap, const char *);
if (n == NULL)
break;
- *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL);
+ *tail = scm_cons (scm_from_utf8_symbol (n), SCM_EOL);
tail = SCM_CDRLOC (*tail);
}
va_end (ap);
SCM
scm_c_module_lookup (SCM module, const char *name)
{
- return scm_module_lookup (module, scm_from_locale_symbol (name));
+ return scm_module_lookup (module, scm_from_utf8_symbol (name));
}
SCM
SCM
scm_c_lookup (const char *name)
{
- return scm_lookup (scm_from_locale_symbol (name));
+ return scm_lookup (scm_from_utf8_symbol (name));
}
SCM
scm_c_public_variable (const char *module_name, const char *name)
{
return scm_public_variable (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_private_variable (const char *module_name, const char *name)
{
return scm_private_variable (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_public_lookup (const char *module_name, const char *name)
{
return scm_public_lookup (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_private_lookup (const char *module_name, const char *name)
{
return scm_private_lookup (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_public_ref (const char *module_name, const char *name)
{
return scm_public_ref (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_private_ref (const char *module_name, const char *name)
{
return scm_private_ref (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_module_define (SCM module, const char *name, SCM value)
{
- return scm_module_define (module, scm_from_locale_symbol (name), value);
+ return scm_module_define (module, scm_from_utf8_symbol (name), value);
}
SCM
SCM
scm_c_define (const char *name, SCM value)
{
- return scm_define (scm_from_locale_symbol (name), value);
+ return scm_define (scm_from_utf8_symbol (name), value);
}
SCM_DEFINE (scm_define, "define!", 2, 0, 0,
{
handle = SCM_CAR (ls);
- if (SCM_UNPACK (SCM_CAR (handle)) == 0)
- {
- /* FIXME: We hit a weak pair whose car has become unreachable.
- We should remove the pair in question or something. */
- }
- else
- {
- if (scm_is_eq (SCM_CDR (handle), variable))
- return SCM_CAR (handle);
- }
+ if (scm_is_eq (SCM_CDR (handle), variable))
+ return SCM_CAR (handle);
ls = SCM_CDR (ls);
}
void
scm_modules_prehistory ()
{
- scm_pre_modules_obarray = scm_c_make_hash_table (1533);
+ scm_pre_modules_obarray = scm_c_make_hash_table (1790);
}
void
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
- * 2014 Free Software Foundation, Inc.
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
+ * 2013, 2014 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
{
SCM bignum;
- bignum = PTR2SCM (ptr);
+ bignum = SCM_PACK_POINTER (ptr);
mpz_clear (SCM_I_BIG_MPZ (bignum));
}
{
SCM z;
- z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
+ z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
SCM_SET_CELL_TYPE (z, scm_tc16_real);
SCM_REAL_VALUE (z) = val;
else if (SCM_NUMBERP (x))
return SCM_BOOL_T;
else
- SCM_WTA_DISPATCH_1 (g_scm_exact_p, x, 1, s_scm_exact_p);
+ return scm_wta_dispatch_1 (g_scm_exact_p, x, 1, s_scm_exact_p);
}
#undef FUNC_NAME
else if (SCM_NUMBERP (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p);
+ return scm_wta_dispatch_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p);
}
#undef FUNC_NAME
return SCM_BOOL_F;
}
}
- SCM_WTA_DISPATCH_1 (g_scm_odd_p, n, 1, s_scm_odd_p);
+ return scm_wta_dispatch_1 (g_scm_odd_p, n, 1, s_scm_odd_p);
}
#undef FUNC_NAME
return SCM_BOOL_T;
}
}
- SCM_WTA_DISPATCH_1 (g_scm_even_p, n, 1, s_scm_even_p);
+ return scm_wta_dispatch_1 (g_scm_even_p, n, 1, s_scm_even_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_T;
else
- SCM_WTA_DISPATCH_1 (g_scm_finite_p, x, 1, s_scm_finite_p);
+ return scm_wta_dispatch_1 (g_scm_finite_p, x, 1, s_scm_finite_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_inf_p, x, 1, s_scm_inf_p);
+ return scm_wta_dispatch_1 (g_scm_inf_p, x, 1, s_scm_inf_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_nan_p, x, 1, s_scm_nan_p);
+ return scm_wta_dispatch_1 (g_scm_nan_p, x, 1, s_scm_nan_p);
}
#undef FUNC_NAME
SCM_FRACTION_DENOMINATOR (x));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs);
+ return scm_wta_dispatch_1 (g_scm_abs, x, 1, s_scm_abs);
}
#undef FUNC_NAME
if (SCM_LIKELY (scm_is_integer (y)))
return scm_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
+ return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient);
+ return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient);
}
#undef FUNC_NAME
if (SCM_LIKELY (scm_is_integer (y)))
return scm_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
+ return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder);
+ return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder);
}
#undef FUNC_NAME
if (SCM_LIKELY (scm_is_integer (y)))
return scm_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
+ return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo);
+ return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo);
}
#undef FUNC_NAME
two_valued_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos,
const char *subr, SCM *rp1, SCM *rp2)
{
- if (SCM_UNPACK (gf))
- scm_i_extract_values_2 (scm_call_generic_2 (gf, a1, a2), rp1, rp2);
- else
- scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
+ SCM vals = scm_wta_dispatch_2 (gf, a1, a2, pos, subr);
+
+ scm_i_extract_values_2 (vals, rp1, rp2);
}
SCM_DEFINE (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_floor_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
+ s_scm_floor_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_floor_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
+ s_scm_floor_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_ceiling_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
+ s_scm_ceiling_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_ceiling_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
+ s_scm_ceiling_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_truncate_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
+ s_scm_truncate_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_truncate_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
+ s_scm_truncate_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_centered_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
+ s_scm_centered_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_centered_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
+ s_scm_centered_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_round_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG1,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG1,
+ s_scm_round_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_round_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG1,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG1,
+ s_scm_round_remainder);
}
#undef FUNC_NAME
else if (SCM_REALP (y) && scm_is_integer (y))
goto handle_inexacts;
else
- SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
else if (SCM_BIGP (x))
{
else if (SCM_REALP (y) && scm_is_integer (y))
goto handle_inexacts;
else
- SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
else if (SCM_REALP (x) && scm_is_integer (x))
{
scm_inexact_to_exact (y)));
}
else
- SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
else
- SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
+ return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
}
SCM_PRIMITIVE_GENERIC (scm_i_lcm, "lcm", 0, 2, 1,
else if (SCM_REALP (n2) && scm_is_integer (n2))
goto handle_inexacts;
else
- SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
else if (SCM_LIKELY (SCM_BIGP (n1)))
{
else if (SCM_REALP (n2) && scm_is_integer (n2))
goto handle_inexacts;
else
- SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
else if (SCM_REALP (n1) && scm_is_integer (n1))
{
scm_inexact_to_exact (n2)));
}
else
- SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
else
- SCM_WTA_DISPATCH_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
}
/* Emulating 2's complement bignums with sign magnitude arithmetic:
scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
return !0;
}
scm_i_print_double (double val, SCM port)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, idbl2str (val, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, idbl2str (val, num_buf, 10), port);
}
int
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
return !0;
}
scm_i_print_complex (double real, double imag, SCM port)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, icmplx2str (real, imag, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, icmplx2str (real, imag, num_buf, 10), port);
}
int
void (*freefunc) (void *, size_t);
mp_get_memory_functions (NULL, NULL, &freefunc);
scm_remember_upto_here_1 (exp);
- scm_lfwrite (str, len, port);
+ scm_lfwrite_unlocked (str, len, port);
freefunc (str, len + 1);
return !0;
}
static unsigned int
char_decimal_value (scm_t_uint32 c)
{
- /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
- that's certainly above any valid decimal, so we take advantage of
- that to elide some tests. */
- unsigned int d = (unsigned int) uc_decimal_value (c);
-
- /* If that failed, try extended hexadecimals, then. Only accept ascii
- hexadecimals. */
- if (d >= 10U)
+ if (c >= (scm_t_uint32) '0' && c <= (scm_t_uint32) '9')
+ return c - (scm_t_uint32) '0';
+ else
{
- c = uc_tolower (c);
- if (c >= (scm_t_uint32) 'a')
- d = c - (scm_t_uint32)'a' + 10U;
+ /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
+ that's certainly above any valid decimal, so we take advantage of
+ that to elide some tests. */
+ unsigned int d = (unsigned int) uc_decimal_value (c);
+
+ /* If that failed, try extended hexadecimals, then. Only accept ascii
+ hexadecimals. */
+ if (d >= 10U)
+ {
+ c = uc_tolower (c);
+ if (c >= (scm_t_uint32) 'a')
+ d = c - (scm_t_uint32)'a' + 10U;
+ }
+ return d;
}
- return d;
}
/* Parse the substring of MEM starting at *P_IDX for an unsigned integer
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return 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_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return 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_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return 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_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return 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_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return 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_scm_i_num_eq_p, x, y, SCM_ARG1, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1,
+ s_scm_i_num_eq_p);
}
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return 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_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return 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_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return 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_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return 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_scm_i_num_less_p, x, y, SCM_ARG1, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARG1,
+ s_scm_i_num_less_p);
}
scm_gr_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
+ return 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_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
else
return scm_less_p (y, x);
}
scm_leq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
+ return 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_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
+ return 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
scm_geq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
+ return 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_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
+ return 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
else if (SCM_FRACTIONP (z))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p);
+ return scm_wta_dispatch_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (x))
return scm_positive_p (SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p);
+ return scm_wta_dispatch_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (x))
return scm_negative_p (SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p);
+ return scm_wta_dispatch_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p);
}
#undef FUNC_NAME
if (SCM_UNBNDP (y))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_max, s_max);
+ return scm_wta_dispatch_0 (g_max, s_max);
else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);
+ return scm_wta_dispatch_1 (g_max, x, SCM_ARG1, s_max);
}
if (SCM_I_INUMP (x))
return (scm_is_false (scm_less_p (x, y)) ? x : y);
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_BIGP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_REALP (x))
{
return (xx < yy) ? scm_i_from_double (yy) : x;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_FRACTIONP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARG1, s_max);
}
if (SCM_UNBNDP (y))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_min, s_min);
+ return scm_wta_dispatch_0 (g_min, s_min);
else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);
+ return scm_wta_dispatch_1 (g_min, x, SCM_ARG1, s_min);
}
if (SCM_I_INUMP (x))
return (scm_is_false (scm_less_p (x, y)) ? y : x);
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_BIGP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_REALP (x))
{
return (yy < xx) ? scm_i_from_double (yy) : x;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_FRACTIONP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return 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);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARG1, s_min);
}
{
if (SCM_NUMBERP (x)) return x;
if (SCM_UNBNDP (x)) return SCM_INUM0;
- SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum);
+ return scm_wta_dispatch_1 (g_sum, x, SCM_ARG1, s_sum);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
} else if (SCM_BIGP (x))
{
if (SCM_I_INUMP (y))
scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_from_double (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_COMPLEXP (x))
{
return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y),
SCM_COMPLEX_IMAG (x));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARG1, s_sum);
}
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_difference, s_difference);
+ return scm_wta_dispatch_0 (g_difference, s_difference);
else
if (SCM_I_INUMP (x))
{
(scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
+ return scm_wta_dispatch_1 (g_difference, x, SCM_ARG1, s_difference);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_BIGP (x))
{
return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
- else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ else
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_from_double (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_COMPLEXP (x))
{
return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y),
SCM_COMPLEX_IMAG (x));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARG1, s_difference);
}
#undef FUNC_NAME
else if (SCM_NUMBERP (x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);
+ return scm_wta_dispatch_1 (g_product, x, SCM_ARG1, s_product);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
else if (SCM_NUMP (y))
return SCM_INUM0;
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
break;
case -1:
/*
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_BIGP (x))
{
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_from_double (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_COMPLEXP (x))
{
yy * SCM_COMPLEX_IMAG (x));
}
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_DENOMINATOR (x),
SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARG1, s_product);
}
#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_divide, s_divide);
+ return scm_wta_dispatch_0 (g_divide, s_divide);
else if (SCM_I_INUMP (x))
{
scm_t_inum xx = SCM_I_INUM (x);
return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x),
SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
+ return scm_wta_dispatch_1 (g_divide, x, SCM_ARG1, s_divide);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_BIGP (x))
{
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_from_double (rx / scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_COMPLEXP (x))
{
return scm_c_make_rectangular (rx / yy, ix / yy);
}
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_FRACTIONP (x))
{
return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARG1, s_divide);
}
#undef FUNC_NAME
return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_truncate_number, x, SCM_ARG1,
+ return scm_wta_dispatch_1 (g_scm_truncate_number, x, SCM_ARG1,
s_scm_truncate_number);
}
#undef FUNC_NAME
return scm_round_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_round_number, x, SCM_ARG1,
- s_scm_round_number);
+ return scm_wta_dispatch_1 (g_scm_round_number, x, SCM_ARG1,
+ s_scm_round_number);
}
#undef FUNC_NAME
return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor);
+ return scm_wta_dispatch_1 (g_scm_floor, x, 1, s_scm_floor);
}
#undef FUNC_NAME
return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
+ return scm_wta_dispatch_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
}
#undef FUNC_NAME
else if (scm_is_complex (x) && scm_is_complex (y))
return scm_exp (scm_product (scm_log (x), y));
else if (scm_is_complex (x))
- SCM_WTA_DISPATCH_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt);
+ return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt);
else
- SCM_WTA_DISPATCH_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt);
+ return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt);
}
#undef FUNC_NAME
cos (x) * sinh (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sin, z, 1, s_scm_sin);
+ return scm_wta_dispatch_1 (g_scm_sin, z, 1, s_scm_sin);
}
#undef FUNC_NAME
-sin (x) * sinh (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_cos, z, 1, s_scm_cos);
+ return scm_wta_dispatch_1 (g_scm_cos, z, 1, s_scm_cos);
}
#undef FUNC_NAME
return scm_c_make_rectangular (sin (x) / w, sinh (y) / w);
}
else
- SCM_WTA_DISPATCH_1 (g_scm_tan, z, 1, s_scm_tan);
+ return scm_wta_dispatch_1 (g_scm_tan, z, 1, s_scm_tan);
}
#undef FUNC_NAME
cosh (x) * sin (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sinh, z, 1, s_scm_sinh);
+ return scm_wta_dispatch_1 (g_scm_sinh, z, 1, s_scm_sinh);
}
#undef FUNC_NAME
sinh (x) * sin (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_cosh, z, 1, s_scm_cosh);
+ return scm_wta_dispatch_1 (g_scm_cosh, z, 1, s_scm_cosh);
}
#undef FUNC_NAME
return scm_c_make_rectangular (sinh (x) / w, sin (y) / w);
}
else
- SCM_WTA_DISPATCH_1 (g_scm_tanh, z, 1, s_scm_tanh);
+ return scm_wta_dispatch_1 (g_scm_tanh, z, 1, s_scm_tanh);
}
#undef FUNC_NAME
scm_sys_asinh (scm_c_make_rectangular (-y, x)));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_asin, z, 1, s_scm_asin);
+ return scm_wta_dispatch_1 (g_scm_asin, z, 1, s_scm_asin);
}
#undef FUNC_NAME
scm_sys_asinh (scm_c_make_rectangular (-y, x))));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_acos, z, 1, s_scm_acos);
+ return scm_wta_dispatch_1 (g_scm_acos, z, 1, s_scm_acos);
}
#undef FUNC_NAME
scm_c_make_rectangular (0, 2));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
+ return scm_wta_dispatch_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
}
else if (scm_is_real (z))
{
if (scm_is_real (y))
return scm_i_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);
+ return 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);
+ return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
}
#undef FUNC_NAME
scm_sqrt (scm_sum (scm_product (z, z),
SCM_INUM1))));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
+ return scm_wta_dispatch_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
}
#undef FUNC_NAME
scm_sqrt (scm_difference (scm_product (z, z),
SCM_INUM1))));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
+ return scm_wta_dispatch_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
}
#undef FUNC_NAME
scm_difference (SCM_INUM1, z))),
SCM_I_MAKINUM (2));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
+ return scm_wta_dispatch_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
}
#undef FUNC_NAME
{
SCM z;
- z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
+ z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
"complex"));
SCM_SET_CELL_TYPE (z, scm_tc16_complex);
SCM_COMPLEX_REAL (z) = re;
else if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_REALP (z) || SCM_FRACTIONP (z))
return z;
else
- SCM_WTA_DISPATCH_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part);
+ return scm_wta_dispatch_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part);
}
#undef FUNC_NAME
else if (SCM_I_INUMP (z) || SCM_REALP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z))
return SCM_INUM0;
else
- SCM_WTA_DISPATCH_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part);
+ return scm_wta_dispatch_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part);
}
#undef FUNC_NAME
return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
+ return scm_wta_dispatch_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
}
#undef FUNC_NAME
return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_denominator, z, SCM_ARG1, s_scm_denominator);
+ return scm_wta_dispatch_1 (g_scm_denominator, z, SCM_ARG1,
+ s_scm_denominator);
}
#undef FUNC_NAME
SCM_FRACTION_DENOMINATOR (z));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_magnitude, z, SCM_ARG1, s_scm_magnitude);
+ return scm_wta_dispatch_1 (g_scm_magnitude, z, SCM_ARG1,
+ s_scm_magnitude);
}
#undef FUNC_NAME
else return scm_i_from_double (atan2 (0.0, -1.0));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
+ return scm_wta_dispatch_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
}
#undef FUNC_NAME
else if (SCM_INEXACTP (z))
return z;
else
- SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact, z, 1, s_scm_exact_to_inexact);
+ return scm_wta_dispatch_1 (g_scm_exact_to_inexact, z, 1,
+ s_scm_exact_to_inexact);
}
#undef FUNC_NAME
else if (SCM_COMPLEXP (z) && SCM_COMPLEX_IMAG (z) == 0.0)
val = SCM_COMPLEX_REAL (z);
else
- SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact, z, 1, s_scm_inexact_to_exact);
+ return scm_wta_dispatch_1 (g_scm_inexact_to_exact, z, 1,
+ s_scm_inexact_to_exact);
if (!SCM_LIKELY (isfinite (val)))
SCM_OUT_OF_RANGE (1, z);
return scm_i_from_double (val);
}
-#if SCM_ENABLE_DEPRECATED == 1
-
-float
-scm_num2float (SCM num, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2float' is deprecated. Use scm_to_double instead.");
-
- if (SCM_BIGP (num))
- {
- float res = mpz_get_d (SCM_I_BIG_MPZ (num));
- if (!isinf (res))
- return res;
- else
- scm_out_of_range (NULL, num);
- }
- else
- return scm_to_double (num);
-}
-
-double
-scm_num2double (SCM num, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2double' is deprecated. Use scm_to_double instead.");
-
- if (SCM_BIGP (num))
- {
- double res = mpz_get_d (SCM_I_BIG_MPZ (num));
- if (!isinf (res))
- return res;
- else
- scm_out_of_range (NULL, num);
- }
- else
- return scm_to_double (num);
-}
-
-#endif
-
int
scm_is_complex (SCM val)
{
return log_of_fraction (SCM_FRACTION_NUMERATOR (z),
SCM_FRACTION_DENOMINATOR (z));
else
- SCM_WTA_DISPATCH_1 (g_scm_log, z, 1, s_scm_log);
+ return scm_wta_dispatch_1 (g_scm_log, z, 1, s_scm_log);
}
#undef FUNC_NAME
log_of_fraction (SCM_FRACTION_NUMERATOR (z),
SCM_FRACTION_DENOMINATOR (z)));
else
- SCM_WTA_DISPATCH_1 (g_scm_log10, z, 1, s_scm_log10);
+ return scm_wta_dispatch_1 (g_scm_log10, z, 1, s_scm_log10);
}
#undef FUNC_NAME
return scm_i_from_double (exp (scm_to_double (z)));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_exp, z, 1, s_scm_exp);
+ return scm_wta_dispatch_1 (g_scm_exp, z, 1, s_scm_exp);
}
#undef FUNC_NAME
}
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
+ return scm_wta_dispatch_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
}
#undef FUNC_NAME
#define SCM_INEXACTP(x) \
(!SCM_IMP (x) && (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real)
-#define SCM_REALP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_real)
-#define SCM_COMPLEXP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_complex)
+#define SCM_REALP(x) (SCM_HAS_TYP16 (x, scm_tc16_real))
+#define SCM_COMPLEXP(x) (SCM_HAS_TYP16 (x, scm_tc16_complex))
#define SCM_REAL_VALUE(x) (((scm_t_double *) SCM2PTR (x))->real)
#define SCM_COMPLEX_REAL(x) (((scm_t_complex *) SCM2PTR (x))->real)
/* Each bignum is just an mpz_t stored in a double cell starting at word 1. */
#define SCM_I_BIG_MPZ(x) (*((mpz_t *) (SCM_CELL_OBJECT_LOC((x),1))))
-#define SCM_BIGP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_big)
+#define SCM_BIGP(x) (SCM_HAS_TYP16 (x, scm_tc16_big))
#define SCM_NUMBERP(x) (SCM_I_INUMP(x) || SCM_NUMP(x))
-#define SCM_NUMP(x) (!SCM_IMP(x) \
- && ((0x00ff & SCM_CELL_TYPE (x)) == scm_tc7_number))
+#define SCM_NUMP(x) (SCM_HAS_TYP7 (x, scm_tc7_number))
-#define SCM_FRACTIONP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_fraction)
+#define SCM_FRACTIONP(x) (SCM_HAS_TYP16 (x, scm_tc16_fraction))
#define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x))
#define SCM_FRACTION_DENOMINATOR(x) (SCM_CELL_OBJECT_2 (x))
#endif
#endif
+#if SCM_SIZEOF_INTPTR_T == 0
+/* No intptr_t; use size_t functions. */
+#define scm_to_intptr_t scm_to_ssize_t
+#define scm_from_intptr_t scm_from_ssize_t
+#elif SCM_SIZEOF_INTPTR_T == 4
+#define scm_to_intptr_t scm_to_int32
+#define scm_from_intptr_t scm_from_int32
+#elif SCM_SIZEOF_INTPTR_T == 8
+#define scm_to_intptr_t scm_to_int64
+#define scm_from_intptr_t scm_from_int64
+#else
+#error sizeof(intptr_t) is not 4 or 8.
+#endif
+
+#if SCM_SIZEOF_UINTPTR_T == 0
+/* No uintptr_t; use size_t functions. */
+#define scm_to_uintptr_t scm_to_size_t
+#define scm_from_uintptr_t scm_from_size_t
+#elif SCM_SIZEOF_UINTPTR_T == 4
+#define scm_to_uintptr_t scm_to_uint32
+#define scm_from_uintptr_t scm_from_uint32
+#elif SCM_SIZEOF_UINTPTR_T == 8
+#define scm_to_uintptr_t scm_to_uint64
+#define scm_from_uintptr_t scm_from_uint64
+#else
+#error sizeof(uintptr_t) is not 4 or 8.
+#endif
+
/* conversion functions for double */
SCM_API int scm_is_real (SCM val);
+++ /dev/null
-/* Copyright (C) 2001, 2009, 2010, 2011, 2013 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 <string.h>
-#include <fcntl.h>
-#include <unistd.h>
-
-#ifdef HAVE_SYS_MMAN_H
-#include <sys/mman.h>
-#endif
-
-#include <sys/stat.h>
-#include <sys/types.h>
-#include <assert.h>
-#include <alignof.h>
-#include <byteswap.h>
-
-#include <full-read.h>
-
-#include "_scm.h"
-#include "programs.h"
-#include "objcodes.h"
-
-/* SCM_OBJCODE_COOKIE, defined in _scm.h, is a magic value prepended
- to objcode on disk but not in memory.
-
- The length of the header must be a multiple of 8 bytes. */
-verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
-
-/* Endianness and word size of the compilation target. */
-static SCM target_endianness_var = SCM_BOOL_F;
-static SCM target_word_size_var = SCM_BOOL_F;
-
-\f
-/*
- * Objcode type
- */
-
-/* Endianness of the build machine. */
-#ifdef WORDS_BIGENDIAN
-# define NATIVE_ENDIANNESS 'B'
-#else
-# define NATIVE_ENDIANNESS 'L'
-#endif
-
-/* Return the endianness of the compilation target. */
-static char
-target_endianness (void)
-{
- if (scm_is_true (target_endianness_var))
- return scm_is_eq (scm_call_0 (scm_variable_ref (target_endianness_var)),
- scm_endianness_big) ? 'B' : 'L';
- else
- return NATIVE_ENDIANNESS;
-}
-
-/* Return the word size in bytes of the compilation target. */
-static size_t
-target_word_size (void)
-{
- if (scm_is_true (target_word_size_var))
- return scm_to_size_t (scm_call_0
- (scm_variable_ref (target_word_size_var)));
- else
- return sizeof (void *);
-}
-
-/* Convert X, which is in byte order ENDIANNESS, to its native
- representation. */
-static inline uint32_t
-to_native_order (uint32_t x, char endianness)
-{
- if (endianness == NATIVE_ENDIANNESS)
- return x;
- else
- return bswap_32 (x);
-}
-
-static void
-verify_cookie (char *cookie, struct stat *st, int map_fd, void *map_addr)
-#define FUNC_NAME "make_objcode_from_file"
-{
- /* The cookie ends with a version of the form M.N, where M is the
- major version and N is the minor version. For this Guile to be
- able to load an objcode, M must be SCM_OBJCODE_MAJOR_VERSION, and N
- must be less than or equal to SCM_OBJCODE_MINOR_VERSION. Since N
- is the last character, we do a strict comparison on all but the
- last, then a <= on the last one. */
- if (memcmp (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE) - 1))
- {
- SCM args = scm_list_1 (scm_from_latin1_stringn
- (cookie, strlen (SCM_OBJCODE_COOKIE)));
- if (map_fd >= 0)
- {
- (void) close (map_fd);
-#ifdef HAVE_SYS_MMAN_H
- (void) munmap (map_addr, st->st_size);
-#endif
- }
- scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
- }
-
- {
- char minor_version = cookie[strlen (SCM_OBJCODE_COOKIE) - 1];
-
- if (minor_version > SCM_OBJCODE_MINOR_VERSION_STRING[0])
- {
- if (map_fd >= 0)
- {
- (void) close (map_fd);
-#ifdef HAVE_SYS_MMAN_H
- (void) munmap (map_addr, st->st_size);
-#endif
- }
-
- scm_misc_error (FUNC_NAME, "objcode minor version too new (~a > ~a)",
- scm_list_2 (scm_from_latin1_stringn (&minor_version, 1),
- scm_from_latin1_string
- (SCM_OBJCODE_MINOR_VERSION_STRING)));
- }
- }
-}
-#undef FUNC_NAME
-
-/* The words in an objcode SCM object are as follows:
- - scm_tc7_objcode | type | flags
- - the struct scm_objcode C object
- - the parent of this objcode: either another objcode, a bytevector,
- or, in the case of mmap types, #f
- - "native code" -- not currently used.
- */
-
-static SCM
-make_objcode_from_file (int fd)
-#define FUNC_NAME "make_objcode_from_file"
-{
- int ret;
- /* The SCM_OBJCODE_COOKIE is a string literal, and thus has an extra
- trailing NUL, hence the - 1. */
- char cookie[sizeof (SCM_OBJCODE_COOKIE) - 1];
- struct stat st;
-
- ret = fstat (fd, &st);
- if (ret < 0)
- SCM_SYSERROR;
-
- if (st.st_size <= sizeof (struct scm_objcode) + sizeof cookie)
- scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
- scm_list_1 (SCM_I_MAKINUM (st.st_size)));
-
-#ifdef HAVE_SYS_MMAN_H
- {
- char *addr;
- struct scm_objcode *data;
-
- addr = mmap (0, st.st_size, PROT_READ, MAP_PRIVATE, fd, 0);
-
- if (addr == MAP_FAILED)
- {
- int errno_save = errno;
- (void) close (fd);
- errno = errno_save;
- SCM_SYSERROR;
- }
- else
- {
- memcpy (cookie, addr, sizeof cookie);
- data = (struct scm_objcode *) (addr + sizeof cookie);
- }
-
- verify_cookie (cookie, &st, fd, addr);
-
-
- if (data->len + data->metalen
- != (st.st_size - sizeof (*data) - sizeof cookie))
- {
- size_t total_len = sizeof (*data) + data->len + data->metalen;
-
- (void) close (fd);
- (void) munmap (addr, st.st_size);
-
- scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
- scm_list_2 (scm_from_size_t (st.st_size),
- scm_from_size_t (total_len)));
- }
-
- (void) close (fd);
- return scm_permanent_object
- (scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_MMAP, 0),
- (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
- SCM_BOOL_F_BITS, 0));
- }
-#else
- {
- SCM bv = scm_c_make_bytevector (st.st_size - sizeof cookie);
-
- if (full_read (fd, cookie, sizeof cookie) != sizeof cookie
- || full_read (fd, SCM_BYTEVECTOR_CONTENTS (bv),
- SCM_BYTEVECTOR_LENGTH (bv)) != SCM_BYTEVECTOR_LENGTH (bv))
- {
- int errno_save = errno;
- (void) close (fd);
- errno = errno_save;
- if (errno)
- SCM_SYSERROR;
- scm_misc_error (FUNC_NAME, "file truncated while reading", SCM_EOL);
- }
-
- (void) close (fd);
-
- verify_cookie (cookie, &st, -1, NULL);
-
- return scm_bytecode_to_native_objcode (bv);
- }
-#endif
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr)
-#define FUNC_NAME "make-objcode-slice"
-{
- const struct scm_objcode *data, *parent_data;
- const scm_t_uint8 *parent_base;
-
- SCM_VALIDATE_OBJCODE (1, parent);
- parent_data = SCM_OBJCODE_DATA (parent);
- parent_base = SCM_C_OBJCODE_BASE (parent_data);
-
- if (ptr < parent_base
- || ptr >= (parent_base + parent_data->len + parent_data->metalen
- - sizeof (struct scm_objcode)))
- scm_misc_error
- (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
- scm_list_4 (scm_from_unsigned_integer ((scm_t_bits) ptr),
- scm_from_unsigned_integer ((scm_t_bits) parent_base),
- scm_from_uint32 (parent_data->len),
- scm_from_uint32 (parent_data->metalen)));
-
- /* 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_type (struct scm_objcode) - 1UL)) == 0);
-
- data = (struct scm_objcode*) ptr;
- assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen
- <= parent_base + parent_data->len + parent_data->metalen);
-
- return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_SLICE, 0),
- (scm_t_bits)data, SCM_UNPACK (parent), 0);
-}
-#undef FUNC_NAME
-
-\f
-/*
- * Scheme interface
- */
-
-SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
- (SCM obj),
- "")
-#define FUNC_NAME s_scm_objcode_p
-{
- return scm_from_bool (SCM_OBJCODE_P (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0,
- (SCM objcode),
- "")
-#define FUNC_NAME s_scm_objcode_meta
-{
- SCM_VALIDATE_OBJCODE (1, objcode);
-
- if (SCM_OBJCODE_META_LEN (objcode) == 0)
- return SCM_BOOL_F;
- else
- return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
- + SCM_OBJCODE_LEN (objcode)));
-}
-#undef FUNC_NAME
-
-/* Turn BYTECODE into objcode encoded for ENDIANNESS and WORD_SIZE. */
-static SCM
-bytecode_to_objcode (SCM bytecode, char endianness, size_t word_size)
-#define FUNC_NAME "bytecode->objcode"
-{
- size_t size, len, metalen;
- const scm_t_uint8 *c_bytecode;
- struct scm_objcode *data;
-
- if (!scm_is_bytevector (bytecode))
- scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
-
- size = SCM_BYTEVECTOR_LENGTH (bytecode);
- c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
-
- SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
- data = (struct scm_objcode*)c_bytecode;
-
- len = to_native_order (data->len, endianness);
- metalen = to_native_order (data->metalen, endianness);
-
- if (len + metalen != (size - sizeof (*data)))
- scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
- scm_list_2 (scm_from_size_t (size),
- scm_from_uint32 (sizeof (*data) + len + metalen)));
-
- /* foolishly, we assume that as long as bytecode is around, that c_bytecode
- will be of the same length; perhaps a bad assumption? */
- return scm_double_cell (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_BYTEVECTOR, 0),
- (scm_t_bits)data, SCM_UNPACK (bytecode), 0);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
- (SCM bytecode),
- "")
-#define FUNC_NAME s_scm_bytecode_to_objcode
-{
- /* Assume we're called from Scheme, which known that to do with
- `target-type'. */
- return bytecode_to_objcode (bytecode, target_endianness (),
- target_word_size ());
-}
-#undef FUNC_NAME
-
-/* Like `bytecode->objcode', but ignore the `target-type' fluid. This
- is useful for native compilation that happens lazily---e.g., direct
- calls to this function from libguile itself. */
-SCM
-scm_bytecode_to_native_objcode (SCM bytecode)
-{
- return bytecode_to_objcode (bytecode, NATIVE_ENDIANNESS, sizeof (void *));
-}
-
-SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
- (SCM file),
- "")
-#define FUNC_NAME s_scm_load_objcode
-{
- int fd;
- char *c_file;
-
- SCM_VALIDATE_STRING (1, file);
-
- c_file = scm_to_locale_string (file);
- fd = open (c_file, O_RDONLY | O_BINARY | O_CLOEXEC);
- free (c_file);
- if (fd < 0) SCM_SYSERROR;
-
- return make_objcode_from_file (fd);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
- (SCM objcode),
- "")
-#define FUNC_NAME s_scm_objcode_to_bytecode
-{
- scm_t_int8 *s8vector;
- scm_t_uint32 len;
-
- SCM_VALIDATE_OBJCODE (1, objcode);
-
- len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
-
- s8vector = scm_gc_malloc_pointerless (len, FUNC_NAME);
- memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len);
-
- return scm_c_take_gc_bytevector (s8vector, len);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
- (SCM objcode, SCM port),
- "")
-#define FUNC_NAME s_scm_write_objcode
-{
- char cookie[sizeof (SCM_OBJCODE_COOKIE) - 1];
- char endianness, word_size;
- size_t total_size;
-
- SCM_VALIDATE_OBJCODE (1, objcode);
- SCM_VALIDATE_OUTPUT_PORT (2, port);
- endianness = target_endianness ();
- switch (target_word_size ())
- {
- case 4:
- word_size = '4';
- break;
- case 8:
- word_size = '8';
- break;
- default:
- abort ();
- }
-
- memcpy (cookie, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
- cookie[SCM_OBJCODE_ENDIANNESS_OFFSET] = endianness;
- cookie[SCM_OBJCODE_WORD_SIZE_OFFSET] = word_size;
-
- total_size =
- to_native_order (SCM_OBJCODE_LEN (objcode), target_endianness ())
- + to_native_order (SCM_OBJCODE_META_LEN (objcode), target_endianness ());
-
- scm_c_write (port, cookie, strlen (SCM_OBJCODE_COOKIE));
- scm_c_write (port, SCM_OBJCODE_DATA (objcode),
- sizeof (struct scm_objcode) + total_size);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-void
-scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
-{
- scm_puts ("#<objcode ", port);
- scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
- scm_puts (">", port);
-}
-
-\f
-void
-scm_bootstrap_objcodes (void)
-{
- scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
- "scm_init_objcodes",
- (scm_t_extension_init_func)scm_init_objcodes, NULL);
-}
-
-/* Before, we used __BYTE_ORDER, but that is not defined on all
- systems. So punt and use automake, PDP endianness be damned. */
-#ifdef WORDS_BIGENDIAN
-#define SCM_BYTE_ORDER 4321
-#else
-#define SCM_BYTE_ORDER 1234
-#endif
-
-void
-scm_init_objcodes (void)
-{
-#ifndef SCM_MAGIC_SNARFER
-#include "libguile/objcodes.x"
-#endif
-
- scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
- scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
-
- target_endianness_var = scm_c_public_variable ("system base target",
- "target-endianness");
- target_word_size_var = scm_c_public_variable ("system base target",
- "target-word-size");
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+++ /dev/null
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public 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_OBJCODES_H_
-#define _SCM_OBJCODES_H_
-
-#include <libguile.h>
-
-/* Objcode data should be directly mappable to this C structure. */
-struct scm_objcode
-{
- 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 */
- /* In C99, we'd have:
- scm_t_uint8 base[]; */
-};
-
-/* Return a pointer to the base of objcode OBJ. */
-#define SCM_C_OBJCODE_BASE(obj) \
- ((scm_t_uint8 *)(obj) + sizeof (struct scm_objcode))
-
-#define SCM_OBJCODE_TYPE_MMAP (0)
-#define SCM_OBJCODE_TYPE_BYTEVECTOR (1)
-#define SCM_OBJCODE_TYPE_SLICE (2)
-#define SCM_OBJCODE_TYPE_STATIC (3)
-
-#define SCM_OBJCODE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_objcode)
-#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_CELL_WORD_1 (x))
-#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
-
-#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_BASE(x) (SCM_C_OBJCODE_BASE (SCM_OBJCODE_DATA (x)))
-
-#define SCM_MAKE_OBJCODE_TAG(type, flags) (scm_tc7_objcode | (type << 8) | (flags << 16))
-#define SCM_OBJCODE_TYPE(x) ((SCM_CELL_WORD_0 (x) >> 8) & 0xff)
-#define SCM_OBJCODE_FLAGS(x) (SCM_CELL_WORD_0 (x) >> 16)
-#define SCM_OBJCODE_IS_MMAP(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_MMAP)
-#define SCM_OBJCODE_IS_BYTEVECTOR(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_BYTEVECTOR)
-#define SCM_OBJCODE_IS_SLICE(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_SLICE)
-#define SCM_OBJCODE_IS_STATIC(x) (SCM_OBJCODE_TYPE (x) == SCM_OBJCODE_TYPE_STATIC)
-
-#define SCM_OBJCODE_NATIVE_CODE(x) (SCM_CELL_WORD_3 (x))
-#define SCM_SET_OBJCODE_NATIVE_CODE(x, code) (SCM_SET_CELL_WORD_3 (x, code))
-
-SCM_API SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
-SCM_API SCM scm_load_objcode (SCM file);
-SCM_API SCM scm_objcode_p (SCM obj);
-SCM_API SCM scm_objcode_meta (SCM objcode);
-SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
-SCM_INTERNAL SCM scm_bytecode_to_native_objcode (SCM bytecode);
-SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
-SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
-
-SCM_INTERNAL void scm_i_objcode_print (SCM objcode, SCM port,
- scm_print_state *pstate);
-SCM_INTERNAL void scm_bootstrap_objcodes (void);
-SCM_INTERNAL void scm_init_objcodes (void);
-
-#endif /* _SCM_OBJCODES_H_ */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
#include "libguile/hashtab.h"
#include "libguile/alist.h"
#include "libguile/root.h"
-#include "libguile/weaks.h"
#include "libguile/objprop.h"
\f
*/
static SCM object_whash;
-static scm_i_pthread_mutex_t whash_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
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
{
- SCM ret;
-
- scm_i_pthread_mutex_lock (&whash_mutex);
- ret = scm_hashq_ref (object_whash, obj, SCM_EOL);
- scm_i_pthread_mutex_unlock (&whash_mutex);
-
- return ret;
+ return scm_weak_table_refq (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_i_pthread_mutex_lock (&whash_mutex);
- scm_hashq_set_x (object_whash, obj, alist);
- scm_i_pthread_mutex_unlock (&whash_mutex);
+ scm_weak_table_putq_x (object_whash, obj, alist);
return alist;
}
{
SCM assoc;
assoc = scm_assq (key, scm_object_properties (obj));
- return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
+ return (scm_is_pair (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
#undef FUNC_NAME
SCM alist;
SCM assoc;
- scm_i_pthread_mutex_lock (&whash_mutex);
- alist = scm_hashq_ref (object_whash, obj, SCM_EOL);
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ alist = scm_weak_table_refq (object_whash, obj, SCM_EOL);
assoc = scm_assq (key, alist);
- if (SCM_NIMP (assoc))
+ if (scm_is_pair (assoc))
SCM_SETCDR (assoc, value);
else
- scm_hashq_set_x (object_whash, obj, scm_acons (key, value, alist));
- scm_i_pthread_mutex_unlock (&whash_mutex);
+ scm_weak_table_putq_x (object_whash, obj, scm_acons (key, value, alist));
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
return value;
}
void
scm_init_objprop ()
{
- object_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ object_whash = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
#include "libguile/objprop.x"
}
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010, 2011 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_SYMBOL (scm_yes_sym, "yes");
SCM_SYMBOL (scm_no_sym, "no");
-static SCM protected_objects = SCM_EOL;
-
/* Return a list of the current option setting. The format of an
* option setting is described in the above documentation. */
static SCM
for (i = 0; options[i].name; ++i)
{
- SCM ls = scm_cons (scm_from_locale_string (options[i].doc), SCM_EOL);
+ SCM ls = scm_cons (scm_from_utf8_string (options[i].doc), SCM_EOL);
switch (options[i].type)
{
case SCM_OPTION_BOOLEAN:
int dry_run)
{
unsigned int i;
- SCM locally_protected_args = args;
- SCM malloc_obj = scm_malloc_obj (options_length (options) * sizeof (scm_t_bits));
- scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj);
+ scm_t_bits *new_vals;
+
+ new_vals = scm_gc_malloc (options_length (options) * sizeof (scm_t_bits),
+ "new-options");
for (i = 0; options[i].name; ++i)
{
if (options[i].type == SCM_OPTION_BOOLEAN)
- flags[i] = 0;
+ new_vals[i] = 0;
else
- flags[i] = options[i].val;
+ new_vals[i] = options[i].val;
}
while (!SCM_NULL_OR_NIL_P (args))
switch (options[i].type)
{
case SCM_OPTION_BOOLEAN:
- flags[i] = 1;
+ new_vals[i] = 1;
break;
case SCM_OPTION_INTEGER:
args = SCM_CDR (args);
- flags[i] = scm_to_size_t (scm_car (args));
+ new_vals[i] = scm_to_size_t (scm_car (args));
break;
case SCM_OPTION_SCM:
args = SCM_CDR (args);
- flags[i] = SCM_UNPACK (scm_car (args));
+ new_vals[i] = SCM_UNPACK (scm_car (args));
break;
}
found = 1;
return;
for (i = 0; options[i].name; ++i)
- {
- if (options[i].type == SCM_OPTION_SCM)
- {
- SCM old = SCM_PACK (options[i].val);
- SCM new = SCM_PACK (flags[i]);
- if (!SCM_IMP (old))
- protected_objects = scm_delq1_x (old, protected_objects);
- if (!SCM_IMP (new))
- protected_objects = scm_cons (new, protected_objects);
- }
- options[i].val = flags[i];
- }
-
- scm_remember_upto_here_2 (locally_protected_args, malloc_obj);
+ options[i].val = new_vals[i];
}
for (i = 0; options[i].name; ++i)
{
- SCM name = scm_from_locale_symbol (options[i].name);
+ SCM name = scm_from_utf8_symbol (options[i].name);
options[i].name = (char *) SCM_UNPACK (name);
}
func (SCM_UNDEFINED);
void
scm_init_options ()
{
- scm_gc_register_root (&protected_objects);
-
#include "libguile/options.x"
}
/* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008, 2009,
- * 2011, 2013 Free Software Foundation, Inc.
+ * 2011, 2012, 2013 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_DEFINE (scm_cons, "cons", 2, 0, 0,
- (SCM x, SCM y),
- "Return a newly allocated pair whose car is @var{x} and whose\n"
- "cdr is @var{y}. The pair is guaranteed to be different (in the\n"
- "sense of @code{eq?}) from every previously existing object.")
-#define FUNC_NAME s_scm_cons
-{
- return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));
-}
-#undef FUNC_NAME
-
-
SCM
scm_cons2 (SCM w, SCM x, SCM y)
{
return tree
-SCM_DEFINE (scm_cdr, "cdr", 1, 0, 0, (SCM x), "")
-#define FUNC_NAME s_scm_cdr
-{
- CHASE_PAIRS (x, "cdr", 0x02); /* 00000010 */
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_car, "car", 1, 0, 0, (SCM x), "")
-#define FUNC_NAME s_scm_car
-{
- CHASE_PAIRS (x, "car", 0x03); /* 00000011 */
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_cddr, "cddr", 1, 0, 0, (SCM x), "")
#define FUNC_NAME s_scm_cddr
{
scm_init_pairs ()
{
#include "libguile/pairs.x"
+ scm_c_define_gsubr ("cons", 2, 0, 0, scm_cons);
+ scm_c_define_gsubr ("car", 1, 0, 0, scm_car);
+ scm_c_define_gsubr ("cdr", 1, 0, 0, scm_cdr);
}
#ifndef SCM_PAIRS_H
#define SCM_PAIRS_H
-/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008, 2009, 2010, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include "libguile/__scm.h"
+#include "libguile/gc.h"
+
\f
#if (SCM_DEBUG_PAIR_ACCESSES == 1)
SCM_API void scm_error_pair_access (SCM);
#endif
-SCM_API SCM scm_cons (SCM x, SCM y);
+SCM_INLINE int scm_is_pair (SCM x);
+SCM_INLINE SCM scm_cons (SCM x, SCM y);
+SCM_INLINE SCM scm_car (SCM x);
+SCM_INLINE SCM scm_cdr (SCM x);
+
+#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
+/* Return a newly allocated pair whose car is @var{x} and whose cdr is
+ @var{y}. The pair is guaranteed to be different (in the sense of
+ @code{eq?}) from every previously existing object. */
+SCM_INLINE_IMPLEMENTATION SCM
+scm_cons (SCM x, SCM y)
+{
+ return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));
+}
+
+SCM_INLINE_IMPLEMENTATION int
+scm_is_pair (SCM x)
+{
+ /* The following "workaround_for_gcc_295" avoids bad code generated by
+ i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least).
+
+ Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
+ the fetch of the tag word from x is done before confirming it's a
+ non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a
+ immediate. This was seen to afflict scm_srfi1_split_at and something
+ deep in the bowels of ceval(). In both cases segvs resulted from
+ deferencing a random immediate value. srfi-1.test exposes the problem
+ through a short list, the immediate being SCM_EOL in that case.
+ Something in syntax.test exposed the ceval() problem.
+
+ Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the
+ problem, without even using that variable. The "w=w" is just to
+ prevent a warning about it being unused.
+ */
+#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95
+ volatile SCM workaround_for_gcc_295 = x;
+ workaround_for_gcc_295 = workaround_for_gcc_295;
+#endif
+
+ return SCM_I_CONSP (x);
+}
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_car (SCM x)
+{
+ if (SCM_UNLIKELY (!scm_is_pair (x)))
+ scm_wrong_type_arg_msg ("car", 0, x, "pair");
+ return SCM_CAR (x);
+}
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_cdr (SCM x)
+{
+ if (SCM_UNLIKELY (!scm_is_pair (x)))
+ scm_wrong_type_arg_msg ("cdr", 0, x, "pair");
+ return SCM_CDR (x);
+}
+#endif
+
SCM_API SCM scm_cons2 (SCM w, SCM x, SCM y);
SCM_API SCM scm_pair_p (SCM x);
-SCM_API SCM scm_car (SCM x);
-SCM_API SCM scm_cdr (SCM x);
SCM_API SCM scm_set_car_x (SCM pair, SCM value);
SCM_API SCM scm_set_cdr_x (SCM pair, SCM value);
/*
* ports-internal.h - internal-only declarations for ports.
*
- * Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+ * Copyright (C) 2013 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
enum scm_port_encoding_mode {
SCM_PORT_ENCODING_MODE_UTF8,
+ SCM_PORT_ENCODING_MODE_LATIN1,
SCM_PORT_ENCODING_MODE_ICONV
};
typedef enum scm_port_encoding_mode scm_t_port_encoding_mode;
/* This is a separate object so that only those ports that use iconv
- cause finalizers to be registered (FIXME: although currently in 2.0
- finalizers are always registered for ports anyway). */
+ cause finalizers to be registered. */
struct scm_iconv_descriptors
{
/* input/output iconv conversion descriptors */
unsigned at_stream_start_for_bom_write : 1;
scm_t_port_encoding_mode encoding_mode;
scm_t_iconv_descriptors *iconv_descriptors;
- unsigned char pending_eof: 1;
-
- /* When non-NULL, this is the method called by 'setvbuf' for this port.
- It must create read and write buffers for PORT with the specified
- sizes (a size of 0 is for unbuffered ports, which should use the
- 'shortbuf' field.) Size -1 means to use the port's preferred buffer
- size. */
- /* XXX: In 2.2 make this a property of the 'scm_t_ptob_descriptor'. */
- void (*setvbuf) (SCM port, long read_size, long write_size);
-
- /* Key-value properties. */
+ int pending_eof;
SCM alist;
};
#define SCM_UNICODE_BOM 0xFEFFUL /* Unicode byte-order mark */
-#define SCM_PORT_GET_INTERNAL(x) \
- ((scm_t_port_internal *) (SCM_PTAB_ENTRY(x)->input_cd))
+#define SCM_PORT_GET_INTERNAL(x) (SCM_PTAB_ENTRY(x)->internal)
SCM_INTERNAL scm_t_iconv_descriptors *
scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode);
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
* 2007, 2008, 2009, 2010, 2011, 2012, 2013,
- * 2014, 2015 Free Software Foundation, Inc.
+ * 2014 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 <uniconv.h>
#include <unistr.h>
#include <striconveh.h>
-#include <c-strcase.h>
#include <assert.h>
#include "libguile/ports.h"
#include "libguile/ports-internal.h"
#include "libguile/vectors.h"
-#include "libguile/weaks.h"
+#include "libguile/weak-set.h"
#include "libguile/fluids.h"
#include "libguile/eq.h"
#include "libguile/alist.h"
#endif
\f
+/* Port encodings are case-insensitive ASCII strings. */
+static char
+ascii_toupper (char c)
+{
+ return (c < 'a' || c > 'z') ? c : ('A' + (c - 'a'));
+}
+
+/* It is only necessary to use this function on encodings that come from
+ the user and have not been canonicalized yet. Encodings that are set
+ on ports or in the default encoding fluid are in upper-case, and can
+ be compared with strcmp. */
+static int
+encoding_matches (const char *enc, const char *upper)
+{
+ if (!enc)
+ enc = "ISO-8859-1";
+
+ while (*enc)
+ if (ascii_toupper (*enc++) != *upper++)
+ return 0;
+
+ return !*upper;
+}
+
+static char*
+canonicalize_encoding (const char *enc)
+{
+ char *ret;
+ int i;
+
+ if (!enc)
+ return "ISO-8859-1";
+
+ ret = scm_gc_strdup (enc, "port");
+
+ for (i = 0; ret[i]; i++)
+ {
+ if (ret[i] > 127)
+ /* Restrict to ASCII. */
+ scm_misc_error (NULL, "invalid character encoding ~s",
+ scm_list_1 (scm_from_latin1_string (enc)));
+ else
+ ret[i] = ascii_toupper (ret[i]);
+ }
+
+ return ret;
+}
+
+
+\f
/* The port kind table --- a dynamically resized array of port types. */
* 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 = NULL;
-long scm_numptob = 0;
+static scm_t_ptob_descriptor **scm_ptobs = NULL;
+static long scm_numptob = 0; /* Number of port types. */
+static long scm_ptobs_size = 0; /* Number of slots in the port type
+ table. */
+static scm_i_pthread_mutex_t scm_ptobs_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-/* GC marker for a port with stream of SCM type. */
-SCM
-scm_markstream (SCM ptr)
+long
+scm_c_num_port_types (void)
{
- int openp;
- openp = SCM_CELL_WORD_0 (ptr) & SCM_OPN;
- if (openp)
- return SCM_PACK (SCM_STREAM (ptr));
- else
- return SCM_BOOL_F;
+ long ret;
+
+ scm_i_pthread_mutex_lock (&scm_ptobs_lock);
+ ret = scm_numptob;
+ scm_i_pthread_mutex_unlock (&scm_ptobs_lock);
+
+ return ret;
+}
+
+scm_t_ptob_descriptor*
+scm_c_port_type_ref (long ptobnum)
+{
+ scm_t_ptob_descriptor *ret = NULL;
+
+ scm_i_pthread_mutex_lock (&scm_ptobs_lock);
+
+ if (0 <= ptobnum && ptobnum < scm_numptob)
+ ret = scm_ptobs[ptobnum];
+
+ scm_i_pthread_mutex_unlock (&scm_ptobs_lock);
+
+ if (!ret)
+ scm_out_of_range ("scm_c_port_type_ref", scm_from_long (ptobnum));
+
+ return ret;
+}
+
+long
+scm_c_port_type_add_x (scm_t_ptob_descriptor *desc)
+{
+ long ret = -1;
+
+ scm_i_pthread_mutex_lock (&scm_ptobs_lock);
+
+ if (scm_numptob + 1 < SCM_I_MAX_PORT_TYPE_COUNT)
+ {
+ if (scm_numptob == scm_ptobs_size)
+ {
+ unsigned long old_size = scm_ptobs_size;
+ scm_t_ptob_descriptor **old_ptobs = scm_ptobs;
+
+ /* Currently there are only 9 predefined port types, so one
+ resize will cover it. */
+ scm_ptobs_size = old_size + 10;
+
+ if (scm_ptobs_size >= SCM_I_MAX_PORT_TYPE_COUNT)
+ scm_ptobs_size = SCM_I_MAX_PORT_TYPE_COUNT;
+
+ scm_ptobs = scm_gc_malloc (sizeof (*scm_ptobs) * scm_ptobs_size,
+ "scm_ptobs");
+
+ memcpy (scm_ptobs, old_ptobs, sizeof (*scm_ptobs) * scm_numptob);
+ }
+
+ ret = scm_numptob++;
+ scm_ptobs[ret] = desc;
+ }
+
+ scm_i_pthread_mutex_unlock (&scm_ptobs_lock);
+
+ if (ret < 0)
+ scm_out_of_range ("scm_c_port_type_add_x", scm_from_long (scm_numptob));
+
+ return ret;
}
/*
int (*fill_input) (SCM port),
void (*write) (SCM port, const void *data, size_t size))
{
- char *tmp;
- if (SCM_I_MAX_PORT_TYPE_COUNT - 1 <= scm_numptob)
- goto ptoberr;
- SCM_CRITICAL_SECTION_START;
- 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_t_ptob_descriptor *desc;
+ long ptobnum;
- scm_ptobs[scm_numptob].name = name;
- scm_ptobs[scm_numptob].mark = 0;
- 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;
+ desc = scm_gc_malloc_pointerless (sizeof (*desc), "port-type");
+ memset (desc, 0, sizeof (*desc));
- scm_ptobs[scm_numptob].write = write;
- scm_ptobs[scm_numptob].flush = flush_port_default;
+ desc->name = name;
+ desc->print = scm_port_print;
+ desc->write = write;
+ desc->flush = flush_port_default;
+ desc->end_input = end_input_default;
+ desc->fill_input = fill_input;
- scm_ptobs[scm_numptob].end_input = end_input_default;
- scm_ptobs[scm_numptob].fill_input = fill_input;
- scm_ptobs[scm_numptob].input_waiting = 0;
+ ptobnum = scm_c_port_type_add_x (desc);
- scm_ptobs[scm_numptob].seek = 0;
- scm_ptobs[scm_numptob].truncate = 0;
-
- scm_numptob++;
- }
- SCM_CRITICAL_SECTION_END;
- if (!tmp)
- {
- ptoberr:
- scm_memory_error ("scm_make_port_type");
- }
- /* Make a class object if Goops is present */
+ /* Make a class object if GOOPS is present. */
if (SCM_UNPACK (scm_port_class[0]) != 0)
- scm_make_port_classes (scm_numptob - 1, SCM_PTOBNAME (scm_numptob - 1));
- return scm_tc7_port + (scm_numptob - 1) * 256;
+ scm_make_port_classes (ptobnum, name);
+
+ return scm_tc7_port + ptobnum * 256;
}
void
scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].mark = mark;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->mark = mark;
}
void
scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].free = free;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->free = free;
}
void
scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port,
- scm_print_state *pstate))
+ scm_print_state *pstate))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].print = print;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->print = print;
}
void
scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].equalp = equalp;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->equalp = equalp;
}
void
-scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port))
+scm_set_port_close (scm_t_bits tc, int (*close) (SCM))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].flush = flush;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->close = close;
}
void
-scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset))
+scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].end_input = end_input;
+ scm_t_ptob_descriptor *ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc));
+ ptob->flush = flush;
+ ptob->flags |= SCM_PORT_TYPE_HAS_FLUSH;
}
void
-scm_set_port_close (scm_t_bits tc, int (*close) (SCM))
+scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].close = close;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->end_input = end_input;
}
void
-scm_set_port_seek (scm_t_bits tc,
- scm_t_off (*seek) (SCM, scm_t_off, int))
+scm_set_port_seek (scm_t_bits tc, scm_t_off (*seek) (SCM, scm_t_off, int))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].seek = seek;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->seek = seek;
}
void
scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM, scm_t_off))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].truncate = truncate;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->truncate = truncate;
}
void
scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].input_waiting = input_waiting;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->input_waiting = input_waiting;
+}
+
+void
+scm_set_port_setvbuf (scm_t_bits tc, void (*setvbuf) (SCM, long, long))
+{
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->setvbuf = setvbuf;
}
static void
"Return the property of @var{port} associated with @var{key}.")
#define FUNC_NAME s_scm_i_port_property
{
+ scm_i_pthread_mutex_t *lock;
+ SCM result;
+
SCM_VALIDATE_OPPORT (1, port);
- return scm_assq_ref (SCM_PORT_GET_INTERNAL (port)->alist, key);
+ scm_c_lock_port (port, &lock);
+ result = scm_assq_ref (SCM_PORT_GET_INTERNAL (port)->alist, key);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+ return result;
}
#undef FUNC_NAME
"Set the property of @var{port} associated with @var{key} to @var{value}.")
#define FUNC_NAME s_scm_i_set_port_property_x
{
+ scm_i_pthread_mutex_t *lock;
scm_t_port_internal *pti;
SCM_VALIDATE_OPPORT (1, port);
+ scm_c_lock_port (port, &lock);
pti = SCM_PORT_GET_INTERNAL (port);
pti->alist = scm_assq_set_x (pti->alist, key, value);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
\f
-SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0,
- (SCM port),
- "Return @code{#t} if a character is ready on input @var{port}\n"
- "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
- "@code{#t} then the next @code{read-char} operation on\n"
- "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
- "port at end of file then @code{char-ready?} returns @code{#t}.\n"
- "\n"
- "@code{char-ready?} exists to make it possible for a\n"
- "program to accept characters from interactive ports without\n"
- "getting stuck waiting for input. Any input editors associated\n"
- "with such ports must make sure that characters whose existence\n"
- "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
- "If @code{char-ready?} were to return @code{#f} at end of file,\n"
- "a port at end of file would be indistinguishable from an\n"
- "interactive port that has no ready characters.")
-#define FUNC_NAME s_scm_char_ready_p
-{
- scm_t_port *pt;
-
- if (SCM_UNBNDP (port))
- port = scm_current_input_port ();
- /* It's possible to close the current input port, so validate even in
- this case. */
- SCM_VALIDATE_OPINPORT (1, port);
-
- pt = SCM_PTAB_ENTRY (port);
-
- /* if the current read buffer is filled, or the
- last pushed-back char has been read and the saved buffer is
- filled, result is true. */
- if (pt->read_pos < pt->read_end
- || (pt->read_buf == pt->putback_buf
- && pt->saved_read_pos < pt->saved_read_end))
- return SCM_BOOL_T;
- else
- {
- scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
-
- if (ptob->input_waiting)
- return scm_from_bool(ptob->input_waiting (port));
- else
- return SCM_BOOL_T;
- }
-}
-#undef FUNC_NAME
-
-/* Move up to READ_LEN bytes from PORT's putback and/or read buffers
- into memory starting at DEST. Return the number of bytes moved.
- PORT's line/column numbers are left unchanged. */
-size_t
-scm_take_from_input_buffers (SCM port, char *dest, size_t read_len)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- size_t bytes_read = 0;
- size_t from_buf = min (pt->read_end - pt->read_pos, read_len);
-
- if (from_buf > 0)
- {
- memcpy (dest, pt->read_pos, from_buf);
- pt->read_pos += from_buf;
- bytes_read += from_buf;
- read_len -= from_buf;
- dest += from_buf;
- }
-
- /* if putback was active, try the real input buffer too. */
- if (pt->read_buf == pt->putback_buf)
- {
- from_buf = min (pt->saved_read_end - pt->saved_read_pos, read_len);
- if (from_buf > 0)
- {
- memcpy (dest, pt->saved_read_pos, from_buf);
- pt->saved_read_pos += from_buf;
- bytes_read += from_buf;
- }
- }
-
- return bytes_read;
-}
-
-/* Clear a port's read buffers, returning the contents. */
-SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
- (SCM port),
- "This procedure clears a port's input buffers, similar\n"
- "to the way that force-output clears the output buffer. The\n"
- "contents of the buffers are returned as a single string, e.g.,\n"
- "\n"
- "@lisp\n"
- "(define p (open-input-file ...))\n"
- "(drain-input p) => empty string, nothing buffered yet.\n"
- "(unread-char (read-char p) p)\n"
- "(drain-input p) => initial chars from p, up to the buffer size.\n"
- "@end lisp\n\n"
- "Draining the buffers may be useful for cleanly finishing\n"
- "buffered I/O so that the file descriptor can be used directly\n"
- "for further input.")
-#define FUNC_NAME s_scm_drain_input
-{
- SCM result;
- char *data;
- scm_t_port *pt;
- long count;
-
- SCM_VALIDATE_OPINPORT (1, port);
- pt = SCM_PTAB_ENTRY (port);
-
- count = pt->read_end - pt->read_pos;
- if (pt->read_buf == pt->putback_buf)
- count += pt->saved_read_end - pt->saved_read_pos;
-
- if (count)
- {
- result = scm_i_make_string (count, &data, 0);
- scm_take_from_input_buffers (port, data, count);
- }
- else
- result = scm_nullstr;
-
- return result;
-}
-#undef FUNC_NAME
-
-\f
/* Standard ports --- current input, output, error, and more(!). */
static SCM cur_inport_fluid = SCM_BOOL_F;
static SCM cur_outport_fluid = SCM_BOOL_F;
static SCM cur_errport_fluid = SCM_BOOL_F;
+static SCM cur_warnport_fluid = SCM_BOOL_F;
static SCM cur_loadport_fluid = SCM_BOOL_F;
SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
- (),
+ (void),
"Return the current input port. This is the default port used\n"
"by many input procedures. Initially, @code{current-input-port}\n"
"returns the @dfn{standard input} in Unix and C terminology.")
#undef FUNC_NAME
SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
- (),
+ (void),
"Return the current output port. This is the default port used\n"
"by many output procedures. Initially,\n"
"@code{current-output-port} returns the @dfn{standard output} in\n"
#undef FUNC_NAME
SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
- (),
+ (void),
"Return the port to which errors and warnings should be sent (the\n"
"@dfn{standard error} in Unix and C terminology).")
#define FUNC_NAME s_scm_current_error_port
}
#undef FUNC_NAME
-static SCM current_warning_port_var;
-static scm_i_pthread_once_t current_warning_port_once = SCM_I_PTHREAD_ONCE_INIT;
-
-static void
-init_current_warning_port_var (void)
-{
- current_warning_port_var
- = scm_c_private_variable ("guile", "current-warning-port");
-}
-
-SCM
-scm_current_warning_port (void)
+SCM_DEFINE (scm_current_warning_port, "current-warning-port", 0, 0, 0,
+ (void),
+ "Return the port to which diagnostic warnings should be sent.")
+#define FUNC_NAME s_scm_current_warning_port
{
- scm_i_pthread_once (¤t_warning_port_once,
- init_current_warning_port_var);
- return scm_call_0 (scm_variable_ref (current_warning_port_var));
+ if (scm_is_true (cur_warnport_fluid))
+ return scm_fluid_ref (cur_warnport_fluid);
+ else
+ return SCM_BOOL_F;
}
+#undef FUNC_NAME
SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
(),
SCM
scm_set_current_warning_port (SCM port)
+#define FUNC_NAME "set-current-warning-port"
{
- scm_i_pthread_once (¤t_warning_port_once,
- init_current_warning_port_var);
- return scm_call_1 (scm_variable_ref (current_warning_port_var), port);
+ SCM owarnp = scm_fluid_ref (cur_warnport_fluid);
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_fluid_set_x (cur_warnport_fluid, port);
+ return owarnp;
}
+#undef FUNC_NAME
void
scm_dynwind_fluid (cur_loadport_fluid, port);
}
-\f
-/* The port table --- an array of pointers to ports. */
-
-/*
- We need a global registry of ports to flush them all at exit, and to
- get all the ports matching a file descriptor.
- */
-SCM scm_i_port_weak_hash;
-
-scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
\f
-/* Port finalization. */
+/* Retrieving a port's mode. */
-static void finalize_port (void *, void *);
+/* Return the flags that characterize a port based on the mode
+ * string used to open a file for that port.
+ *
+ * See PORT FLAGS in scm.h
+ */
-/* Register a finalizer for PORT. */
-static SCM_C_INLINE_KEYWORD void
-register_finalizer_for_port (SCM port)
+static long
+scm_i_mode_bits_n (SCM modes)
{
- /* Register a finalizer for PORT so that its
- type's `free' function gets called. */
- scm_i_set_finalizer (SCM2PTR (port), finalize_port, NULL);
+ return (SCM_OPN
+ | (scm_i_string_contains_char (modes, 'r')
+ || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0)
+ | (scm_i_string_contains_char (modes, 'w')
+ || scm_i_string_contains_char (modes, 'a')
+ || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0)
+ | (scm_i_string_contains_char (modes, '0') ? SCM_BUF0 : 0)
+ | (scm_i_string_contains_char (modes, 'l') ? SCM_BUFLINE : 0));
}
-/* Finalize the object (a port) pointed to by PTR. */
-static void
-finalize_port (void *ptr, void *data)
+long
+scm_mode_bits (char *modes)
{
- 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 ();
+ /* Valid characters are rw+a0l. So, use latin1. */
+ return scm_i_mode_bits (scm_from_latin1_string (modes));
+}
- 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);
+long
+scm_i_mode_bits (SCM modes)
+{
+ long bits;
- SCM_SETSTREAM (port, 0);
- SCM_CLR_PORT_OPEN_FLAG (port);
+ if (!scm_is_string (modes))
+ scm_wrong_type_arg_msg (NULL, 0, modes, "string");
- scm_gc_ports_collected++;
- }
- }
+ bits = scm_i_mode_bits_n (modes);
+ scm_remember_upto_here_1 (modes);
+ return bits;
}
+/* Return the mode flags from an open port.
+ * Some modes such as "append" are only used when opening
+ * a file and are not returned here. */
+SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
+ (SCM port),
+ "Return the port modes associated with the open port @var{port}.\n"
+ "These will not necessarily be identical to the modes used when\n"
+ "the port was opened, since modes such as \"append\" which are\n"
+ "used only during port creation are not retained.")
+#define FUNC_NAME s_scm_port_mode
+{
+ char modes[4];
+ modes[0] = '\0';
-\f
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPPORT (1, port);
+ if (SCM_CELL_WORD_0 (port) & SCM_RDNG) {
+ if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
+ strcpy (modes, "r+");
+ else
+ strcpy (modes, "r");
+ }
+ else if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
+ strcpy (modes, "w");
+ if (SCM_CELL_WORD_0 (port) & SCM_BUF0)
+ strcat (modes, "0");
-/* 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"
-{
- /*
- We initialize the cell to empty, this is in case scm_gc_calloc
- triggers GC ; we don't want the GC to scan a half-finished Z.
- */
-
- SCM z = scm_cons (SCM_EOL, SCM_EOL);
- scm_t_port *entry = scm_gc_typed_calloc (scm_t_port);
- scm_t_port_internal *pti = scm_gc_typed_calloc (scm_t_port_internal);
- const char *encoding;
+ return scm_from_latin1_string (modes);
+}
+#undef FUNC_NAME
- entry->file_name = SCM_BOOL_F;
- entry->rw_active = SCM_PORT_NEITHER;
- entry->port = z;
-
- /* Initialize this port with the thread's current default
- encoding. */
- encoding = scm_i_default_port_encoding ();
- entry->ilseq_handler = scm_i_default_port_conversion_handler ();
- entry->encoding = encoding ? scm_gc_strdup (encoding, "port") : NULL;
- if (encoding && c_strcasecmp (encoding, "UTF-8") == 0)
- pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
- else
- pti->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
- pti->iconv_descriptors = NULL;
+\f
- pti->at_stream_start_for_bom_read = 1;
- pti->at_stream_start_for_bom_write = 1;
+/* The port table --- a weak set of all ports.
- /* XXX These fields are not what they seem. They have been
- repurposed, but cannot safely be renamed in 2.0 without breaking
- ABI compatibility. This will be cleaned up in 2.2. */
- entry->input_cd = pti; /* XXX pointer to the internal port structure */
- entry->output_cd = NULL; /* XXX unused */
+ We need a global registry of ports to flush them all at exit, and to
+ get all the ports matching a file descriptor. */
+SCM scm_i_port_weak_set;
- pti->pending_eof = 0;
- pti->alist = SCM_EOL;
- /* Until Guile 2.0.9 included, 'setvbuf' would only work on file
- ports. Now all port types can be supported, but it's not clear
- that port types out in wild accept having someone else fiddle with
- their buffer. Thus, conservatively turn it off by default. */
- pti->setvbuf = NULL;
+\f
+
+/* Port finalization. */
- SCM_SET_CELL_TYPE (z, tag);
- SCM_SETPTAB_ENTRY (z, entry);
+struct do_free_data
+{
+ scm_t_ptob_descriptor *ptob;
+ SCM port;
+};
- scm_hashq_set_x (scm_i_port_weak_hash, z, SCM_BOOL_F);
+static SCM
+do_free (void *body_data)
+{
+ struct do_free_data *data = body_data;
- /* For each new port, register a finalizer so that it port type's free
- function can be invoked eventually. */
- register_finalizer_for_port (z);
+ /* `close' is for explicit `close-port' by user. `free' is for this
+ purpose: ports collected by the GC. */
+ data->ptob->free (data->port);
- return z;
+ return SCM_BOOL_T;
}
-#undef FUNC_NAME
-#if SCM_ENABLE_DEPRECATED==1
-scm_t_port *
-scm_add_to_port_table (SCM port)
+/* Finalize the object (a port) pointed to by PTR. */
+static void
+finalize_port (void *ptr, void *data)
{
- SCM z;
- scm_t_port * pt;
+ SCM port = SCM_PACK_POINTER (ptr);
- scm_c_issue_deprecation_warning ("'scm_add_to_port_table' is deprecated. "
- "Use 'scm_new_port_table_entry' instead.");
+ if (!SCM_PORTP (port))
+ abort ();
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
- z = scm_new_port_table_entry (scm_tc7_port);
- pt = SCM_PTAB_ENTRY(z);
- pt->port = port;
- SCM_SETCAR (z, SCM_EOL);
- SCM_SETCDR (z, SCM_EOL);
- SCM_SETPTAB_ENTRY (port, pt);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ if (SCM_OPENP (port))
+ {
+ struct do_free_data data;
- return pt;
-}
-#endif
+ SCM_CLR_PORT_OPEN_FLAG (port);
+ data.ptob = SCM_PORT_DESCRIPTOR (port);
+ data.port = port;
-/* Remove a port from the table and destroy it. */
+ scm_internal_catch (SCM_BOOL_T, do_free, &data,
+ scm_handle_by_message_noexit, NULL);
-static void close_iconv_descriptors (scm_t_iconv_descriptors *id);
+ scm_gc_ports_collected++;
+ }
+}
-static void
-scm_i_remove_port (SCM port)
-#define FUNC_NAME "scm_remove_port"
+
+\f
+
+SCM
+scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits,
+ const char *encoding,
+ scm_t_string_failed_conversion_handler handler,
+ scm_t_bits stream)
{
- scm_t_port *p;
+ SCM ret;
+ scm_t_port *entry;
scm_t_port_internal *pti;
+ scm_t_ptob_descriptor *ptob;
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ entry = scm_gc_typed_calloc (scm_t_port);
+ pti = scm_gc_typed_calloc (scm_t_port_internal);
+ ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tag));
- p = SCM_PTAB_ENTRY (port);
- pti = SCM_PORT_GET_INTERNAL (port);
- scm_port_non_buffer (p);
- p->putback_buf = NULL;
- p->putback_buf_size = 0;
+ ret = scm_words (tag | mode_bits, 3);
+ SCM_SET_CELL_WORD_1 (ret, (scm_t_bits) entry);
+ SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) ptob);
- if (pti->iconv_descriptors)
+ entry->lock = scm_gc_malloc_pointerless (sizeof (*entry->lock), "port lock");
+ scm_i_pthread_mutex_init (entry->lock, scm_i_pthread_mutexattr_recursive);
+
+ entry->internal = pti;
+ entry->file_name = SCM_BOOL_F;
+ entry->rw_active = SCM_PORT_NEITHER;
+ entry->port = ret;
+ entry->stream = stream;
+
+ if (encoding_matches (encoding, "UTF-8"))
{
- close_iconv_descriptors (pti->iconv_descriptors);
- pti->iconv_descriptors = NULL;
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
+ entry->encoding = "UTF-8";
+ }
+ else if (encoding_matches (encoding, "ISO-8859-1"))
+ {
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
+ entry->encoding = "ISO-8859-1";
+ }
+ else
+ {
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+ entry->encoding = canonicalize_encoding (encoding);
}
- SCM_SETPTAB_ENTRY (port, 0);
+ entry->ilseq_handler = handler;
+ pti->iconv_descriptors = NULL;
- scm_hashq_remove_x (scm_i_port_weak_hash, port);
+ pti->at_stream_start_for_bom_read = 1;
+ pti->at_stream_start_for_bom_write = 1;
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-}
-#undef FUNC_NAME
+ pti->pending_eof = 0;
+ pti->alist = SCM_EOL;
+ if (SCM_PORT_DESCRIPTOR (ret)->free)
+ scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL);
-/* Functions for debugging. */
-#ifdef GUILE_DEBUG
-SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0,
- (),
- "Return the number of ports in the port table. @code{pt-size}\n"
- "is only included in @code{--enable-guile-debug} builds.")
-#define FUNC_NAME s_scm_pt_size
-{
- return scm_from_int (SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash));
+ if (SCM_PORT_DESCRIPTOR (ret)->flags & SCM_PORT_TYPE_HAS_FLUSH)
+ scm_weak_set_add_x (scm_i_port_weak_set, ret);
+
+ return ret;
}
-#undef FUNC_NAME
-#endif
-void
-scm_port_non_buffer (scm_t_port *pt)
+SCM
+scm_c_make_port (scm_t_bits tag, unsigned long mode_bits, scm_t_bits stream)
{
- pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
- pt->write_buf = pt->write_pos = &pt->shortbuf;
- pt->read_buf_size = pt->write_buf_size = 1;
- pt->write_end = pt->write_buf + pt->write_buf_size;
+ return scm_c_make_port_with_encoding (tag, mode_bits,
+ scm_i_default_port_encoding (),
+ scm_i_default_port_conversion_handler (),
+ stream);
}
-\f
-/* Revealed counts --- an oddity inherited from SCSH. */
-
-/* Find a port in the table and return its revealed count.
- Also used by the garbage collector.
- */
-
-int
-scm_revealed_count (SCM port)
+SCM
+scm_new_port_table_entry (scm_t_bits tag)
{
- return SCM_REVEALED(port);
+ return scm_c_make_port (tag, 0, 0);
}
+\f
+/* Predicates. */
-/* Return the revealed count for a port. */
-
-SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
- (SCM port),
- "Return the revealed count for @var{port}.")
-#define FUNC_NAME s_scm_port_revealed
+SCM_DEFINE (scm_port_p, "port?", 1, 0, 0,
+ (SCM x),
+ "Return a boolean indicating whether @var{x} is a port.\n"
+ "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
+ "@var{x}))}.")
+#define FUNC_NAME s_scm_port_p
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_int (scm_revealed_count (port));
+ return scm_from_bool (SCM_PORTP (x));
}
#undef FUNC_NAME
-/* Set the revealed count for a port. */
-SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
- (SCM port, SCM rcount),
- "Sets the revealed count for a port to a given value.\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_set_port_revealed_x
+SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an input port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
+#define FUNC_NAME s_scm_input_port_p
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- SCM_REVEALED (port) = scm_to_int (rcount);
- return SCM_UNSPECIFIED;
+ return scm_from_bool (SCM_INPUT_PORT_P (x));
}
#undef FUNC_NAME
-
-\f
-/* Retrieving a port's mode. */
-
-/* Return the flags that characterize a port based on the mode
- * string used to open a file for that port.
- *
- * See PORT FLAGS in scm.h
- */
-
-static long
-scm_i_mode_bits_n (SCM modes)
-{
- return (SCM_OPN
- | (scm_i_string_contains_char (modes, 'r')
- || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0)
- | (scm_i_string_contains_char (modes, 'w')
- || scm_i_string_contains_char (modes, 'a')
- || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0)
- | (scm_i_string_contains_char (modes, '0') ? SCM_BUF0 : 0)
- | (scm_i_string_contains_char (modes, 'l') ? SCM_BUFLINE : 0));
-}
-
-long
-scm_mode_bits (char *modes)
+SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an output port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
+#define FUNC_NAME s_scm_output_port_p
{
- return scm_i_mode_bits (scm_from_locale_string (modes));
+ x = SCM_COERCE_OUTPORT (x);
+ return scm_from_bool (SCM_OUTPUT_PORT_P (x));
}
+#undef FUNC_NAME
-long
-scm_i_mode_bits (SCM modes)
+SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0,
+ (SCM port),
+ "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
+ "open.")
+#define FUNC_NAME s_scm_port_closed_p
{
- long bits;
-
- if (!scm_is_string (modes))
- scm_wrong_type_arg_msg (NULL, 0, modes, "string");
-
- bits = scm_i_mode_bits_n (modes);
- scm_remember_upto_here_1 (modes);
- return bits;
+ SCM_VALIDATE_PORT (1, port);
+ return scm_from_bool (!SCM_OPPORTP (port));
}
+#undef FUNC_NAME
-/* Return the mode flags from an open port.
- * Some modes such as "append" are only used when opening
- * a file and are not returned here. */
-
-SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
- (SCM port),
- "Return the port modes associated with the open port @var{port}.\n"
- "These will not necessarily be identical to the modes used when\n"
- "the port was opened, since modes such as \"append\" which are\n"
- "used only during port creation are not retained.")
-#define FUNC_NAME s_scm_port_mode
+SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
+ "return @code{#f}.")
+#define FUNC_NAME s_scm_eof_object_p
{
- char modes[4];
- modes[0] = '\0';
-
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPPORT (1, port);
- if (SCM_CELL_WORD_0 (port) & SCM_RDNG) {
- if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- strcpy (modes, "r+");
- else
- strcpy (modes, "r");
- }
- else if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- strcpy (modes, "w");
- if (SCM_CELL_WORD_0 (port) & SCM_BUF0)
- strcat (modes, "0");
- return scm_from_locale_string (modes);
+ return scm_from_bool (SCM_EOF_OBJECT_P (x));
}
#undef FUNC_NAME
\f
+
/* Closing ports. */
+static void close_iconv_descriptors (scm_t_iconv_descriptors *id);
+
/* scm_close_port
* Call the close operation on a port object.
* see also scm_close.
"descriptors.")
#define FUNC_NAME s_scm_close_port
{
- size_t i;
+ scm_t_port_internal *pti;
int rv;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_PORT (1, port);
if (SCM_CLOSEDP (port))
return SCM_BOOL_F;
- i = SCM_PTOBNUM (port);
- if (scm_ptobs[i].close)
- rv = (scm_ptobs[i].close) (port);
+
+ pti = SCM_PORT_GET_INTERNAL (port);
+ SCM_CLR_PORT_OPEN_FLAG (port);
+
+ if (SCM_PORT_DESCRIPTOR (port)->flags & SCM_PORT_TYPE_HAS_FLUSH)
+ scm_weak_set_remove_x (scm_i_port_weak_set, port);
+
+ if (SCM_PORT_DESCRIPTOR (port)->close)
+ /* Note! This may throw an exception. Anything after this point
+ should be resilient to non-local exits. */
+ rv = SCM_PORT_DESCRIPTOR (port)->close (port);
else
rv = 0;
- scm_i_remove_port (port);
- SCM_CLR_PORT_OPEN_FLAG (port);
+
+ if (pti->iconv_descriptors)
+ {
+ /* If we don't get here, the iconv_descriptors finalizer will
+ clean up. */
+ close_iconv_descriptors (pti->iconv_descriptors);
+ pti->iconv_descriptors = NULL;
+ }
+
return scm_from_bool (rv >= 0);
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-static SCM
-collect_keys (void *unused, SCM key, SCM value, SCM result)
-{
- return scm_cons (key, result);
-}
+\f
+
+/* Encoding characters to byte streams, and decoding byte streams to
+ characters. */
+
+/* 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;
+
+/* Use ENCODING as the default encoding for future ports. */
void
-scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
+scm_i_set_default_port_encoding (const char *encoding)
{
- SCM ports;
+ if (!scm_port_encoding_init
+ || !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);
- /* Copy out the port table as a list so that we get strong references
- to all the values. */
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
- ports = scm_internal_hash_fold (collect_keys, NULL,
- SCM_EOL, scm_i_port_weak_hash);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ if (encoding_matches (encoding, "ISO-8859-1"))
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
+ else
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var),
+ scm_from_latin1_string (canonicalize_encoding (encoding)));
+}
- for (; scm_is_pair (ports); ports = scm_cdr (ports))
+/* Return the name of the default encoding for newly created ports. */
+const char *
+scm_i_default_port_encoding (void)
+{
+ if (!scm_port_encoding_init)
+ return "ISO-8859-1";
+ else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
+ return "ISO-8859-1";
+ else
{
- SCM p = scm_car (ports);
- if (SCM_PORTP (p))
- proc (data, p);
+ SCM encoding;
+
+ encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var));
+ if (!scm_is_string (encoding))
+ return "ISO-8859-1";
+ else
+ return scm_i_string_chars (encoding);
}
}
-SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
- (SCM proc),
- "Apply @var{proc} to each port in the Guile port table\n"
- "in turn. The return value is unspecified. More specifically,\n"
- "@var{proc} is applied exactly once to every port that exists\n"
- "in the system at the time @code{port-for-each} is invoked.\n"
- "Changes to the port table while @code{port-for-each} is running\n"
- "have no effect as far as @code{port-for-each} is concerned.")
-#define FUNC_NAME s_scm_port_for_each
-{
- SCM ports;
+/* A fluid specifying the default conversion handler for newly created
+ ports. Its value should be one of the symbols below. */
+SCM_VARIABLE (default_conversion_strategy_var,
+ "%default-port-conversion-strategy");
- SCM_VALIDATE_PROC (1, proc);
+/* Whether the above fluid is initialized. */
+static int scm_conversion_strategy_init = 0;
- /* Copy out the port table as a list so that we get strong references
- to all the values. */
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
- ports = scm_internal_hash_fold (collect_keys, NULL,
- SCM_EOL, scm_i_port_weak_hash);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+/* The possible conversion strategies. */
+SCM_SYMBOL (sym_error, "error");
+SCM_SYMBOL (sym_substitute, "substitute");
+SCM_SYMBOL (sym_escape, "escape");
- for (; scm_is_pair (ports); ports = scm_cdr (ports))
- if (SCM_PORTP (SCM_CAR (ports)))
- scm_call_1 (proc, SCM_CAR (ports));
+/* Return the default failed encoding conversion policy for new created
+ ports. */
+scm_t_string_failed_conversion_handler
+scm_i_default_port_conversion_handler (void)
+{
+ scm_t_string_failed_conversion_handler handler;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
+ if (!scm_conversion_strategy_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var)))
+ handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else
+ {
+ SCM fluid, value;
+ fluid = SCM_VARIABLE_REF (default_conversion_strategy_var);
+ value = scm_fluid_ref (fluid);
-\f
-/* Utter miscellany. Gosh, we should clean this up some time. */
+ if (scm_is_eq (sym_substitute, value))
+ handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else if (scm_is_eq (sym_escape, value))
+ handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE;
+ else
+ /* Default to 'error also when the fluid's value is not one of
+ the valid symbols. */
+ handler = SCM_FAILED_CONVERSION_ERROR;
+ }
-SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is an input port, otherwise return\n"
- "@code{#f}. Any object satisfying this predicate also satisfies\n"
- "@code{port?}.")
-#define FUNC_NAME s_scm_input_port_p
-{
- return scm_from_bool (SCM_INPUT_PORT_P (x));
+ return handler;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is an output port, otherwise return\n"
- "@code{#f}. Any object satisfying this predicate also satisfies\n"
- "@code{port?}.")
-#define FUNC_NAME s_scm_output_port_p
+/* Use HANDLER as the default conversion strategy for future ports. */
+void
+scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler
+ handler)
{
- x = SCM_COERCE_OUTPORT (x);
- return scm_from_bool (SCM_OUTPUT_PORT_P (x));
-}
-#undef FUNC_NAME
+ SCM strategy;
-SCM_DEFINE (scm_port_p, "port?", 1, 0, 0,
- (SCM x),
- "Return a boolean indicating whether @var{x} is a port.\n"
- "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
- "@var{x}))}.")
-#define FUNC_NAME s_scm_port_p
-{
- return scm_from_bool (SCM_PORTP (x));
-}
-#undef FUNC_NAME
+ if (!scm_conversion_strategy_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var)))
+ scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
+ SCM_EOL);
-SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0,
- (SCM port),
- "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
- "open.")
-#define FUNC_NAME s_scm_port_closed_p
-{
- SCM_VALIDATE_PORT (1, port);
- return scm_from_bool (!SCM_OPPORTP (port));
-}
-#undef FUNC_NAME
+ switch (handler)
+ {
+ case SCM_FAILED_CONVERSION_ERROR:
+ strategy = sym_error;
+ break;
-SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
- "return @code{#f}.")
-#define FUNC_NAME s_scm_eof_object_p
-{
- return scm_from_bool(SCM_EOF_OBJECT_P (x));
+ case SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE:
+ strategy = sym_escape;
+ break;
+
+ case SCM_FAILED_CONVERSION_QUESTION_MARK:
+ strategy = sym_substitute;
+ break;
+
+ default:
+ abort ();
+ }
+
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var),
+ strategy);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
- (SCM port),
- "Flush the specified output port, or the current output port if @var{port}\n"
- "is omitted. The current output buffer contents are passed to the\n"
- "underlying port implementation (e.g., in the case of fports, the\n"
- "data will be written to the file and the output buffer will be cleared.)\n"
- "It has no effect on an unbuffered port.\n\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_force_output
+static void
+scm_i_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port);
+
+/* If the next LEN bytes from PORT are equal to those in BYTES, then
+ return 1, else return 0. Leave the port position unchanged. */
+static int
+looking_at_bytes (SCM port, const unsigned char *bytes, int len)
{
- if (SCM_UNBNDP (port))
- port = scm_current_output_port ();
- else
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ int i = 0;
+
+ while (i < len && scm_peek_byte_or_eof_unlocked (port) == bytes[i])
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPOUTPORT (1, port);
+ pt->read_pos++;
+ i++;
}
- scm_flush (port);
- return SCM_UNSPECIFIED;
+ scm_i_unget_bytes_unlocked (bytes, i, port);
+ return (i == len);
}
-#undef FUNC_NAME
+static const unsigned char scm_utf8_bom[3] = {0xEF, 0xBB, 0xBF};
+static const unsigned char scm_utf16be_bom[2] = {0xFE, 0xFF};
+static const unsigned char scm_utf16le_bom[2] = {0xFF, 0xFE};
+static const unsigned char scm_utf32be_bom[4] = {0x00, 0x00, 0xFE, 0xFF};
+static const unsigned char scm_utf32le_bom[4] = {0xFF, 0xFE, 0x00, 0x00};
-static void
-flush_output_port (void *closure, SCM port)
+/* Decide what byte order to use for a UTF-16 port. Return "UTF-16BE"
+ or "UTF-16LE". MODE must be either SCM_PORT_READ or SCM_PORT_WRITE,
+ and specifies which operation is about to be done. The MODE
+ determines how we will decide the byte order. We deliberately avoid
+ reading from the port unless the user is about to do so. If the user
+ is about to read, then we look for a BOM, and if present, we use it
+ to determine the byte order. Otherwise we choose big endian, as
+ recommended by the Unicode Standard. Note that the BOM (if any) is
+ not consumed here. */
+static const char *
+decide_utf16_encoding (SCM port, scm_t_port_rw_active mode)
{
- if (SCM_OPOUTPORTP (port))
- scm_flush (port);
+ if (mode == SCM_PORT_READ
+ && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read
+ && looking_at_bytes (port, scm_utf16le_bom, sizeof scm_utf16le_bom))
+ return "UTF-16LE";
+ else
+ return "UTF-16BE";
}
-SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
- (),
- "Equivalent to calling @code{force-output} on\n"
- "all open output ports. The return value is unspecified.")
-#define FUNC_NAME s_scm_flush_all_ports
+/* Decide what byte order to use for a UTF-32 port. Return "UTF-32BE"
+ or "UTF-32LE". See the comment above 'decide_utf16_encoding' for
+ details. */
+static const char *
+decide_utf32_encoding (SCM port, scm_t_port_rw_active mode)
{
- scm_c_port_for_each (&flush_output_port, NULL);
- return SCM_UNSPECIFIED;
+ if (mode == SCM_PORT_READ
+ && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read
+ && looking_at_bytes (port, scm_utf32le_bom, sizeof scm_utf32le_bom))
+ return "UTF-32LE";
+ else
+ return "UTF-32BE";
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
- (SCM port),
- "Return the next character available from @var{port}, updating\n"
- "@var{port} to point to the following character. If no more\n"
- "characters are available, the end-of-file object is returned.\n"
- "\n"
- "When @var{port}'s data cannot be decoded according to its\n"
- "character encoding, a @code{decoding-error} is raised and\n"
- "@var{port} points past the erroneous byte sequence.\n")
-#define FUNC_NAME s_scm_read_char
+static void
+finalize_iconv_descriptors (void *ptr, void *data)
{
- scm_t_wchar c;
- if (SCM_UNBNDP (port))
- port = scm_current_input_port ();
- SCM_VALIDATE_OPINPORT (1, port);
- c = scm_getc (port);
- if (EOF == c)
- return SCM_EOF_VAL;
- return SCM_MAKE_CHAR (c);
+ close_iconv_descriptors (ptr);
}
-#undef FUNC_NAME
-/* Update the line and column number of PORT after consumption of C. */
-static inline void
-update_port_lf (scm_t_wchar c, SCM port)
+static scm_t_iconv_descriptors *
+open_iconv_descriptors (const char *encoding, int reading, int writing)
{
- switch (c)
+ scm_t_iconv_descriptors *id;
+ iconv_t input_cd, output_cd;
+ size_t i;
+
+ input_cd = (iconv_t) -1;
+ output_cd = (iconv_t) -1;
+
+ for (i = 0; encoding[i]; i++)
+ if (encoding[i] > 127)
+ goto invalid_encoding;
+
+ if (reading)
{
- case '\a':
- case EOF:
- break;
- case '\b':
- SCM_DECCOL (port);
- break;
- case '\n':
- SCM_INCLINE (port);
- break;
- case '\r':
- SCM_ZEROCOL (port);
- break;
- case '\t':
- SCM_TABCOL (port);
- break;
- default:
- SCM_INCCOL (port);
- break;
- }
-}
-
-#define SCM_MBCHAR_BUF_SIZE (4)
+ /* Open an input iconv conversion descriptor, from ENCODING
+ to UTF-8. We choose UTF-8, not UTF-32, because iconv
+ implementations can typically convert from anything to
+ UTF-8, but not to UTF-32 (see
+ <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
-/* Convert the SIZE-byte UTF-8 sequence in UTF8_BUF to a codepoint.
- UTF8_BUF is assumed to contain a valid UTF-8 sequence. */
-static scm_t_wchar
-utf8_to_codepoint (const scm_t_uint8 *utf8_buf, size_t size)
-{
- scm_t_wchar codepoint;
+ /* Assume opening an iconv descriptor causes about 16 KB of
+ allocation. */
+ scm_gc_register_allocation (16 * 1024);
- if (utf8_buf[0] <= 0x7f)
- {
- assert (size == 1);
- codepoint = utf8_buf[0];
- }
- else if ((utf8_buf[0] & 0xe0) == 0xc0)
- {
- assert (size == 2);
- codepoint = ((scm_t_wchar) utf8_buf[0] & 0x1f) << 6UL
- | (utf8_buf[1] & 0x3f);
- }
- else if ((utf8_buf[0] & 0xf0) == 0xe0)
- {
- assert (size == 3);
- codepoint = ((scm_t_wchar) utf8_buf[0] & 0x0f) << 12UL
- | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 6UL
- | (utf8_buf[2] & 0x3f);
+ input_cd = iconv_open ("UTF-8", encoding);
+ if (input_cd == (iconv_t) -1)
+ goto invalid_encoding;
}
- else
+
+ if (writing)
{
- assert (size == 4);
- codepoint = ((scm_t_wchar) utf8_buf[0] & 0x07) << 18UL
- | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 12UL
- | ((scm_t_wchar) utf8_buf[2] & 0x3f) << 6UL
- | (utf8_buf[3] & 0x3f);
+ /* Assume opening an iconv descriptor causes about 16 KB of
+ allocation. */
+ scm_gc_register_allocation (16 * 1024);
+
+ output_cd = iconv_open (encoding, "UTF-8");
+ if (output_cd == (iconv_t) -1)
+ {
+ if (input_cd != (iconv_t) -1)
+ iconv_close (input_cd);
+ goto invalid_encoding;
+ }
}
- return codepoint;
-}
+ id = scm_gc_malloc_pointerless (sizeof (*id), "iconv descriptors");
+ id->input_cd = input_cd;
+ id->output_cd = output_cd;
-/* Read a UTF-8 sequence from PORT. On success, return 0 and set
- *CODEPOINT to the codepoint that was read, fill BUF with its UTF-8
- representation, and set *LEN to the length in bytes. Return
- `EILSEQ' on error. */
-static int
-get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
- scm_t_uint8 buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
-{
-#define ASSERT_NOT_EOF(b) \
- if (SCM_UNLIKELY ((b) == EOF)) \
- goto invalid_seq
-#define CONSUME_PEEKED_BYTE() \
- pt->read_pos++
+ /* Register a finalizer to close the descriptors. */
+ scm_i_set_finalizer (id, finalize_iconv_descriptors, NULL);
- int byte;
- scm_t_port *pt;
+ return id;
- *len = 0;
- pt = SCM_PTAB_ENTRY (port);
+ invalid_encoding:
+ {
+ SCM err;
+ err = scm_from_latin1_string (encoding);
+ scm_misc_error ("open_iconv_descriptors",
+ "invalid or unknown character encoding ~s",
+ scm_list_1 (err));
+ }
+}
- byte = scm_get_byte_or_eof (port);
- if (byte == EOF)
- {
- *codepoint = EOF;
- return 0;
- }
+static void
+close_iconv_descriptors (scm_t_iconv_descriptors *id)
+{
+ if (id->input_cd != (iconv_t) -1)
+ iconv_close (id->input_cd);
+ if (id->output_cd != (iconv_t) -1)
+ iconv_close (id->output_cd);
+ id->input_cd = (void *) -1;
+ id->output_cd = (void *) -1;
+}
- buf[0] = (scm_t_uint8) byte;
- *len = 1;
+scm_t_iconv_descriptors *
+scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode)
+{
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
- if (buf[0] <= 0x7f)
- /* 1-byte form. */
- *codepoint = buf[0];
- else if (buf[0] >= 0xc2 && buf[0] <= 0xdf)
+ assert (pti->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV);
+
+ if (!pti->iconv_descriptors)
{
- /* 2-byte form. */
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ const char *precise_encoding;
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
- goto invalid_seq;
+ if (!pt->encoding)
+ pt->encoding = "ISO-8859-1";
- CONSUME_PEEKED_BYTE ();
- buf[1] = (scm_t_uint8) byte;
- *len = 2;
+ /* If the specified encoding is UTF-16 or UTF-32, then make
+ that more precise by deciding what byte order to use. */
+ if (strcmp (pt->encoding, "UTF-16") == 0)
+ precise_encoding = decide_utf16_encoding (port, mode);
+ else if (strcmp (pt->encoding, "UTF-32") == 0)
+ precise_encoding = decide_utf32_encoding (port, mode);
+ else
+ precise_encoding = pt->encoding;
- *codepoint = ((scm_t_wchar) buf[0] & 0x1f) << 6UL
- | (buf[1] & 0x3f);
+ pti->iconv_descriptors =
+ open_iconv_descriptors (precise_encoding,
+ SCM_INPUT_PORT_P (port),
+ SCM_OUTPUT_PORT_P (port));
}
- else if ((buf[0] & 0xf0) == 0xe0)
- {
- /* 3-byte form. */
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
-
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80
- || (buf[0] == 0xe0 && byte < 0xa0)
- || (buf[0] == 0xed && byte > 0x9f)))
- goto invalid_seq;
- CONSUME_PEEKED_BYTE ();
- buf[1] = (scm_t_uint8) byte;
- *len = 2;
+ return pti->iconv_descriptors;
+}
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
+/* The name of the encoding is itself encoded in ASCII. */
+void
+scm_i_set_port_encoding_x (SCM port, const char *encoding)
+{
+ scm_t_port *pt;
+ scm_t_port_internal *pti;
+ scm_t_iconv_descriptors *prev;
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
- goto invalid_seq;
+ /* Set the character encoding for this port. */
+ pt = SCM_PTAB_ENTRY (port);
+ pti = SCM_PORT_GET_INTERNAL (port);
+ prev = pti->iconv_descriptors;
- CONSUME_PEEKED_BYTE ();
- buf[2] = (scm_t_uint8) byte;
- *len = 3;
+ /* In order to handle cases where the encoding changes mid-stream
+ (e.g. within an HTTP stream, or within a file that is composed of
+ segments with different encodings), we consider this to be "stream
+ start" for purposes of BOM handling, regardless of our actual file
+ position. */
+ pti->at_stream_start_for_bom_read = 1;
+ pti->at_stream_start_for_bom_write = 1;
- *codepoint = ((scm_t_wchar) buf[0] & 0x0f) << 12UL
- | ((scm_t_wchar) buf[1] & 0x3f) << 6UL
- | (buf[2] & 0x3f);
+ if (encoding_matches (encoding, "UTF-8"))
+ {
+ pt->encoding = "UTF-8";
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
}
- else if (buf[0] >= 0xf0 && buf[0] <= 0xf4)
+ else if (encoding_matches (encoding, "ISO-8859-1"))
{
- /* 4-byte form. */
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
-
- if (SCM_UNLIKELY (((byte & 0xc0) != 0x80)
- || (buf[0] == 0xf0 && byte < 0x90)
- || (buf[0] == 0xf4 && byte > 0x8f)))
- goto invalid_seq;
-
- CONSUME_PEEKED_BYTE ();
- buf[1] = (scm_t_uint8) byte;
- *len = 2;
-
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
-
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
- goto invalid_seq;
-
- CONSUME_PEEKED_BYTE ();
- buf[2] = (scm_t_uint8) byte;
- *len = 3;
-
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
-
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
- goto invalid_seq;
-
- CONSUME_PEEKED_BYTE ();
- buf[3] = (scm_t_uint8) byte;
- *len = 4;
-
- *codepoint = ((scm_t_wchar) buf[0] & 0x07) << 18UL
- | ((scm_t_wchar) buf[1] & 0x3f) << 12UL
- | ((scm_t_wchar) buf[2] & 0x3f) << 6UL
- | (buf[3] & 0x3f);
+ pt->encoding = "ISO-8859-1";
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
}
else
- goto invalid_seq;
-
- return 0;
-
- invalid_seq:
- /* Here we could choose the consume the faulty byte when it's not a
- valid starting byte, but it's not a requirement. What Section 3.9
- of Unicode 6.0.0 mandates, though, is to not consume a byte that
- would otherwise be a valid starting byte. */
-
- return EILSEQ;
+ {
+ pt->encoding = canonicalize_encoding (encoding);
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+ }
-#undef CONSUME_PEEKED_BYTE
-#undef ASSERT_NOT_EOF
+ pti->iconv_descriptors = NULL;
+ if (prev)
+ close_iconv_descriptors (prev);
}
-/* Likewise, read a byte sequence from PORT, passing it through its
- input conversion descriptor. */
-static int
-get_iconv_codepoint (SCM port, scm_t_wchar *codepoint,
- char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
+SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0,
+ (SCM port),
+ "Returns, as a string, the character encoding that @var{port}\n"
+ "uses to interpret its input and output.\n")
+#define FUNC_NAME s_scm_port_encoding
{
- scm_t_iconv_descriptors *id;
- scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE];
- size_t input_size = 0;
+ SCM_VALIDATE_PORT (1, port);
- id = scm_i_port_iconv_descriptors (port, SCM_PORT_READ);
+ return scm_from_latin1_string (SCM_PTAB_ENTRY (port)->encoding);
+}
+#undef FUNC_NAME
- for (;;)
- {
- int byte_read;
- char *input, *output;
- size_t input_left, output_left, done;
+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"
+ "port I/O. New ports are created with the encoding\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;
- byte_read = scm_get_byte_or_eof (port);
- if (SCM_UNLIKELY (byte_read == EOF))
- {
- if (SCM_LIKELY (input_size == 0))
- {
- *codepoint = (scm_t_wchar) EOF;
- *len = input_size;
- return 0;
- }
- else
- {
- /* EOF found in the middle of a multibyte character. */
- scm_i_set_pending_eof (port);
- return EILSEQ;
- }
- }
+ SCM_VALIDATE_PORT (1, port);
+ SCM_VALIDATE_STRING (2, enc);
- buf[input_size++] = byte_read;
+ enc_str = scm_to_latin1_string (enc);
+ scm_i_set_port_encoding_x (port, enc_str);
+ free (enc_str);
- input = buf;
- input_left = input_size;
- output = (char *) utf8_buf;
- output_left = sizeof (utf8_buf);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
- done = iconv (id->input_cd, &input, &input_left, &output, &output_left);
+SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy",
+ 1, 0, 0, (SCM port),
+ "Returns the behavior of the port when handling a character that\n"
+ "is not representable in the port's current encoding.\n"
+ "It returns the symbol @code{error} if unrepresentable characters\n"
+ "should cause exceptions, @code{substitute} if the port should\n"
+ "try to replace unrepresentable characters with question marks or\n"
+ "approximate characters, or @code{escape} if unrepresentable\n"
+ "characters should be converted to string escapes.\n"
+ "\n"
+ "If @var{port} is @code{#f}, then the current default behavior\n"
+ "will be returned. New ports will have this default behavior\n"
+ "when they are created.\n")
+#define FUNC_NAME s_scm_port_conversion_strategy
+{
+ scm_t_string_failed_conversion_handler h;
- if (done == (size_t) -1)
- {
- int err = errno;
- if (SCM_LIKELY (err == EINVAL))
- /* The input byte sequence did not form a complete
- character. Read another byte and try again. */
- continue;
- else
- return err;
- }
- else
- {
- size_t output_size = sizeof (utf8_buf) - output_left;
- if (SCM_LIKELY (output_size > 0))
- {
- /* iconv generated output. Convert the UTF8_BUF sequence
- to a Unicode code point. */
- *codepoint = utf8_to_codepoint (utf8_buf, output_size);
- *len = input_size;
- return 0;
- }
- else
- {
- /* iconv consumed some bytes without producing any output.
- Most likely this means that a Unicode byte-order mark
- (BOM) was consumed, which should not be included in the
- returned buf. Shift any remaining bytes to the beginning
- of buf, and continue the loop. */
- memmove (buf, input, input_left);
- input_size = input_left;
- continue;
- }
- }
+ if (scm_is_false (port))
+ h = scm_i_default_port_conversion_handler ();
+ else
+ {
+ scm_t_port *pt;
+
+ SCM_VALIDATE_OPPORT (1, port);
+ pt = SCM_PTAB_ENTRY (port);
+
+ h = pt->ilseq_handler;
}
+
+ if (h == SCM_FAILED_CONVERSION_ERROR)
+ return scm_from_latin1_symbol ("error");
+ else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK)
+ return scm_from_latin1_symbol ("substitute");
+ else if (h == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ return scm_from_latin1_symbol ("escape");
+ else
+ abort ();
+
+ /* Never gets here. */
+ return SCM_UNDEFINED;
}
+#undef FUNC_NAME
-/* Read a codepoint from PORT and return it in *CODEPOINT. Fill BUF
- with the byte representation of the codepoint in PORT's encoding, and
- set *LEN to the length in bytes of that representation. Return 0 on
- success and an errno value on error. */
-static int
-get_codepoint (SCM port, scm_t_wchar *codepoint,
- char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
+SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!",
+ 2, 0, 0,
+ (SCM port, SCM sym),
+ "Sets the behavior of the interpreter when outputting a character\n"
+ "that is not representable in the port's current encoding.\n"
+ "@var{sym} can be either @code{'error}, @code{'substitute}, or\n"
+ "@code{'escape}. If it is @code{'error}, an error will be thrown\n"
+ "when an unconvertible character is encountered. If it is\n"
+ "@code{'substitute}, then unconvertible characters will \n"
+ "be replaced with approximate characters, or with question marks\n"
+ "if no approximately correct character is available.\n"
+ "If it is @code{'escape},\n"
+ "it will appear as a hex escape when output.\n"
+ "\n"
+ "If @var{port} is an open port, the conversion error behavior\n"
+ "is set for that port. If it is @code{#f}, it is set as the\n"
+ "default behavior for any future ports that get created in\n"
+ "this thread.\n")
+#define FUNC_NAME s_scm_set_port_conversion_strategy_x
{
- int err;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
+ scm_t_string_failed_conversion_handler handler;
- if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
- err = get_utf8_codepoint (port, codepoint, (scm_t_uint8 *) buf, len);
+ if (scm_is_eq (sym, sym_error))
+ handler = SCM_FAILED_CONVERSION_ERROR;
+ else if (scm_is_eq (sym, sym_substitute))
+ handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else if (scm_is_eq (sym, sym_escape))
+ handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE;
else
- err = get_iconv_codepoint (port, codepoint, buf, len);
+ SCM_MISC_ERROR ("unknown conversion strategy ~s", scm_list_1 (sym));
- if (SCM_LIKELY (err == 0))
+ if (scm_is_false (port))
+ scm_i_set_default_port_conversion_handler (handler);
+ else
{
- if (SCM_UNLIKELY (pti->at_stream_start_for_bom_read))
- {
- /* Record that we're no longer at stream start. */
- pti->at_stream_start_for_bom_read = 0;
- if (pt->rw_random)
- pti->at_stream_start_for_bom_write = 0;
+ SCM_VALIDATE_OPPORT (1, port);
+ SCM_PTAB_ENTRY (port)->ilseq_handler = handler;
+ }
- /* If we just read a BOM in an encoding that recognizes them,
- then silently consume it and read another code point. */
- if (SCM_UNLIKELY
- (*codepoint == SCM_UNICODE_BOM
- && (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8
- || c_strcasecmp (pt->encoding, "UTF-16") == 0
- || c_strcasecmp (pt->encoding, "UTF-32") == 0)))
- return get_codepoint (port, codepoint, buf, len);
- }
- update_port_lf (*codepoint, port);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+\f
+
+/* The port lock. */
+
+static void
+lock_port (void *mutex)
+{
+ scm_i_pthread_mutex_lock ((scm_i_pthread_mutex_t *) mutex);
+}
+
+static void
+unlock_port (void *mutex)
+{
+ scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t *) mutex);
+}
+
+void
+scm_dynwind_lock_port (SCM port)
+#define FUNC_NAME "dynwind-lock-port"
+{
+ scm_i_pthread_mutex_t *lock;
+ SCM_VALIDATE_OPPORT (SCM_ARG1, port);
+ scm_c_lock_port (port, &lock);
+ if (lock)
+ {
+ scm_dynwind_unwind_handler (unlock_port, lock, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_rewind_handler (lock_port, lock, 0);
}
- else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK)
+}
+#undef FUNC_NAME
+
+
+\f
+
+/* Input. */
+
+int
+scm_get_byte_or_eof (SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ int ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_get_byte_or_eof_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+ return ret;
+}
+
+int
+scm_peek_byte_or_eof (SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ int ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_peek_byte_or_eof_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+ return ret;
+}
+
+/* scm_c_read
+ *
+ * Used by an application to read arbitrary number of bytes from an
+ * SCM port. Same semantics as libc read, except that scm_c_read only
+ * returns less than SIZE bytes if at end-of-file.
+ *
+ * Warning: Doesn't update port line and column counts! */
+
+/* This structure, and the following swap_buffer function, are used
+ for temporarily swapping a port's own read buffer, and the buffer
+ that the caller of scm_c_read provides. */
+struct port_and_swap_buffer
+{
+ scm_t_port *pt;
+ unsigned char *buffer;
+ size_t size;
+};
+
+static void
+swap_buffer (void *data)
+{
+ struct port_and_swap_buffer *psb = (struct port_and_swap_buffer *) data;
+ unsigned char *old_buf = psb->pt->read_buf;
+ size_t old_size = psb->pt->read_buf_size;
+
+ /* Make the port use (buffer, size) from the struct. */
+ psb->pt->read_pos = psb->pt->read_buf = psb->pt->read_end = psb->buffer;
+ psb->pt->read_buf_size = psb->size;
+
+ /* Save the port's old (buffer, size) in the struct. */
+ psb->buffer = old_buf;
+ psb->size = old_size;
+}
+
+static int scm_i_fill_input_unlocked (SCM port);
+
+size_t
+scm_c_read_unlocked (SCM port, void *buffer, size_t size)
+#define FUNC_NAME "scm_c_read"
+{
+ scm_t_port *pt;
+ scm_t_port_internal *pti;
+ size_t n_read = 0, n_available;
+ struct port_and_swap_buffer psb;
+
+ SCM_VALIDATE_OPINPORT (1, port);
+
+ pt = SCM_PTAB_ENTRY (port);
+ pti = SCM_PORT_GET_INTERNAL (port);
+ if (pt->rw_active == SCM_PORT_WRITE)
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ /* Take bytes first from the port's read buffer. */
+ if (pt->read_pos < pt->read_end)
{
- *codepoint = '?';
- err = 0;
- update_port_lf (*codepoint, port);
+ n_available = min (size, pt->read_end - pt->read_pos);
+ memcpy (buffer, pt->read_pos, n_available);
+ buffer = (char *) buffer + n_available;
+ pt->read_pos += n_available;
+ n_read += n_available;
+ size -= n_available;
+ }
+
+ /* Avoid the scm_dynwind_* costs if we now have enough data. */
+ if (size == 0)
+ return n_read;
+
+ /* Now we will call scm_i_fill_input_unlocked repeatedly until we have
+ read the requested number of bytes. (Note that a single
+ scm_i_fill_input_unlocked call does not guarantee to fill the whole
+ of the port's read buffer.) */
+ if (pt->read_buf_size <= 1
+ && pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ {
+ /* The port that we are reading from is unbuffered - i.e. does not
+ have its own persistent buffer - but we have a buffer, provided
+ by our caller, that is the right size for the data that is
+ wanted. For the following scm_i_fill_input_unlocked calls,
+ therefore, we use the buffer in hand as the port's read buffer.
+
+ We need to make sure that the port's normal (1 byte) buffer is
+ reinstated in case one of the scm_i_fill_input_unlocked ()
+ calls throws an exception; we use the scm_dynwind_* API to
+ achieve 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;
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
+
+ /* Call scm_i_fill_input_unlocked until we have all the bytes that
+ we need, or we hit EOF. */
+ while (pt->read_buf_size && (scm_i_fill_input_unlocked (port) != EOF))
+ {
+ 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 ();
+ }
+ else
+ {
+ /* The port has its own buffer. It is important that we use it,
+ even if it happens to be smaller than our caller's buffer, so
+ that a custom port implementation's entry points (in
+ particular, fill_input) can rely on the buffer always being
+ the same as they first set up. */
+ while (size && (scm_i_fill_input_unlocked (port) != EOF))
+ {
+ n_available = min (size, pt->read_end - pt->read_pos);
+ memcpy (buffer, pt->read_pos, n_available);
+ buffer = (char *) buffer + n_available;
+ pt->read_pos += n_available;
+ n_read += n_available;
+ size -= n_available;
+ }
+ }
+
+ return n_read;
+}
+#undef FUNC_NAME
+
+size_t
+scm_c_read (SCM port, void *buffer, size_t size)
+{
+ scm_i_pthread_mutex_t *lock;
+ size_t ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_c_read_unlocked (port, buffer, size);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+
+ return ret;
+}
+
+/* Update the line and column number of PORT after consumption of C. */
+static inline void
+update_port_lf (scm_t_wchar c, SCM port)
+{
+ switch (c)
+ {
+ case '\a':
+ case EOF:
+ break;
+ case '\b':
+ SCM_DECCOL (port);
+ break;
+ case '\n':
+ SCM_INCLINE (port);
+ break;
+ case '\r':
+ SCM_ZEROCOL (port);
+ break;
+ case '\t':
+ SCM_TABCOL (port);
+ break;
+ default:
+ SCM_INCCOL (port);
+ break;
}
-
- return err;
}
-/* Read a codepoint from PORT and return it. */
-scm_t_wchar
-scm_getc (SCM port)
-#define FUNC_NAME "scm_getc"
-{
- int err;
- size_t len;
- scm_t_wchar codepoint;
- char buf[SCM_MBCHAR_BUF_SIZE];
-
- err = get_codepoint (port, &codepoint, buf, &len);
- if (SCM_UNLIKELY (err != 0))
- /* At this point PORT should point past the invalid encoding, as per
- R6RS-lib Section 8.2.4. */
- scm_decoding_error (FUNC_NAME, err, "input decoding error", port);
-
- return codepoint;
-}
-#undef FUNC_NAME
+#define SCM_MBCHAR_BUF_SIZE (4)
-/* this should only be called when the read buffer is empty. it
- tries to refill the read buffer. it returns the first char from
- the port, which is either EOF or *(pt->read_pos). */
-static int
-scm_i_fill_input (SCM port)
+/* Convert the SIZE-byte UTF-8 sequence in UTF8_BUF to a codepoint.
+ UTF8_BUF is assumed to contain a valid UTF-8 sequence. */
+static scm_t_wchar
+utf8_to_codepoint (const scm_t_uint8 *utf8_buf, size_t size)
{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
-
- assert (pt->read_pos == pt->read_end);
+ scm_t_wchar codepoint;
- if (pti->pending_eof)
+ if (utf8_buf[0] <= 0x7f)
{
- pti->pending_eof = 0;
- return EOF;
+ assert (size == 1);
+ codepoint = utf8_buf[0];
}
-
- if (pt->read_buf == pt->putback_buf)
+ else if ((utf8_buf[0] & 0xe0) == 0xc0)
{
- /* finished reading put-back chars. */
- pt->read_buf = pt->saved_read_buf;
- pt->read_pos = pt->saved_read_pos;
- pt->read_end = pt->saved_read_end;
- pt->read_buf_size = pt->saved_read_buf_size;
- if (pt->read_pos < pt->read_end)
- return *(pt->read_pos);
+ assert (size == 2);
+ codepoint = ((scm_t_wchar) utf8_buf[0] & 0x1f) << 6UL
+ | (utf8_buf[1] & 0x3f);
+ }
+ else if ((utf8_buf[0] & 0xf0) == 0xe0)
+ {
+ assert (size == 3);
+ codepoint = ((scm_t_wchar) utf8_buf[0] & 0x0f) << 12UL
+ | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 6UL
+ | (utf8_buf[2] & 0x3f);
+ }
+ else
+ {
+ assert (size == 4);
+ codepoint = ((scm_t_wchar) utf8_buf[0] & 0x07) << 18UL
+ | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 12UL
+ | ((scm_t_wchar) utf8_buf[2] & 0x3f) << 6UL
+ | (utf8_buf[3] & 0x3f);
}
- return scm_ptobs[SCM_PTOBNUM (port)].fill_input (port);
-}
-int
-scm_fill_input (SCM port)
-{
- return scm_i_fill_input (port);
+ return codepoint;
}
-/* Slow-path fallback for 'scm_get_byte_or_eof' in inline.h */
-int
-scm_slow_get_byte_or_eof (SCM port)
+/* Read a UTF-8 sequence from PORT. On success, return 0 and set
+ *CODEPOINT to the codepoint that was read, fill BUF with its UTF-8
+ representation, and set *LEN to the length in bytes. Return
+ `EILSEQ' on error. */
+static int
+get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
+ scm_t_uint8 buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
+#define ASSERT_NOT_EOF(b) \
+ if (SCM_UNLIKELY ((b) == EOF)) \
+ goto invalid_seq
+#define CONSUME_PEEKED_BYTE() \
+ pt->read_pos++
- if (pt->rw_active == SCM_PORT_WRITE)
- scm_flush (port);
+ int byte;
+ scm_t_port *pt;
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
+ *len = 0;
+ pt = SCM_PTAB_ENTRY (port);
- if (pt->read_pos >= pt->read_end)
+ byte = scm_get_byte_or_eof_unlocked (port);
+ if (byte == EOF)
{
- if (SCM_UNLIKELY (scm_i_fill_input (port) == EOF))
- return EOF;
+ *codepoint = EOF;
+ return 0;
}
- return *pt->read_pos++;
-}
+ buf[0] = (scm_t_uint8) byte;
+ *len = 1;
-/* Slow-path fallback for 'scm_peek_byte_or_eof' in inline.h */
-int
-scm_slow_peek_byte_or_eof (SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ if (buf[0] <= 0x7f)
+ /* 1-byte form. */
+ *codepoint = buf[0];
+ else if (buf[0] >= 0xc2 && buf[0] <= 0xdf)
+ {
+ /* 2-byte form. */
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
- if (pt->rw_active == SCM_PORT_WRITE)
- scm_flush (port);
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
+ goto invalid_seq;
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
+ CONSUME_PEEKED_BYTE ();
+ buf[1] = (scm_t_uint8) byte;
+ *len = 2;
- if (pt->read_pos >= pt->read_end)
- {
- if (SCM_UNLIKELY (scm_i_fill_input (port) == EOF))
- {
- scm_i_set_pending_eof (port);
- return EOF;
- }
+ *codepoint = ((scm_t_wchar) buf[0] & 0x1f) << 6UL
+ | (buf[1] & 0x3f);
}
+ else if ((buf[0] & 0xf0) == 0xe0)
+ {
+ /* 3-byte form. */
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
- return *pt->read_pos;
-}
-
-
-/* scm_lfwrite
- *
- * This function differs from scm_c_write; it updates port line and
- * column. */
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80
+ || (buf[0] == 0xe0 && byte < 0xa0)
+ || (buf[0] == 0xed && byte > 0x9f)))
+ goto invalid_seq;
-void
-scm_lfwrite (const char *ptr, size_t size, SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+ CONSUME_PEEKED_BYTE ();
+ buf[1] = (scm_t_uint8) byte;
+ *len = 2;
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
- ptob->write (port, ptr, size);
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
+ goto invalid_seq;
- for (; size; ptr++, size--)
- update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port);
+ CONSUME_PEEKED_BYTE ();
+ buf[2] = (scm_t_uint8) byte;
+ *len = 3;
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
-}
+ *codepoint = ((scm_t_wchar) buf[0] & 0x0f) << 12UL
+ | ((scm_t_wchar) buf[1] & 0x3f) << 6UL
+ | (buf[2] & 0x3f);
+ }
+ else if (buf[0] >= 0xf0 && buf[0] <= 0xf4)
+ {
+ /* 4-byte form. */
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
-/* Write STR to PORT from START inclusive to END exclusive. */
-void
-scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ if (SCM_UNLIKELY (((byte & 0xc0) != 0x80)
+ || (buf[0] == 0xf0 && byte < 0x90)
+ || (buf[0] == 0xf4 && byte > 0x8f)))
+ goto invalid_seq;
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ CONSUME_PEEKED_BYTE ();
+ buf[1] = (scm_t_uint8) byte;
+ *len = 2;
- if (end == (size_t) -1)
- end = scm_i_string_length (str);
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
- scm_i_display_substring (str, start, end, port);
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
+ goto invalid_seq;
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
-}
+ CONSUME_PEEKED_BYTE ();
+ buf[2] = (scm_t_uint8) byte;
+ *len = 3;
-/* scm_c_read
- *
- * Used by an application to read arbitrary number of bytes from an
- * SCM port. Same semantics as libc read, except that scm_c_read only
- * returns less than SIZE bytes if at end-of-file.
- *
- * Warning: Doesn't update port line and column counts! */
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
-/* This structure, and the following swap_buffer function, are used
- for temporarily swapping a port's own read buffer, and the buffer
- that the caller of scm_c_read provides. */
-struct port_and_swap_buffer
-{
- scm_t_port *pt;
- unsigned char *buffer;
- size_t size;
-};
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
+ goto invalid_seq;
-static void
-swap_buffer (void *data)
-{
- struct port_and_swap_buffer *psb = (struct port_and_swap_buffer *) data;
- unsigned char *old_buf = psb->pt->read_buf;
- size_t old_size = psb->pt->read_buf_size;
+ CONSUME_PEEKED_BYTE ();
+ buf[3] = (scm_t_uint8) byte;
+ *len = 4;
- /* Make the port use (buffer, size) from the struct. */
- psb->pt->read_pos = psb->pt->read_buf = psb->pt->read_end = psb->buffer;
- psb->pt->read_buf_size = psb->size;
+ *codepoint = ((scm_t_wchar) buf[0] & 0x07) << 18UL
+ | ((scm_t_wchar) buf[1] & 0x3f) << 12UL
+ | ((scm_t_wchar) buf[2] & 0x3f) << 6UL
+ | (buf[3] & 0x3f);
+ }
+ else
+ goto invalid_seq;
- /* Save the port's old (buffer, size) in the struct. */
- psb->buffer = old_buf;
- psb->size = old_size;
-}
+ return 0;
-size_t
-scm_c_read (SCM port, void *buffer, size_t size)
-#define FUNC_NAME "scm_c_read"
-{
- scm_t_port *pt;
- size_t n_read = 0, n_available;
- struct port_and_swap_buffer psb;
+ invalid_seq:
+ /* Here we could choose the consume the faulty byte when it's not a
+ valid starting byte, but it's not a requirement. What Section 3.9
+ of Unicode 6.0.0 mandates, though, is to not consume a byte that
+ would otherwise be a valid starting byte. */
- SCM_VALIDATE_OPINPORT (1, port);
+ return EILSEQ;
- pt = SCM_PTAB_ENTRY (port);
- if (pt->rw_active == SCM_PORT_WRITE)
- scm_ptobs[SCM_PTOBNUM (port)].flush (port);
+#undef CONSUME_PEEKED_BYTE
+#undef ASSERT_NOT_EOF
+}
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
+/* Read an ISO-8859-1 codepoint (a byte) from PORT. On success, return
+ 0 and set *CODEPOINT to the codepoint that was read, fill BUF with
+ its UTF-8 representation, and set *LEN to the length in bytes.
+ Return `EILSEQ' on error. */
+static int
+get_latin1_codepoint (SCM port, scm_t_wchar *codepoint,
+ char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
+{
+ *codepoint = scm_get_byte_or_eof_unlocked (port);
- /* Take bytes first from the port's read buffer. */
- if (pt->read_pos < pt->read_end)
+ if (*codepoint == EOF)
+ *len = 0;
+ else
{
- n_available = min (size, pt->read_end - pt->read_pos);
- memcpy (buffer, pt->read_pos, n_available);
- buffer = (char *) buffer + n_available;
- pt->read_pos += n_available;
- n_read += n_available;
- size -= n_available;
+ *len = 1;
+ buf[0] = *codepoint;
}
+ return 0;
+}
- /* Avoid the scm_dynwind_* costs if we now have enough data. */
- if (size == 0)
- return n_read;
+/* Likewise, read a byte sequence from PORT, passing it through its
+ input conversion descriptor. */
+static int
+get_iconv_codepoint (SCM port, scm_t_wchar *codepoint,
+ char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
+{
+ scm_t_iconv_descriptors *id;
+ scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE];
+ size_t input_size = 0;
+
+ id = scm_i_port_iconv_descriptors (port, SCM_PORT_READ);
- /* Now we will call scm_i_fill_input repeatedly until we have read the
- requested number of bytes. (Note that a single scm_i_fill_input
- call does not guarantee to fill the whole of the port's read
- buffer.) */
- if (pt->read_buf_size <= 1 &&
- (pt->encoding == NULL
- || c_strcasecmp (pt->encoding, "ISO-8859-1") == 0))
+ for (;;)
{
- /* The port that we are reading from is unbuffered - i.e. does
- not have its own persistent buffer - but we have a buffer,
- provided by our caller, that is the right size for the data
- that is wanted. For the following scm_i_fill_input calls,
- therefore, we use the buffer in hand as the port's read
- buffer.
-
- We need to make sure that the port's normal (1 byte) buffer
- is reinstated in case one of the scm_i_fill_input () calls
- throws an exception; we use the scm_dynwind_* API to achieve
- that.
+ int byte_read;
+ char *input, *output;
+ size_t input_left, output_left, done;
- 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;
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
+ byte_read = scm_get_byte_or_eof_unlocked (port);
+ if (SCM_UNLIKELY (byte_read == EOF))
+ {
+ if (SCM_LIKELY (input_size == 0))
+ {
+ *codepoint = (scm_t_wchar) EOF;
+ *len = input_size;
+ return 0;
+ }
+ else
+ {
+ /* EOF found in the middle of a multibyte character. */
+ scm_i_set_pending_eof (port);
+ return EILSEQ;
+ }
+ }
+
+ buf[input_size++] = byte_read;
+
+ input = buf;
+ input_left = input_size;
+ output = (char *) utf8_buf;
+ output_left = sizeof (utf8_buf);
+
+ done = iconv (id->input_cd, &input, &input_left, &output, &output_left);
- /* Call scm_i_fill_input until we have all the bytes that we need,
- or we hit EOF. */
- while (pt->read_buf_size && (scm_i_fill_input (port) != EOF))
+ if (done == (size_t) -1)
{
- pt->read_buf_size -= (pt->read_end - pt->read_pos);
- pt->read_pos = pt->read_buf = pt->read_end;
+ int err = errno;
+ if (SCM_LIKELY (err == EINVAL))
+ /* The input byte sequence did not form a complete
+ character. Read another byte and try again. */
+ continue;
+ else
+ return err;
}
-#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 ();
+ else
+ {
+ size_t output_size = sizeof (utf8_buf) - output_left;
+ if (SCM_LIKELY (output_size > 0))
+ {
+ /* iconv generated output. Convert the UTF8_BUF sequence
+ to a Unicode code point. */
+ *codepoint = utf8_to_codepoint (utf8_buf, output_size);
+ *len = input_size;
+ return 0;
+ }
+ else
+ {
+ /* iconv consumed some bytes without producing any output.
+ Most likely this means that a Unicode byte-order mark
+ (BOM) was consumed, which should not be included in the
+ returned buf. Shift any remaining bytes to the beginning
+ of buf, and continue the loop. */
+ memmove (buf, input, input_left);
+ input_size = input_left;
+ continue;
+ }
+ }
}
+}
+
+/* Read a codepoint from PORT and return it in *CODEPOINT. Fill BUF
+ with the byte representation of the codepoint in PORT's encoding, and
+ set *LEN to the length in bytes of that representation. Return 0 on
+ success and an errno value on error. */
+static SCM_C_INLINE int
+get_codepoint (SCM port, scm_t_wchar *codepoint,
+ char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
+{
+ int err;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
+
+ if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
+ err = get_utf8_codepoint (port, codepoint, (scm_t_uint8 *) buf, len);
+ else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ err = get_latin1_codepoint (port, codepoint, buf, len);
else
+ err = get_iconv_codepoint (port, codepoint, buf, len);
+
+ if (SCM_LIKELY (err == 0))
{
- /* The port has its own buffer. It is important that we use it,
- even if it happens to be smaller than our caller's buffer, so
- that a custom port implementation's entry points (in
- particular, fill_input) can rely on the buffer always being
- the same as they first set up. */
- while (size && (scm_i_fill_input (port) != EOF))
- {
- n_available = min (size, pt->read_end - pt->read_pos);
- memcpy (buffer, pt->read_pos, n_available);
- buffer = (char *) buffer + n_available;
- pt->read_pos += n_available;
- n_read += n_available;
- size -= n_available;
- }
+ if (SCM_UNLIKELY (pti->at_stream_start_for_bom_read))
+ {
+ /* Record that we're no longer at stream start. */
+ pti->at_stream_start_for_bom_read = 0;
+ if (pt->rw_random)
+ pti->at_stream_start_for_bom_write = 0;
+
+ /* If we just read a BOM in an encoding that recognizes them,
+ then silently consume it and read another code point. */
+ if (SCM_UNLIKELY
+ (*codepoint == SCM_UNICODE_BOM
+ && (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8
+ || strcmp (pt->encoding, "UTF-16") == 0
+ || strcmp (pt->encoding, "UTF-32") == 0)))
+ return get_codepoint (port, codepoint, buf, len);
+ }
+ update_port_lf (*codepoint, port);
+ }
+ else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK)
+ {
+ *codepoint = '?';
+ err = 0;
+ update_port_lf (*codepoint, port);
}
- return n_read;
+ return err;
}
-#undef FUNC_NAME
-/* scm_c_write
- *
- * Used by an application to write arbitrary number of bytes to an SCM
- * port. Similar semantics as libc write. However, unlike libc
- * write, scm_c_write writes the requested number of bytes and has no
- * return value.
- *
- * Warning: Doesn't update port line and column counts!
- */
-
-void
-scm_c_write (SCM port, const void *ptr, size_t size)
-#define FUNC_NAME "scm_c_write"
+/* Read a codepoint from PORT and return it. */
+scm_t_wchar
+scm_getc_unlocked (SCM port)
+#define FUNC_NAME "scm_getc"
{
- scm_t_port *pt;
- scm_t_ptob_descriptor *ptob;
-
- SCM_VALIDATE_OPOUTPORT (1, port);
-
- pt = SCM_PTAB_ENTRY (port);
- ptob = &scm_ptobs[SCM_PTOBNUM (port)];
-
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ int err;
+ size_t len;
+ scm_t_wchar codepoint;
+ char buf[SCM_MBCHAR_BUF_SIZE];
- ptob->write (port, ptr, size);
+ err = get_codepoint (port, &codepoint, buf, &len);
+ if (SCM_UNLIKELY (err != 0))
+ /* At this point PORT should point past the invalid encoding, as per
+ R6RS-lib Section 8.2.4. */
+ scm_decoding_error (FUNC_NAME, err, "input decoding error", port);
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
+ return codepoint;
}
#undef FUNC_NAME
-void
-scm_flush (SCM port)
+scm_t_wchar
+scm_getc (SCM port)
{
- long i = SCM_PTOBNUM (port);
- assert (i >= 0);
- (scm_ptobs[i].flush) (port);
+ scm_i_pthread_mutex_t *lock;
+ scm_t_wchar ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_getc_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+
+ return ret;
}
-void
-scm_end_input (SCM port)
+SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
+ (SCM port),
+ "Return the next character available from @var{port}, updating\n"
+ "@var{port} to point to the following character. If no more\n"
+ "characters are available, the end-of-file object is returned.\n"
+ "\n"
+ "When @var{port}'s data cannot be decoded according to its\n"
+ "character encoding, a @code{decoding-error} is raised and\n"
+ "@var{port} points past the erroneous byte sequence.\n")
+#define FUNC_NAME s_scm_read_char
{
- long offset;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_wchar c;
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ SCM_VALIDATE_OPINPORT (1, port);
+ c = scm_getc_unlocked (port);
+ if (EOF == c)
+ return SCM_EOF_VAL;
+ return SCM_MAKE_CHAR (c);
+}
+#undef FUNC_NAME
- scm_i_clear_pending_eof (port);
- if (pt->read_buf == pt->putback_buf)
- {
- offset = pt->read_end - pt->read_pos;
- pt->read_buf = pt->saved_read_buf;
- pt->read_pos = pt->saved_read_pos;
- pt->read_end = pt->saved_read_end;
- pt->read_buf_size = pt->saved_read_buf_size;
- }
- else
- offset = 0;
- scm_ptobs[SCM_PTOBNUM (port)].end_input (port, offset);
-}
+\f
+/* Pushback. */
\f
static void
-scm_i_unget_bytes (const unsigned char *buf, size_t len, SCM port)
+scm_i_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port)
#define FUNC_NAME "scm_unget_bytes"
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
#undef FUNC_NAME
void
-scm_unget_bytes (const unsigned char *buf, size_t len, SCM port)
+scm_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port)
{
- scm_i_unget_bytes (buf, len, port);
+ scm_i_unget_bytes_unlocked (buf, len, port);
}
void
-scm_unget_byte (int c, SCM port)
+scm_unget_byte_unlocked (int c, SCM port)
+{
+ unsigned char byte = c;
+ scm_i_unget_bytes_unlocked (&byte, 1, port);
+}
+
+void
+scm_unget_bytes (const unsigned char *buf, size_t len, SCM port)
{
- unsigned char byte;
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_i_unget_bytes_unlocked (buf, len, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+}
- byte = c;
- scm_i_unget_bytes (&byte, 1, port);
+void
+scm_unget_byte (int c, SCM port)
+{
+ unsigned char byte = c;
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_i_unget_bytes_unlocked (&byte, 1, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
}
void
-scm_ungetc (scm_t_wchar c, SCM port)
+scm_ungetc_unlocked (scm_t_wchar c, SCM port)
#define FUNC_NAME "scm_ungetc"
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
char *result;
char result_buf[10];
- const char *encoding;
size_t len;
- if (pt->encoding != NULL)
- encoding = pt->encoding;
- else
- encoding = "ISO-8859-1";
-
len = sizeof (result_buf);
- result = u32_conv_to_encoding (encoding,
- (enum iconv_ilseq_handler) pt->ilseq_handler,
- (uint32_t *) &c, 1, NULL,
- result_buf, &len);
+
+ if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
+ {
+ if (c < 0x80)
+ {
+ result_buf[0] = (char) c;
+ result = result_buf;
+ len = 1;
+ }
+ else
+ result =
+ (char *) u32_to_u8 ((uint32_t *) &c, 1, (uint8_t *) result_buf, &len);
+ }
+ else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1 && c <= 0xff)
+ {
+ result_buf[0] = (char) c;
+ result = result_buf;
+ len = 1;
+ }
+ else
+ result = u32_conv_to_encoding (pt->encoding,
+ (enum iconv_ilseq_handler) pt->ilseq_handler,
+ (uint32_t *) &c, 1, NULL,
+ result_buf, &len);
if (SCM_UNLIKELY (result == NULL || len == 0))
scm_encoding_error (FUNC_NAME, errno,
"conversion to port encoding failed",
SCM_BOOL_F, SCM_MAKE_CHAR (c));
- scm_i_unget_bytes ((unsigned char *) result, len, port);
+ scm_i_unget_bytes_unlocked ((unsigned char *) result, len, port);
if (SCM_UNLIKELY (result != result_buf))
free (result);
if (c == '\n')
- {
- /* What should col be in this case?
- * We'll leave it at -1.
- */
- SCM_LINUM (port) -= 1;
- }
- else
- SCM_COL(port) -= 1;
+ SCM_LINUM (port) -= 1;
+ SCM_DECCOL (port);
}
#undef FUNC_NAME
+void
+scm_ungetc (scm_t_wchar c, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_ungetc_unlocked (c, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
void
-scm_ungets (const char *s, int n, SCM port)
+scm_ungets_unlocked (const char *s, int n, SCM port)
{
/* This is simple minded and inefficient, but unreading strings is
* probably not a common operation, and remember that line and
* Please feel free to write an optimized version!
*/
while (n--)
- scm_ungetc (s[n], port);
+ scm_ungetc_unlocked (s[n], port);
}
+void
+scm_ungets (const char *s, int n, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_ungets_unlocked (s, n, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
(SCM port),
scm_t_wchar c;
char bytes[SCM_MBCHAR_BUF_SIZE];
long column, line;
- size_t len;
-
- if (SCM_UNBNDP (port))
- port = scm_current_input_port ();
- SCM_VALIDATE_OPINPORT (1, port);
-
- column = SCM_COL (port);
- line = SCM_LINUM (port);
-
- err = get_codepoint (port, &c, bytes, &len);
-
- scm_i_unget_bytes ((unsigned char *) bytes, len, port);
-
- SCM_COL (port) = column;
- SCM_LINUM (port) = line;
-
- if (SCM_UNLIKELY (err != 0))
- {
- scm_decoding_error (FUNC_NAME, err, "input decoding error", port);
-
- /* Shouldn't happen since `catch' always aborts to prompt. */
- result = SCM_BOOL_F;
- }
- else if (c == EOF)
- {
- scm_i_set_pending_eof (port);
- result = SCM_EOF_VAL;
- }
- else
- result = SCM_MAKE_CHAR (c);
-
- return result;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0,
- (SCM cobj, SCM port),
- "Place character @var{cobj} in @var{port} so that it will be\n"
- "read by the next read operation. If called multiple times, the\n"
- "unread characters will be read again in last-in first-out\n"
- "order. If @var{port} is not supplied, the current input port\n"
- "is used.")
-#define FUNC_NAME s_scm_unread_char
-{
- int c;
-
- SCM_VALIDATE_CHAR (1, cobj);
- if (SCM_UNBNDP (port))
- port = scm_current_input_port ();
- SCM_VALIDATE_OPINPORT (2, port);
-
- c = SCM_CHAR (cobj);
-
- scm_ungetc (c, port);
- return cobj;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0,
- (SCM str, SCM port),
- "Place the string @var{str} in @var{port} so that its characters will be\n"
- "read in subsequent read operations. If called multiple times, the\n"
- "unread characters will be read again in last-in first-out order. If\n"
- "@var{port} is not supplied, the current-input-port is used.")
-#define FUNC_NAME s_scm_unread_string
-{
- int n;
- SCM_VALIDATE_STRING (1, str);
- if (SCM_UNBNDP (port))
- port = scm_current_input_port ();
- SCM_VALIDATE_OPINPORT (2, port);
-
- n = scm_i_string_length (str);
-
- while (n--)
- scm_ungetc (scm_i_string_ref (str, n), port);
-
- return str;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
- (SCM fd_port, SCM offset, SCM whence),
- "Sets the current position of @var{fd_port} to the integer\n"
- "@var{offset}, which is interpreted according to the value of\n"
- "@var{whence}.\n"
- "\n"
- "One of the following variables should be supplied for\n"
- "@var{whence}:\n"
- "@defvar SEEK_SET\n"
- "Seek from the beginning of the file.\n"
- "@end defvar\n"
- "@defvar SEEK_CUR\n"
- "Seek from the current position.\n"
- "@end defvar\n"
- "@defvar SEEK_END\n"
- "Seek from the end of the file.\n"
- "@end defvar\n"
- "If @var{fd_port} is a file descriptor, the underlying system\n"
- "call is @code{lseek}. @var{port} may be a string port.\n"
- "\n"
- "The value returned is the new position in the file. This means\n"
- "that the current position of a port can be obtained using:\n"
- "@lisp\n"
- "(seek port 0 SEEK_CUR)\n"
- "@end lisp")
-#define FUNC_NAME s_scm_seek
-{
- int how;
-
- fd_port = SCM_COERCE_OUTPORT (fd_port);
-
- how = scm_to_int (whence);
- if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
- SCM_OUT_OF_RANGE (3, whence);
-
- if (SCM_OPPORTP (fd_port))
- {
- scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (fd_port);
- scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port);
- off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
- off_t_or_off64_t rv;
-
- if (!ptob->seek)
- SCM_MISC_ERROR ("port is not seekable",
- scm_cons (fd_port, SCM_EOL));
- else
- rv = ptob->seek (fd_port, off, how);
-
- /* Set stream-start flags according to new position. */
- pti->at_stream_start_for_bom_read = (rv == 0);
- pti->at_stream_start_for_bom_write = (rv == 0);
-
- scm_i_clear_pending_eof (fd_port);
-
- return scm_from_off_t_or_off64_t (rv);
- }
- else /* file descriptor?. */
- {
- off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
- off_t_or_off64_t rv;
- rv = lseek_or_lseek64 (scm_to_int (fd_port), off, how);
- if (rv == -1)
- SCM_SYSERROR;
- return scm_from_off_t_or_off64_t (rv);
- }
-}
-#undef FUNC_NAME
-
-#ifndef O_BINARY
-#define O_BINARY 0
-#endif
-
-/* Mingw has ftruncate(), perhaps implemented above using chsize, but
- doesn't have the filename version truncate(), hence this code. */
-#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
-static int
-truncate (const char *file, off_t length)
-{
- int ret, fdes;
-
- fdes = open (file, O_BINARY | O_WRONLY);
- if (fdes == -1)
- return -1;
-
- ret = ftruncate (fdes, length);
- if (ret == -1)
- {
- int save_errno = errno;
- close (fdes);
- errno = save_errno;
- return -1;
- }
-
- return close (fdes);
-}
-#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
-
-SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
- (SCM object, SCM length),
- "Truncate file @var{object} to @var{length} bytes. @var{object}\n"
- "can be a filename string, a port object, or an integer file\n"
- "descriptor.\n"
- "The return value is unspecified.\n"
- "\n"
- "For a port or file descriptor @var{length} can be omitted, in\n"
- "which case the file is truncated at the current position (per\n"
- "@code{ftell} above).\n"
- "\n"
- "On most systems a file can be extended by giving a length\n"
- "greater than the current size, but this is not mandatory in the\n"
- "POSIX standard.")
-#define FUNC_NAME s_scm_truncate_file
-{
- int rv;
-
- /* "object" can be a port, fdes or filename.
-
- Negative "length" makes no sense, but it's left to truncate() or
- ftruncate() to give back an error for that (normally EINVAL).
- */
-
- if (SCM_UNBNDP (length))
- {
- /* must supply length if object is a filename. */
- if (scm_is_string (object))
- SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL);
-
- length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR));
- }
+ size_t len = 0;
- object = SCM_COERCE_OUTPORT (object);
- if (scm_is_integer (object))
- {
- off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
- SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
- c_length));
- }
- else if (SCM_OPOUTPORTP (object))
- {
- off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
- scm_t_port *pt = SCM_PTAB_ENTRY (object);
- scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ SCM_VALIDATE_OPINPORT (1, port);
- if (!ptob->truncate)
- SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
+ column = SCM_COL (port);
+ line = SCM_LINUM (port);
- scm_i_clear_pending_eof (object);
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (object);
- else if (pt->rw_active == SCM_PORT_WRITE)
- ptob->flush (object);
+ err = get_codepoint (port, &c, bytes, &len);
- ptob->truncate (object, c_length);
- rv = 0;
+ scm_i_unget_bytes_unlocked ((unsigned char *) bytes, len, port);
+
+ SCM_COL (port) = column;
+ SCM_LINUM (port) = line;
+
+ if (SCM_UNLIKELY (err != 0))
+ {
+ scm_decoding_error (FUNC_NAME, err, "input decoding error", port);
+
+ /* Shouldn't happen since `catch' always aborts to prompt. */
+ result = SCM_BOOL_F;
}
- else
+ else if (c == EOF)
{
- off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
- char *str = scm_to_locale_string (object);
- int eno;
- SCM_SYSCALL (rv = truncate_or_truncate64 (str, c_length));
- eno = errno;
- free (str);
- errno = eno;
+ scm_i_set_pending_eof (port);
+ result = SCM_EOF_VAL;
}
- if (rv == -1)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
+ else
+ result = SCM_MAKE_CHAR (c);
+
+ return result;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0,
- (SCM port),
- "Return the current line number for @var{port}.\n"
- "\n"
- "The first line of a file is 0. But you might want to add 1\n"
- "when printing line numbers, since starting from 1 is\n"
- "traditional in error messages, and likely to be more natural to\n"
- "non-programmers.")
-#define FUNC_NAME s_scm_port_line
+SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0,
+ (SCM cobj, SCM port),
+ "Place character @var{cobj} in @var{port} so that it will be\n"
+ "read by the next read operation. If called multiple times, the\n"
+ "unread characters will be read again in last-in first-out\n"
+ "order. If @var{port} is not supplied, the current input port\n"
+ "is used.")
+#define FUNC_NAME s_scm_unread_char
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_long (SCM_LINUM (port));
+ int c;
+
+ SCM_VALIDATE_CHAR (1, cobj);
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ SCM_VALIDATE_OPINPORT (2, port);
+
+ c = SCM_CHAR (cobj);
+
+ scm_ungetc_unlocked (c, port);
+ return cobj;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
- (SCM port, SCM line),
- "Set the current line number for @var{port} to @var{line}. The\n"
- "first line of a file is 0.")
-#define FUNC_NAME s_scm_set_port_line_x
+SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0,
+ (SCM str, SCM port),
+ "Place the string @var{str} in @var{port} so that its characters will be\n"
+ "read in subsequent read operations. If called multiple times, the\n"
+ "unread characters will be read again in last-in first-out order. If\n"
+ "@var{port} is not supplied, the current-input-port is used.")
+#define FUNC_NAME s_scm_unread_string
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- SCM_PTAB_ENTRY (port)->line_number = scm_to_long (line);
- return SCM_UNSPECIFIED;
+ int n;
+ SCM_VALIDATE_STRING (1, str);
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ SCM_VALIDATE_OPINPORT (2, port);
+
+ n = scm_i_string_length (str);
+
+ while (n--)
+ scm_ungetc_unlocked (scm_i_string_ref (str, n), port);
+
+ return str;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0,
- (SCM port),
- "Return the current column number of @var{port}.\n"
- "If the number is\n"
- "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
- "- i.e. the first character of the first line is line 0, column 0.\n"
- "(However, when you display a file position, for example in an error\n"
- "message, we recommend you add 1 to get 1-origin integers. This is\n"
- "because lines and column numbers traditionally start with 1, and that is\n"
- "what non-programmers will find most natural.)")
-#define FUNC_NAME s_scm_port_column
+
+\f
+
+/* Manipulating the buffers. */
+
+/* This routine does not take any locks, as it is usually called as part
+ of a port implementation. */
+void
+scm_port_non_buffer (scm_t_port *pt)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_int (SCM_COL (port));
+ pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
+ pt->write_buf = pt->write_pos = &pt->shortbuf;
+ pt->read_buf_size = pt->write_buf_size = 1;
+ pt->write_end = pt->write_buf + pt->write_buf_size;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
- (SCM port, SCM column),
- "Set the current column of @var{port}. Before reading the first\n"
- "character on a line the column should be 0.")
-#define FUNC_NAME s_scm_set_port_column_x
+/* this should only be called when the read buffer is empty. it
+ tries to refill the read buffer. it returns the first char from
+ the port, which is either EOF or *(pt->read_pos). */
+static int
+scm_i_fill_input_unlocked (SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- SCM_PTAB_ENTRY (port)->column_number = scm_to_int (column);
- return SCM_UNSPECIFIED;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
+
+ assert (pt->read_pos == pt->read_end);
+
+ if (pti->pending_eof)
+ {
+ pti->pending_eof = 0;
+ return EOF;
+ }
+
+ if (pt->read_buf == pt->putback_buf)
+ {
+ /* finished reading put-back chars. */
+ pt->read_buf = pt->saved_read_buf;
+ pt->read_pos = pt->saved_read_pos;
+ pt->read_end = pt->saved_read_end;
+ pt->read_buf_size = pt->saved_read_buf_size;
+ if (pt->read_pos < pt->read_end)
+ return *(pt->read_pos);
+ }
+ return SCM_PORT_DESCRIPTOR (port)->fill_input (port);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0,
- (SCM port),
- "Return the filename associated with @var{port}, or @code{#f}\n"
- "if no filename is associated with the port.")
-#define FUNC_NAME s_scm_port_filename
+int
+scm_fill_input (SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return SCM_FILENAME (port);
+ scm_i_pthread_mutex_t *lock;
+ int ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_fill_input_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+
+ return ret;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
- (SCM port, SCM filename),
- "Change the filename associated with @var{port}, using the current input\n"
- "port if none is specified. Note that this does not change the port's\n"
- "source of data, but only the value that is returned by\n"
- "@code{port-filename} and reported in diagnostic output.")
-#define FUNC_NAME s_scm_set_port_filename_x
+/* Slow-path fallback for 'scm_get_byte_or_eof_unlocked' */
+int
+scm_slow_get_byte_or_eof_unlocked (SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- /* We allow the user to set the filename to whatever he likes. */
- SCM_SET_FILENAME (port, filename);
- return SCM_UNSPECIFIED;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_flush_unlocked (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ if (pt->read_pos >= pt->read_end)
+ {
+ if (SCM_UNLIKELY (scm_i_fill_input_unlocked (port) == EOF))
+ return EOF;
+ }
+
+ return *pt->read_pos++;
}
-#undef FUNC_NAME
-/* 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");
+/* Slow-path fallback for 'scm_peek_byte_or_eof_unlocked' */
+int
+scm_slow_peek_byte_or_eof_unlocked (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
-static int scm_port_encoding_init = 0;
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_flush_unlocked (port);
-/* Use ENCODING as the default encoding for future ports. */
-void
-scm_i_set_default_port_encoding (const char *encoding)
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ if (pt->read_pos >= pt->read_end)
+ {
+ if (SCM_UNLIKELY (scm_i_fill_input_unlocked (port) == EOF))
+ {
+ scm_i_set_pending_eof (port);
+ return EOF;
+ }
+ }
+
+ return *pt->read_pos;
+}
+
+/* Move up to READ_LEN bytes from PORT's putback and/or read buffers
+ into memory starting at DEST. Return the number of bytes moved.
+ PORT's line/column numbers are left unchanged. */
+size_t
+scm_take_from_input_buffers (SCM port, char *dest, size_t read_len)
{
- if (!scm_port_encoding_init
- || !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);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ size_t bytes_read = 0;
+ size_t from_buf = min (pt->read_end - pt->read_pos, read_len);
+
+ if (from_buf > 0)
+ {
+ memcpy (dest, pt->read_pos, from_buf);
+ pt->read_pos += from_buf;
+ bytes_read += from_buf;
+ read_len -= from_buf;
+ dest += from_buf;
+ }
+
+ /* if putback was active, try the real input buffer too. */
+ if (pt->read_buf == pt->putback_buf)
+ {
+ from_buf = min (pt->saved_read_end - pt->saved_read_pos, read_len);
+ if (from_buf > 0)
+ {
+ memcpy (dest, pt->saved_read_pos, from_buf);
+ pt->saved_read_pos += from_buf;
+ bytes_read += from_buf;
+ }
+ }
- if (encoding == NULL
- || c_strcasecmp (encoding, "ASCII") == 0
- || c_strcasecmp (encoding, "ANSI_X3.4-1968") == 0
- || c_strcasecmp (encoding, "ISO-8859-1") == 0)
- scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
- else
- scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var),
- scm_from_locale_string (encoding));
+ return bytes_read;
}
-/* Return the name of the default encoding for newly created ports; a
- return value of NULL means "ISO-8859-1". */
-const char *
-scm_i_default_port_encoding (void)
+/* Clear a port's read buffers, returning the contents. */
+SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
+ (SCM port),
+ "This procedure clears a port's input buffers, similar\n"
+ "to the way that force-output clears the output buffer. The\n"
+ "contents of the buffers are returned as a single string, e.g.,\n"
+ "\n"
+ "@lisp\n"
+ "(define p (open-input-file ...))\n"
+ "(drain-input p) => empty string, nothing buffered yet.\n"
+ "(unread-char (read-char p) p)\n"
+ "(drain-input p) => initial chars from p, up to the buffer size.\n"
+ "@end lisp\n\n"
+ "Draining the buffers may be useful for cleanly finishing\n"
+ "buffered I/O so that the file descriptor can be used directly\n"
+ "for further input.")
+#define FUNC_NAME s_scm_drain_input
{
- if (!scm_port_encoding_init)
- return NULL;
- else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
- return NULL;
- else
- {
- SCM encoding;
+ SCM result;
+ char *data;
+ scm_t_port *pt;
+ long count;
- encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var));
- if (!scm_is_string (encoding))
- return NULL;
- else
- return scm_i_string_chars (encoding);
+ SCM_VALIDATE_OPINPORT (1, port);
+ pt = SCM_PTAB_ENTRY (port);
+
+ count = pt->read_end - pt->read_pos;
+ if (pt->read_buf == pt->putback_buf)
+ count += pt->saved_read_end - pt->saved_read_pos;
+
+ if (count)
+ {
+ result = scm_i_make_string (count, &data, 0);
+ scm_take_from_input_buffers (port, data, count);
}
+ else
+ result = scm_nullstr;
+
+ return result;
}
+#undef FUNC_NAME
-/* If the next LEN bytes from PORT are equal to those in BYTES, then
- return 1, else return 0. Leave the port position unchanged. */
-static int
-looking_at_bytes (SCM port, const unsigned char *bytes, int len)
+void
+scm_end_input_unlocked (SCM port)
{
+ long offset;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- int i = 0;
- while (i < len && scm_peek_byte_or_eof (port) == bytes[i])
+ scm_i_clear_pending_eof (port);
+ if (pt->read_buf == pt->putback_buf)
{
- pt->read_pos++;
- i++;
+ offset = pt->read_end - pt->read_pos;
+ pt->read_buf = pt->saved_read_buf;
+ pt->read_pos = pt->saved_read_pos;
+ pt->read_end = pt->saved_read_end;
+ pt->read_buf_size = pt->saved_read_buf_size;
}
- scm_i_unget_bytes (bytes, i, port);
- return (i == len);
+ else
+ offset = 0;
+
+ SCM_PORT_DESCRIPTOR (port)->end_input (port, offset);
}
-static const unsigned char scm_utf8_bom[3] = {0xEF, 0xBB, 0xBF};
-static const unsigned char scm_utf16be_bom[2] = {0xFE, 0xFF};
-static const unsigned char scm_utf16le_bom[2] = {0xFF, 0xFE};
-static const unsigned char scm_utf32be_bom[4] = {0x00, 0x00, 0xFE, 0xFF};
-static const unsigned char scm_utf32le_bom[4] = {0xFF, 0xFE, 0x00, 0x00};
+void
+scm_end_input (SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_end_input_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
-/* Decide what byte order to use for a UTF-16 port. Return "UTF-16BE"
- or "UTF-16LE". MODE must be either SCM_PORT_READ or SCM_PORT_WRITE,
- and specifies which operation is about to be done. The MODE
- determines how we will decide the byte order. We deliberately avoid
- reading from the port unless the user is about to do so. If the user
- is about to read, then we look for a BOM, and if present, we use it
- to determine the byte order. Otherwise we choose big endian, as
- recommended by the Unicode Standard. Note that the BOM (if any) is
- not consumed here. */
-static const char *
-decide_utf16_encoding (SCM port, scm_t_port_rw_active mode)
+SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
+ (SCM port),
+ "Flush the specified output port, or the current output port if @var{port}\n"
+ "is omitted. The current output buffer contents are passed to the\n"
+ "underlying port implementation (e.g., in the case of fports, the\n"
+ "data will be written to the file and the output buffer will be cleared.)\n"
+ "It has no effect on an unbuffered port.\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_force_output
{
- if (mode == SCM_PORT_READ
- && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read
- && looking_at_bytes (port, scm_utf16le_bom, sizeof scm_utf16le_bom))
- return "UTF-16LE";
+ if (SCM_UNBNDP (port))
+ port = scm_current_output_port ();
else
- return "UTF-16BE";
+ {
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ }
+ scm_flush_unlocked (port);
+ return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
-/* Decide what byte order to use for a UTF-32 port. Return "UTF-32BE"
- or "UTF-32LE". See the comment above 'decide_utf16_encoding' for
- details. */
-static const char *
-decide_utf32_encoding (SCM port, scm_t_port_rw_active mode)
+void
+scm_flush_unlocked (SCM port)
{
- if (mode == SCM_PORT_READ
- && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read
- && looking_at_bytes (port, scm_utf32le_bom, sizeof scm_utf32le_bom))
- return "UTF-32LE";
- else
- return "UTF-32BE";
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
}
-static void
-finalize_iconv_descriptors (void *ptr, void *data)
+void
+scm_flush (SCM port)
{
- close_iconv_descriptors (ptr);
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_flush_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
-static scm_t_iconv_descriptors *
-open_iconv_descriptors (const char *encoding, int reading, int writing)
+int
+scm_fill_input_unlocked (SCM port)
{
- scm_t_iconv_descriptors *id;
- iconv_t input_cd, output_cd;
+ return scm_i_fill_input_unlocked (port);
+}
- input_cd = (iconv_t) -1;
- output_cd = (iconv_t) -1;
- if (reading)
- {
- /* Open an input iconv conversion descriptor, from ENCODING
- to UTF-8. We choose UTF-8, not UTF-32, because iconv
- implementations can typically convert from anything to
- UTF-8, but not to UTF-32 (see
- <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
- /* Assume opening an iconv descriptor causes about 16 KB of
- allocation. */
- scm_gc_register_allocation (16 * 1024);
+\f
- input_cd = iconv_open ("UTF-8", encoding);
- if (input_cd == (iconv_t) -1)
- goto invalid_encoding;
- }
+/* Output. */
- if (writing)
- {
- /* Assume opening an iconv descriptor causes about 16 KB of
- allocation. */
- scm_gc_register_allocation (16 * 1024);
+void
+scm_putc (char c, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_putc_unlocked (c, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
- output_cd = iconv_open (encoding, "UTF-8");
- if (output_cd == (iconv_t) -1)
- {
- if (input_cd != (iconv_t) -1)
- iconv_close (input_cd);
- goto invalid_encoding;
- }
- }
+void
+scm_puts (const char *s, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_puts_unlocked (s, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
+
+/* scm_c_write
+ *
+ * Used by an application to write arbitrary number of bytes to an SCM
+ * port. Similar semantics as libc write. However, unlike libc
+ * write, scm_c_write writes the requested number of bytes and has no
+ * return value.
+ *
+ * Warning: Doesn't update port line and column counts!
+ */
+void
+scm_c_write_unlocked (SCM port, const void *ptr, size_t size)
+#define FUNC_NAME "scm_c_write"
+{
+ scm_t_port *pt;
+ scm_t_ptob_descriptor *ptob;
- id = scm_gc_malloc_pointerless (sizeof (*id), "iconv descriptors");
- id->input_cd = input_cd;
- id->output_cd = output_cd;
+ SCM_VALIDATE_OPOUTPORT (1, port);
- /* Register a finalizer to close the descriptors. */
- scm_i_set_finalizer (id, finalize_iconv_descriptors, NULL);
+ pt = SCM_PTAB_ENTRY (port);
+ ptob = SCM_PORT_DESCRIPTOR (port);
- return id;
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (port);
- invalid_encoding:
- {
- SCM err;
- err = scm_from_locale_string (encoding);
- scm_misc_error ("open_iconv_descriptors",
- "invalid or unknown character encoding ~s",
- scm_list_1 (err));
- }
+ ptob->write (port, ptr, size);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
}
+#undef FUNC_NAME
-static void
-close_iconv_descriptors (scm_t_iconv_descriptors *id)
+void
+scm_c_write (SCM port, const void *ptr, size_t size)
{
- if (id->input_cd != (iconv_t) -1)
- iconv_close (id->input_cd);
- if (id->output_cd != (iconv_t) -1)
- iconv_close (id->output_cd);
- id->input_cd = (void *) -1;
- id->output_cd = (void *) -1;
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_c_write_unlocked (port, ptr, size);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
-/* Return the iconv_descriptors, initializing them if necessary. MODE
- must be either SCM_PORT_READ or SCM_PORT_WRITE, and specifies which
- operation is about to be done. We deliberately avoid reading from
- the port unless the user was about to do so. */
-scm_t_iconv_descriptors *
-scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode)
+/* scm_lfwrite
+ *
+ * This function differs from scm_c_write; it updates port line and
+ * column. */
+void
+scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port)
{
- scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
-
- assert (pti->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV);
-
- if (!pti->iconv_descriptors)
- {
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- const char *precise_encoding;
-
- if (!pt->encoding)
- pt->encoding = "ISO-8859-1";
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
- /* If the specified encoding is UTF-16 or UTF-32, then make
- that more precise by deciding what byte order to use. */
- if (c_strcasecmp (pt->encoding, "UTF-16") == 0)
- precise_encoding = decide_utf16_encoding (port, mode);
- else if (c_strcasecmp (pt->encoding, "UTF-32") == 0)
- precise_encoding = decide_utf32_encoding (port, mode);
- else
- precise_encoding = pt->encoding;
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (port);
- pti->iconv_descriptors =
- open_iconv_descriptors (precise_encoding,
- SCM_INPUT_PORT_P (port),
- SCM_OUTPUT_PORT_P (port));
- }
+ ptob->write (port, ptr, size);
- return pti->iconv_descriptors;
+ for (; size; ptr++, size--)
+ update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
}
void
-scm_i_set_port_encoding_x (SCM port, const char *encoding)
+scm_lfwrite (const char *ptr, size_t size, SCM port)
{
- scm_t_port *pt;
- scm_t_port_internal *pti;
- scm_t_iconv_descriptors *prev;
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_lfwrite_unlocked (ptr, size, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
- /* Set the character encoding for this port. */
- pt = SCM_PTAB_ENTRY (port);
- pti = SCM_PORT_GET_INTERNAL (port);
- prev = pti->iconv_descriptors;
+/* Write STR to PORT from START inclusive to END exclusive. */
+void
+scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
- /* In order to handle cases where the encoding changes mid-stream
- (e.g. within an HTTP stream, or within a file that is composed of
- segments with different encodings), we consider this to be "stream
- start" for purposes of BOM handling, regardless of our actual file
- position. */
- pti->at_stream_start_for_bom_read = 1;
- pti->at_stream_start_for_bom_write = 1;
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (port);
- if (encoding == NULL)
- encoding = "ISO-8859-1";
+ if (end == (size_t) -1)
+ end = scm_i_string_length (str);
- /* If ENCODING is UTF-8, then no conversion descriptor is opened
- because we do I/O ourselves. This saves 100+ KiB for each
- descriptor. */
- pt->encoding = scm_gc_strdup (encoding, "port");
- if (c_strcasecmp (encoding, "UTF-8") == 0)
- pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
- else
- pti->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+ scm_i_display_substring (str, start, end, port);
- pti->iconv_descriptors = NULL;
- if (prev)
- close_iconv_descriptors (prev);
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
}
-SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0,
+
+\f
+
+/* Querying and setting positions, and character availability. */
+
+SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0,
(SCM port),
- "Returns, as a string, the character encoding that @var{port}\n"
- "uses to interpret its input and output.\n")
-#define FUNC_NAME s_scm_port_encoding
+ "Return @code{#t} if a character is ready on input @var{port}\n"
+ "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
+ "@code{#t} then the next @code{read-char} operation on\n"
+ "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
+ "port at end of file then @code{char-ready?} returns @code{#t}.\n"
+ "\n"
+ "@code{char-ready?} exists to make it possible for a\n"
+ "program to accept characters from interactive ports without\n"
+ "getting stuck waiting for input. Any input editors associated\n"
+ "with such ports must make sure that characters whose existence\n"
+ "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
+ "If @code{char-ready?} were to return @code{#f} at end of file,\n"
+ "a port at end of file would be indistinguishable from an\n"
+ "interactive port that has no ready characters.")
+#define FUNC_NAME s_scm_char_ready_p
{
scm_t_port *pt;
- const char *enc;
- SCM_VALIDATE_PORT (1, port);
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ /* It's possible to close the current input port, so validate even in
+ this case. */
+ SCM_VALIDATE_OPINPORT (1, port);
pt = SCM_PTAB_ENTRY (port);
- enc = pt->encoding;
- if (enc)
- return scm_from_locale_string (pt->encoding);
+
+ /* if the current read buffer is filled, or the
+ last pushed-back char has been read and the saved buffer is
+ filled, result is true. */
+ if (pt->read_pos < pt->read_end
+ || (pt->read_buf == pt->putback_buf
+ && pt->saved_read_pos < pt->saved_read_end))
+ return SCM_BOOL_T;
else
- return SCM_BOOL_F;
+ {
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
+
+ if (ptob->input_waiting)
+ return scm_from_bool(ptob->input_waiting (port));
+ else
+ return SCM_BOOL_T;
+ }
}
#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"
- "port I/O. New ports are created with the encoding\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
+SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
+ (SCM fd_port, SCM offset, SCM whence),
+ "Sets the current position of @var{fd_port} to the integer\n"
+ "@var{offset}, which is interpreted according to the value of\n"
+ "@var{whence}.\n"
+ "\n"
+ "One of the following variables should be supplied for\n"
+ "@var{whence}:\n"
+ "@defvar SEEK_SET\n"
+ "Seek from the beginning of the file.\n"
+ "@end defvar\n"
+ "@defvar SEEK_CUR\n"
+ "Seek from the current position.\n"
+ "@end defvar\n"
+ "@defvar SEEK_END\n"
+ "Seek from the end of the file.\n"
+ "@end defvar\n"
+ "If @var{fd_port} is a file descriptor, the underlying system\n"
+ "call is @code{lseek}. @var{port} may be a string port.\n"
+ "\n"
+ "The value returned is the new position in the file. This means\n"
+ "that the current position of a port can be obtained using:\n"
+ "@lisp\n"
+ "(seek port 0 SEEK_CUR)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_seek
{
- char *enc_str;
+ int how;
- SCM_VALIDATE_PORT (1, port);
- SCM_VALIDATE_STRING (2, enc);
+ fd_port = SCM_COERCE_OUTPORT (fd_port);
- enc_str = scm_to_locale_string (enc);
- scm_i_set_port_encoding_x (port, enc_str);
- free (enc_str);
+ how = scm_to_int (whence);
+ if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
+ SCM_OUT_OF_RANGE (3, whence);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
+ if (SCM_OPPORTP (fd_port))
+ {
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (fd_port);
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (fd_port);
+ off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
+ off_t_or_off64_t rv;
+ if (!ptob->seek)
+ SCM_MISC_ERROR ("port is not seekable",
+ scm_cons (fd_port, SCM_EOL));
+ else
+ rv = ptob->seek (fd_port, off, how);
-/* A fluid specifying the default conversion handler for newly created
- ports. Its value should be one of the symbols below. */
-SCM_VARIABLE (default_conversion_strategy_var,
- "%default-port-conversion-strategy");
+ /* Set stream-start flags according to new position. */
+ pti->at_stream_start_for_bom_read = (rv == 0);
+ pti->at_stream_start_for_bom_write = (rv == 0);
-/* Whether the above fluid is initialized. */
-static int scm_conversion_strategy_init = 0;
+ scm_i_clear_pending_eof (fd_port);
-/* The possible conversion strategies. */
-SCM_SYMBOL (sym_error, "error");
-SCM_SYMBOL (sym_substitute, "substitute");
-SCM_SYMBOL (sym_escape, "escape");
+ return scm_from_off_t_or_off64_t (rv);
+ }
+ else /* file descriptor?. */
+ {
+ off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
+ off_t_or_off64_t rv;
+ rv = lseek_or_lseek64 (scm_to_int (fd_port), off, how);
+ if (rv == -1)
+ SCM_SYSERROR;
+ return scm_from_off_t_or_off64_t (rv);
+ }
+}
+#undef FUNC_NAME
-/* Return the default failed encoding conversion policy for new created
- ports. */
-scm_t_string_failed_conversion_handler
-scm_i_default_port_conversion_handler (void)
-{
- scm_t_string_failed_conversion_handler handler;
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
- if (!scm_conversion_strategy_init
- || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var)))
- handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
- else
- {
- SCM fluid, value;
+/* Mingw has ftruncate(), perhaps implemented above using chsize, but
+ doesn't have the filename version truncate(), hence this code. */
+#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
+static int
+truncate (const char *file, off_t length)
+{
+ int ret, fdes;
- fluid = SCM_VARIABLE_REF (default_conversion_strategy_var);
- value = scm_fluid_ref (fluid);
+ fdes = open (file, O_BINARY | O_WRONLY);
+ if (fdes == -1)
+ return -1;
- if (scm_is_eq (sym_substitute, value))
- handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
- else if (scm_is_eq (sym_escape, value))
- handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE;
- else
- /* Default to 'error also when the fluid's value is not one of
- the valid symbols. */
- handler = SCM_FAILED_CONVERSION_ERROR;
+ ret = ftruncate (fdes, length);
+ if (ret == -1)
+ {
+ int save_errno = errno;
+ close (fdes);
+ errno = save_errno;
+ return -1;
}
- return handler;
+ return close (fdes);
}
+#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
-/* Use HANDLER as the default conversion strategy for future ports. */
-void
-scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler
- handler)
+SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
+ (SCM object, SCM length),
+ "Truncate file @var{object} to @var{length} bytes. @var{object}\n"
+ "can be a filename string, a port object, or an integer file\n"
+ "descriptor.\n"
+ "The return value is unspecified.\n"
+ "\n"
+ "For a port or file descriptor @var{length} can be omitted, in\n"
+ "which case the file is truncated at the current position (per\n"
+ "@code{ftell} above).\n"
+ "\n"
+ "On most systems a file can be extended by giving a length\n"
+ "greater than the current size, but this is not mandatory in the\n"
+ "POSIX standard.")
+#define FUNC_NAME s_scm_truncate_file
{
- SCM strategy;
-
- if (!scm_conversion_strategy_init
- || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var)))
- scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
- SCM_EOL);
+ int rv;
- switch (handler)
- {
- case SCM_FAILED_CONVERSION_ERROR:
- strategy = sym_error;
- break;
+ /* "object" can be a port, fdes or filename.
- case SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE:
- strategy = sym_escape;
- break;
+ Negative "length" makes no sense, but it's left to truncate() or
+ ftruncate() to give back an error for that (normally EINVAL).
+ */
- case SCM_FAILED_CONVERSION_QUESTION_MARK:
- strategy = sym_substitute;
- break;
+ if (SCM_UNBNDP (length))
+ {
+ /* must supply length if object is a filename. */
+ if (scm_is_string (object))
+ SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL);
+
+ length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR));
+ }
- default:
- abort ();
+ object = SCM_COERCE_OUTPORT (object);
+ if (scm_is_integer (object))
+ {
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
+ c_length));
}
+ else if (SCM_OPOUTPORTP (object))
+ {
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ scm_t_port *pt = SCM_PTAB_ENTRY (object);
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (object);
- scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var),
- strategy);
-}
+ if (!ptob->truncate)
+ SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
-SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy",
- 1, 0, 0, (SCM port),
- "Returns the behavior of the port when handling a character that\n"
- "is not representable in the port's current encoding.\n"
- "It returns the symbol @code{error} if unrepresentable characters\n"
- "should cause exceptions, @code{substitute} if the port should\n"
- "try to replace unrepresentable characters with question marks or\n"
- "approximate characters, or @code{escape} if unrepresentable\n"
- "characters should be converted to string escapes.\n"
- "\n"
- "If @var{port} is @code{#f}, then the current default behavior\n"
- "will be returned. New ports will have this default behavior\n"
- "when they are created.\n")
-#define FUNC_NAME s_scm_port_conversion_strategy
-{
- scm_t_string_failed_conversion_handler h;
+ scm_i_clear_pending_eof (object);
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (object);
+ else if (pt->rw_active == SCM_PORT_WRITE)
+ ptob->flush (object);
- if (scm_is_false (port))
- h = scm_i_default_port_conversion_handler ();
+ ptob->truncate (object, c_length);
+ rv = 0;
+ }
else
{
- scm_t_port *pt;
-
- SCM_VALIDATE_OPPORT (1, port);
- pt = SCM_PTAB_ENTRY (port);
-
- h = pt->ilseq_handler;
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ char *str = scm_to_locale_string (object);
+ int eno;
+ SCM_SYSCALL (rv = truncate_or_truncate64 (str, c_length));
+ eno = errno;
+ free (str);
+ errno = eno;
}
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
- if (h == SCM_FAILED_CONVERSION_ERROR)
- return scm_from_latin1_symbol ("error");
- else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK)
- return scm_from_latin1_symbol ("substitute");
- else if (h == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
- return scm_from_latin1_symbol ("escape");
- else
- abort ();
+SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0,
+ (SCM port),
+ "Return the current line number for @var{port}.\n"
+ "\n"
+ "The first line of a file is 0. But you might want to add 1\n"
+ "when printing line numbers, since starting from 1 is\n"
+ "traditional in error messages, and likely to be more natural to\n"
+ "non-programmers.")
+#define FUNC_NAME s_scm_port_line
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return scm_from_long (SCM_LINUM (port));
+}
+#undef FUNC_NAME
- /* Never gets here. */
- return SCM_UNDEFINED;
+SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
+ (SCM port, SCM line),
+ "Set the current line number for @var{port} to @var{line}. The\n"
+ "first line of a file is 0.")
+#define FUNC_NAME s_scm_set_port_line_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_PTAB_ENTRY (port)->line_number = scm_to_long (line);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!",
- 2, 0, 0,
- (SCM port, SCM sym),
- "Sets the behavior of the interpreter when outputting a character\n"
- "that is not representable in the port's current encoding.\n"
- "@var{sym} can be either @code{'error}, @code{'substitute}, or\n"
- "@code{'escape}. If it is @code{'error}, an error will be thrown\n"
- "when an unconvertible character is encountered. If it is\n"
- "@code{'substitute}, then unconvertible characters will \n"
- "be replaced with approximate characters, or with question marks\n"
- "if no approximately correct character is available.\n"
- "If it is @code{'escape},\n"
- "it will appear as a hex escape when output.\n"
- "\n"
- "If @var{port} is an open port, the conversion error behavior\n"
- "is set for that port. If it is @code{#f}, it is set as the\n"
- "default behavior for any future ports that get created in\n"
- "this thread.\n")
-#define FUNC_NAME s_scm_set_port_conversion_strategy_x
+SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0,
+ (SCM port),
+ "Return the current column number of @var{port}.\n"
+ "If the number is\n"
+ "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
+ "- i.e. the first character of the first line is line 0, column 0.\n"
+ "(However, when you display a file position, for example in an error\n"
+ "message, we recommend you add 1 to get 1-origin integers. This is\n"
+ "because lines and column numbers traditionally start with 1, and that is\n"
+ "what non-programmers will find most natural.)")
+#define FUNC_NAME s_scm_port_column
{
- scm_t_string_failed_conversion_handler handler;
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return scm_from_int (SCM_COL (port));
+}
+#undef FUNC_NAME
- if (scm_is_eq (sym, sym_error))
- handler = SCM_FAILED_CONVERSION_ERROR;
- else if (scm_is_eq (sym, sym_substitute))
- handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
- else if (scm_is_eq (sym, sym_escape))
- handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE;
- else
- SCM_MISC_ERROR ("unknown conversion strategy ~s", scm_list_1 (sym));
+SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
+ (SCM port, SCM column),
+ "Set the current column of @var{port}. Before reading the first\n"
+ "character on a line the column should be 0.")
+#define FUNC_NAME s_scm_set_port_column_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_PTAB_ENTRY (port)->column_number = scm_to_int (column);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
- if (scm_is_false (port))
- scm_i_set_default_port_conversion_handler (handler);
- else
- {
- SCM_VALIDATE_OPPORT (1, port);
- SCM_PTAB_ENTRY (port)->ilseq_handler = handler;
- }
+SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0,
+ (SCM port),
+ "Return the filename associated with @var{port}, or @code{#f}\n"
+ "if no filename is associated with the port.")
+#define FUNC_NAME s_scm_port_filename
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return SCM_FILENAME (port);
+}
+#undef FUNC_NAME
+SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
+ (SCM port, SCM filename),
+ "Change the filename associated with @var{port}, using the current input\n"
+ "port if none is specified. Note that this does not change the port's\n"
+ "source of data, but only the value that is returned by\n"
+ "@code{port-filename} and reported in diagnostic output.")
+#define FUNC_NAME s_scm_set_port_filename_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ /* We allow the user to set the filename to whatever he likes. */
+ SCM_SET_FILENAME (port, filename);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+\f
+
+/* Implementation helpers for port printing functions. */
void
scm_print_port_mode (SCM exp, SCM port)
{
- scm_puts (SCM_CLOSEDP (exp)
+ scm_puts_unlocked (SCM_CLOSEDP (exp)
? "closed: "
: (SCM_RDNG & SCM_CELL_WORD_0 (exp)
? (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp));
if (!type)
type = "port";
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
scm_print_port_mode (exp, port);
- scm_puts (type, port);
- scm_putc (' ', port);
+ scm_puts_unlocked (type, port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
+
+\f
+
+/* Iterating over all ports. */
+
+struct for_each_data
+{
+ void (*proc) (void *data, SCM p);
+ void *data;
+};
+
+static SCM
+for_each_trampoline (void *data, SCM port, SCM result)
+{
+ struct for_each_data *d = data;
+
+ d->proc (d->data, port);
+
+ return result;
+}
+
+void
+scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
+{
+ struct for_each_data d;
+
+ d.proc = proc;
+ d.data = data;
+
+ scm_c_weak_set_fold (for_each_trampoline, &d, SCM_EOL,
+ scm_i_port_weak_set);
+}
+
+static void
+scm_for_each_trampoline (void *data, SCM port)
+{
+ scm_call_1 (SCM_PACK_POINTER (data), port);
+}
+
+SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
+ (SCM proc),
+ "Apply @var{proc} to each port in the Guile port table\n"
+ "in turn. The return value is unspecified. More specifically,\n"
+ "@var{proc} is applied exactly once to every port that exists\n"
+ "in the system at the time @code{port-for-each} is invoked.\n"
+ "Changes to the port table while @code{port-for-each} is running\n"
+ "have no effect as far as @code{port-for-each} is concerned.")
+#define FUNC_NAME s_scm_port_for_each
+{
+ SCM_VALIDATE_PROC (1, proc);
+
+ scm_c_port_for_each (scm_for_each_trampoline, SCM_UNPACK_POINTER (proc));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void
+flush_output_port (void *closure, SCM port)
+{
+ if (SCM_OPOUTPORTP (port))
+ scm_flush_unlocked (port);
+}
+
+SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
+ (),
+ "Equivalent to calling @code{force-output} on\n"
+ "all open output ports. The return value is unspecified.")
+#define FUNC_NAME s_scm_flush_all_ports
+{
+ scm_c_port_for_each (&flush_output_port, NULL);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
\f
/* Void ports. */
static SCM
scm_i_void_port (long mode_bits)
{
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
- {
- SCM answer = scm_new_port_table_entry (scm_tc16_void_port);
- scm_t_port * pt = SCM_PTAB_ENTRY(answer);
+ SCM ret;
- scm_port_non_buffer (pt);
+ ret = scm_c_make_port (scm_tc16_void_port, mode_bits, 0);
+
+ scm_port_non_buffer (SCM_PTAB_ENTRY (ret));
- SCM_SETSTREAM (answer, 0);
- SCM_SET_CELL_TYPE (answer, scm_tc16_void_port | mode_bits);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
- return answer;
- }
+ return ret;
}
SCM
}
#undef FUNC_NAME
+
\f
+
/* Initialization. */
void
cur_inport_fluid = scm_make_fluid ();
cur_outport_fluid = scm_make_fluid ();
cur_errport_fluid = scm_make_fluid ();
+ cur_warnport_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_set = scm_c_make_weak_set (31);
#include "libguile/ports.x"
scm_c_define ("%current-input-port-fluid", cur_inport_fluid);
scm_c_define ("%current-output-port-fluid", cur_outport_fluid);
scm_c_define ("%current-error-port-fluid", cur_errport_fluid);
+ scm_c_define ("%current-warning-port-fluid", cur_warnport_fluid);
}
/*
#ifndef SCM_PORTS_H
#define SCM_PORTS_H
-/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
- * 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
+ * 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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/__scm.h"
+#include <stdio.h>
+#include <string.h>
#include <unistd.h>
+#include "libguile/gc.h"
+#include "libguile/tags.h"
+#include "libguile/error.h"
#include "libguile/print.h"
#include "libguile/struct.h"
#include "libguile/threads.h"
SCM_PORT_WRITE = 2
} scm_t_port_rw_active;
+/* An internal-only structure defined in ports-internal.h. */
+struct scm_port_internal;
+
/* C representation of a Scheme port. */
typedef struct
{
SCM port; /* Link back to the port object. */
- int revealed; /* 0 not revealed, > 1 revealed.
- * Revealed ports do not get GC'd.
- */
+ scm_i_pthread_mutex_t *lock; /* A recursive lock for this port. */
+
+ /* pointer to internal-only port structure */
+ struct scm_port_internal *internal;
+
/* data for the underlying port implementation as a raw C value. */
scm_t_bits stream;
long line_number; /* debugging support. */
int column_number; /* debugging support. */
- /* Character encoding support */
- char *encoding;
- scm_t_string_failed_conversion_handler ilseq_handler;
-
/* port buffers. the buffer(s) are set up for all ports.
in the case of string ports, the buffer is the string itself.
in the case of unbuffered file ports, the buffer is a
unsigned char *putback_buf;
size_t putback_buf_size; /* allocated size of putback_buf. */
- /* IMPORTANT: 'input_cd' and 'output_cd' used to be pointers to the
- input and output iconv descriptors, but those have been moved to
- the internal-only port structure defined in ports-internal.h.
-
- Given that we must preserve ABI compatibility in 2.0, we cannot
- safely change this public structure without running afoul of C
- strict aliasing rules. We cannot even change the member names.
-
- To work around this, in this public structure, 'input_cd' has been
- repurposed to be a pointer to the internal port structure (see
- ports-internal.h), and 'output_cd' is now unused.
-
- This will be cleaned up in 2.2. */
-
- void *input_cd; /* XXX actually a pointer to scm_t_port_internal */
- void *output_cd; /* XXX actually unused */
+ /* Character encoding support */
+ char *encoding;
+ scm_t_string_failed_conversion_handler ilseq_handler;
} scm_t_port;
-SCM_INTERNAL scm_i_pthread_mutex_t scm_i_port_table_mutex;
-SCM_INTERNAL SCM scm_i_port_weak_hash;
+SCM_INTERNAL SCM scm_i_port_weak_set;
#define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end)
#define SCM_BUF0 (8L<<16) /* Is it unbuffered? */
#define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */
-#define SCM_PORTP(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_port))
-#define SCM_OPPORTP(x) (!SCM_IMP(x) && (((0x7f | SCM_OPN) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN)))
-#define SCM_OPINPORTP(x) (!SCM_IMP(x) && (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)))
-#define SCM_OPOUTPORTP(x) (!SCM_IMP(x) && (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)))
-#define SCM_INPUT_PORT_P(x) \
- (!SCM_IMP(x) \
- && (((0x7f | SCM_RDNG) & SCM_CELL_WORD_0(x)) == (scm_tc7_port | SCM_RDNG)))
-#define SCM_OUTPUT_PORT_P(x) \
- (!SCM_IMP(x) \
- && (((0x7f | SCM_WRTNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_WRTNG)))
-#define SCM_OPENP(x) (!SCM_IMP(x) && (SCM_OPN & SCM_CELL_WORD_0 (x)))
-#define SCM_CLOSEDP(x) (!SCM_OPENP(x))
+#define SCM_PORTP(x) (SCM_HAS_TYP7 (x, scm_tc7_port))
+#define SCM_OPPORTP(x) (SCM_PORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN))
+#define SCM_INPUT_PORT_P(x) (SCM_PORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_RDNG))
+#define SCM_OUTPUT_PORT_P(x) (SCM_PORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_WRTNG))
+#define SCM_OPINPORTP(x) (SCM_OPPORTP (x) && SCM_INPUT_PORT_P (x))
+#define SCM_OPOUTPORTP(x) (SCM_OPPORTP (x) && SCM_OUTPUT_PORT_P (x))
+#define SCM_OPENP(x) (SCM_OPPORTP (x))
+#define SCM_CLOSEDP(x) (!SCM_OPENP (x))
#define SCM_CLR_PORT_OPEN_FLAG(p) \
SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) & ~SCM_OPN)
#define SCM_PTAB_ENTRY(x) ((scm_t_port *) SCM_CELL_WORD_1 (x))
+#define SCM_PORT_DESCRIPTOR(port) ((scm_t_ptob_descriptor *) SCM_CELL_WORD_2 (port))
#define SCM_SETPTAB_ENTRY(x, ent) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (ent)))
#define SCM_STREAM(x) (SCM_PTAB_ENTRY(x)->stream)
#define SCM_SETSTREAM(x, s) (SCM_PTAB_ENTRY(x)->stream = (scm_t_bits) (s))
#define SCM_SET_FILENAME(x, n) (SCM_PTAB_ENTRY(x)->file_name = (n))
#define SCM_LINUM(x) (SCM_PTAB_ENTRY(x)->line_number)
#define SCM_COL(x) (SCM_PTAB_ENTRY(x)->column_number)
-#define SCM_REVEALED(x) (SCM_PTAB_ENTRY(x)->revealed)
-#define SCM_SETREVEALED(x, s) (SCM_PTAB_ENTRY(x)->revealed = (s))
#define SCM_INCLINE(port) do {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} while (0)
#define SCM_ZEROCOL(port) do {SCM_COL (port) = 0;} while (0)
\f
+typedef enum scm_t_port_type_flags {
+ SCM_PORT_TYPE_HAS_FLUSH = 1 << 0
+} scm_t_port_type_flags;
+
/* port-type description. */
typedef struct scm_t_ptob_descriptor
{
scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE);
void (*truncate) (SCM port, scm_t_off length);
+ /* When non-NULL, this is the method called by 'setvbuf' for this port.
+ It must create read and write buffers for PORT with the specified
+ sizes (a size of 0 is for unbuffered ports, which should use the
+ 'shortbuf' field.) Size -1 means to use the port's preferred buffer
+ size. */
+ void (*setvbuf) (SCM port, long read_size, long write_size);
+
+ unsigned flags;
} scm_t_ptob_descriptor;
#define SCM_TC2PTOBNUM(x) (0x0ff & ((x) >> 8))
#define SCM_PTOBNUM(x) (SCM_TC2PTOBNUM (SCM_CELL_TYPE (x)))
/* SCM_PTOBNAME can be 0 if name is missing */
-#define SCM_PTOBNAME(ptobnum) scm_ptobs[ptobnum].name
-
-\f
-
-/* Hey you! Yes you, reading the header file! We're going to deprecate
- scm_ptobs in 2.2, so please don't write any new code that uses it.
- Thanks. */
-SCM_API scm_t_ptob_descriptor *scm_ptobs;
-SCM_API long scm_numptob;
+#define SCM_PTOBNAME(ptobnum) (scm_c_port_type_ref (ptobnum)->name)
-\f
-
-SCM_API SCM scm_markstream (SCM ptr);
+/* Port types, and their vtables. */
+SCM_INTERNAL long scm_c_num_port_types (void);
+SCM_API scm_t_ptob_descriptor* scm_c_port_type_ref (long ptobnum);
+SCM_API long scm_c_port_type_add_x (scm_t_ptob_descriptor *desc);
SCM_API scm_t_bits scm_make_port_type (char *name,
int (*fill_input) (SCM port),
void (*write) (SCM port,
SCM_API void scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM));
SCM_API void scm_set_port_close (scm_t_bits tc, int (*close) (SCM));
-SCM_API void scm_set_port_flush (scm_t_bits tc,
- void (*flush) (SCM port));
+SCM_API void scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port));
SCM_API void scm_set_port_end_input (scm_t_bits tc,
- void (*end_input) (SCM port,
- int offset));
+ void (*end_input) (SCM port,
+ int offset));
SCM_API void scm_set_port_seek (scm_t_bits tc,
scm_t_off (*seek) (SCM port,
scm_t_off OFFSET,
void (*truncate) (SCM port,
scm_t_off length));
SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM));
-SCM_API SCM scm_char_ready_p (SCM port);
-SCM_API size_t scm_take_from_input_buffers (SCM port, char *dest,
- size_t read_len);
-SCM_API SCM scm_drain_input (SCM port);
+SCM_API void scm_set_port_setvbuf (scm_t_bits tc,
+ void (*setvbuf) (SCM, long, long));
+
+/* The input, output, error, and load ports. */
SCM_API SCM scm_current_input_port (void);
SCM_API SCM scm_current_output_port (void);
SCM_API SCM scm_current_error_port (void);
SCM_API void scm_dynwind_current_input_port (SCM port);
SCM_API void scm_dynwind_current_output_port (SCM port);
SCM_API void scm_dynwind_current_error_port (SCM port);
-SCM_API SCM scm_new_port_table_entry (scm_t_bits tag);
-SCM_API void scm_grow_port_cbuf (SCM port, size_t requested);
-SCM_API SCM scm_pt_size (void);
-SCM_API SCM scm_pt_member (SCM member);
-SCM_API void scm_port_non_buffer (scm_t_port *pt);
-SCM_API int scm_revealed_count (SCM port);
-SCM_API SCM scm_port_revealed (SCM port);
-SCM_API SCM scm_set_port_revealed_x (SCM port, SCM rcount);
+SCM_INTERNAL void scm_i_dynwind_current_load_port (SCM port);
+
+/* Mode bits. */
+SCM_INTERNAL long scm_i_mode_bits (SCM modes);
SCM_API long scm_mode_bits (char *modes);
SCM_API SCM scm_port_mode (SCM port);
-SCM_API SCM scm_close_input_port (SCM port);
-SCM_API SCM scm_close_output_port (SCM port);
-SCM_API SCM scm_close_port (SCM port);
-SCM_API SCM scm_port_for_each (SCM proc);
-SCM_API void scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data);
+
+/* Low-level constructors. */
+SCM_API SCM
+scm_c_make_port_with_encoding (scm_t_bits tag,
+ unsigned long mode_bits,
+ const char *encoding,
+ scm_t_string_failed_conversion_handler handler,
+ scm_t_bits stream);
+SCM_API SCM scm_c_make_port (scm_t_bits tag, unsigned long mode_bits,
+ scm_t_bits stream);
+SCM_API SCM scm_new_port_table_entry (scm_t_bits tag);
+
+/* Predicates. */
+SCM_API SCM scm_port_p (SCM x);
SCM_API SCM scm_input_port_p (SCM x);
SCM_API SCM scm_output_port_p (SCM x);
-SCM_API SCM scm_port_p (SCM x);
SCM_API SCM scm_port_closed_p (SCM port);
SCM_API SCM scm_eof_object_p (SCM x);
-SCM_API SCM scm_force_output (SCM port);
-SCM_API SCM scm_flush_all_ports (void);
-SCM_API SCM scm_read_char (SCM port);
-SCM_API scm_t_wchar scm_getc (SCM port);
+
+/* Closing ports. */
+SCM_API SCM scm_close_port (SCM port);
+SCM_API SCM scm_close_input_port (SCM port);
+SCM_API SCM scm_close_output_port (SCM port);
+
+/* Encoding characters to byte streams, and decoding byte streams to
+ characters. */
+SCM_INTERNAL const char *scm_i_default_port_encoding (void);
+SCM_INTERNAL void scm_i_set_default_port_encoding (const char *);
+SCM_INTERNAL scm_t_string_failed_conversion_handler
+scm_i_default_port_conversion_handler (void);
+SCM_INTERNAL void
+scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler);
+SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str);
+SCM_API SCM scm_port_encoding (SCM port);
+SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding);
+SCM_API SCM scm_port_conversion_strategy (SCM port);
+SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior);
+
+/* Acquiring and releasing the port lock. */
+SCM_API void scm_dynwind_lock_port (SCM port);
+SCM_INLINE int scm_c_lock_port (SCM port, scm_i_pthread_mutex_t **lock);
+SCM_INLINE int scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock);
+
+/* Input. */
+SCM_API int scm_get_byte_or_eof (SCM port);
+SCM_INLINE int scm_get_byte_or_eof_unlocked (SCM port);
+SCM_API int scm_slow_get_byte_or_eof_unlocked (SCM port);
+SCM_API int scm_peek_byte_or_eof (SCM port);
+SCM_INLINE int scm_peek_byte_or_eof_unlocked (SCM port);
+SCM_API int scm_slow_peek_byte_or_eof_unlocked (SCM port);
SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size);
-SCM_API void scm_c_write (SCM port, const void *buffer, size_t size);
-SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port);
-SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end,
- SCM port);
-SCM_API void scm_flush (SCM port);
-SCM_API void scm_end_input (SCM port);
-SCM_API int scm_fill_input (SCM port);
+SCM_API size_t scm_c_read_unlocked (SCM port, void *buffer, size_t size);
+SCM_API scm_t_wchar scm_getc (SCM port);
+SCM_API scm_t_wchar scm_getc_unlocked (SCM port);
+SCM_API SCM scm_read_char (SCM port);
+
+/* Pushback. */
SCM_API void scm_unget_bytes (const unsigned char *buf, size_t len, SCM port);
+SCM_API void scm_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port);
SCM_API void scm_unget_byte (int c, SCM port);
+SCM_API void scm_unget_byte_unlocked (int c, SCM port);
SCM_API void scm_ungetc (scm_t_wchar c, SCM port);
+SCM_API void scm_ungetc_unlocked (scm_t_wchar c, SCM port);
SCM_API void scm_ungets (const char *s, int n, SCM port);
+SCM_API void scm_ungets_unlocked (const char *s, int n, SCM port);
SCM_API SCM scm_peek_char (SCM port);
SCM_API SCM scm_unread_char (SCM cobj, SCM port);
SCM_API SCM scm_unread_string (SCM str, SCM port);
+
+/* Manipulating the buffers. */
+SCM_API void scm_port_non_buffer (scm_t_port *pt);
+SCM_API int scm_fill_input (SCM port);
+SCM_API int scm_fill_input_unlocked (SCM port);
+SCM_INTERNAL size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len);
+SCM_API SCM scm_drain_input (SCM port);
+SCM_API void scm_end_input (SCM port);
+SCM_API void scm_end_input_unlocked (SCM port);
+SCM_API SCM scm_force_output (SCM port);
+SCM_API void scm_flush (SCM port);
+SCM_API void scm_flush_unlocked (SCM port);
+
+/* Output. */
+SCM_API void scm_putc (char c, SCM port);
+SCM_INLINE void scm_putc_unlocked (char c, SCM port);
+SCM_API void scm_puts (const char *str_data, SCM port);
+SCM_INLINE void scm_puts_unlocked (const char *str_data, SCM port);
+SCM_API void scm_c_write (SCM port, const void *buffer, size_t size);
+SCM_API void scm_c_write_unlocked (SCM port, const void *buffer, size_t size);
+SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port);
+SCM_API void scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port);
+SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end,
+ SCM port);
+
+/* Querying and setting positions, and character availability. */
+SCM_API SCM scm_char_ready_p (SCM port);
SCM_API SCM scm_seek (SCM object, SCM offset, SCM whence);
SCM_API SCM scm_truncate_file (SCM object, SCM length);
SCM_API SCM scm_port_line (SCM port);
SCM_API SCM scm_set_port_column_x (SCM port, SCM line);
SCM_API SCM scm_port_filename (SCM port);
SCM_API SCM scm_set_port_filename_x (SCM port, SCM filename);
+
+/* Port properties. */
SCM_INTERNAL SCM scm_i_port_property (SCM port, SCM key);
SCM_INTERNAL SCM scm_i_set_port_property_x (SCM port, SCM key, SCM value);
-SCM_INTERNAL const char *scm_i_default_port_encoding (void);
-SCM_INTERNAL void scm_i_set_default_port_encoding (const char *);
-SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str);
-SCM_API SCM scm_port_encoding (SCM port);
-SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding);
-SCM_INTERNAL scm_t_string_failed_conversion_handler
-scm_i_default_port_conversion_handler (void);
-/* Use HANDLER as the default conversion strategy for future ports. */
-SCM_INTERNAL void
-scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler);
-SCM_API int scm_slow_get_byte_or_eof (SCM port);
-SCM_API int scm_slow_peek_byte_or_eof (SCM port);
-SCM_API SCM scm_port_conversion_strategy (SCM port);
-SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior);
+/* Implementation helpers for port printing functions. */
SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *);
SCM_API void scm_print_port_mode (SCM exp, SCM port);
+
+/* Iterating over all ports. */
+SCM_API SCM scm_port_for_each (SCM proc);
+SCM_API void scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data);
+SCM_API SCM scm_flush_all_ports (void);
+
+/* Void ports. */
SCM_API SCM scm_void_port (char * mode_str);
SCM_API SCM scm_sys_make_void_port (SCM mode);
+
+/* Initialization. */
SCM_INTERNAL void scm_init_ports (void);
-#if SCM_ENABLE_DEPRECATED==1
-SCM_DEPRECATED scm_t_port * scm_add_to_port_table (SCM port);
-#endif
-#ifdef GUILE_DEBUG
-SCM_API SCM scm_pt_size (void);
-SCM_API SCM scm_pt_member (SCM member);
-#endif /* GUILE_DEBUG */
+/* Inline function implementations. */
-/* internal */
+#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
+SCM_INLINE_IMPLEMENTATION int
+scm_c_lock_port (SCM port, scm_i_pthread_mutex_t **lock)
+{
+ *lock = SCM_PTAB_ENTRY (port)->lock;
-SCM_INTERNAL long scm_i_mode_bits (SCM modes);
-SCM_INTERNAL void scm_i_dynwind_current_load_port (SCM port);
+ if (*lock)
+ return scm_i_pthread_mutex_lock (*lock);
+ else
+ return 0;
+}
+
+SCM_INLINE_IMPLEMENTATION int
+scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock)
+{
+ *lock = SCM_PTAB_ENTRY (port)->lock;
+ if (*lock)
+ {
+ int ret = scm_i_pthread_mutex_trylock (*lock);
+ if (ret != 0)
+ *lock = NULL;
+ return ret;
+ }
+ else
+ return 0;
+}
+
+SCM_INLINE_IMPLEMENTATION int
+scm_get_byte_or_eof_unlocked (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random)
+ && pt->read_pos < pt->read_end))
+ return *pt->read_pos++;
+ else
+ return scm_slow_get_byte_or_eof_unlocked (port);
+}
+
+/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */
+SCM_INLINE_IMPLEMENTATION int
+scm_peek_byte_or_eof_unlocked (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random)
+ && pt->read_pos < pt->read_end))
+ return *pt->read_pos;
+ else
+ return scm_slow_peek_byte_or_eof_unlocked (port);
+}
+SCM_INLINE_IMPLEMENTATION void
+scm_putc_unlocked (char c, SCM port)
+{
+ SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
+ scm_lfwrite_unlocked (&c, 1, port);
+}
+
+SCM_INLINE_IMPLEMENTATION void
+scm_puts_unlocked (const char *s, SCM port)
+{
+ SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
+ scm_lfwrite_unlocked (s, strlen (s), port);
+}
+#endif /* SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES */
#endif /* SCM_PORTS_H */
#define FUNC_NAME s_scm_fork
{
int pid;
+ scm_i_finalizer_pre_fork ();
if (scm_ilength (scm_all_threads ()) != 1)
/* Other threads may be holding on to resources that Guile needs --
it is not safe to permit one thread to fork while others are
#include <uniconv.h>
#include <unictype.h>
-#include <c-strcase.h>
#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/macros.h"
#include "libguile/procprop.h"
#include "libguile/read.h"
-#include "libguile/weaks.h"
#include "libguile/programs.h"
#include "libguile/alist.h"
#include "libguile/struct.h"
{ \
if (pstate->top - pstate->list_offset >= pstate->level) \
{ \
- scm_putc ('#', port); \
+ scm_putc_unlocked ('#', port); \
return; \
} \
} \
for (i = pstate->top - 1; 1; --i)
if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref))
break;
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
scm_intprint (i - self, 10, port);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
}
/* Print the name of a symbol. */
(INITIAL_IDENTIFIER_MASK \
| UC_CATEGORY_MASK_Nd | UC_CATEGORY_MASK_Mc | UC_CATEGORY_MASK_Me)
+/* FIXME: Cache this information on the symbol, somehow. */
static int
symbol_has_extended_read_syntax (SCM sym)
{
c = scm_i_symbol_ref (sym, 0);
- /* Single dot; conflicts with dotted-pair notation. */
- if (len == 1 && c == '.')
- return 1;
-
- /* Other initial-character constraints. */
- if (c == '\'' || c == '`' || c == ',' || c == '"' || c == ';' || c == '#')
- return 1;
-
- /* R7RS allows neither '|' nor '\' in bare symbols. */
- if ((c == '|' || c == '\\') && SCM_PRINT_R7RS_SYMBOLS_P)
- return 1;
+ switch (c)
+ {
+ case '\'':
+ case '`':
+ case ',':
+ case '"':
+ case ';':
+ case '#':
+ /* Some initial-character constraints. */
+ return 1;
+
+ case '|':
+ case '\\':
+ /* R7RS allows neither '|' nor '\' in bare symbols. */
+ if (SCM_PRINT_R7RS_SYMBOLS_P)
+ return 1;
+ break;
- /* Keywords can be identified by trailing colons too. */
- if (c == ':' || scm_i_symbol_ref (sym, len - 1) == ':')
- return quote_keywordish_symbols ();
+ case ':':
+ /* Symbols that look like keywords. */
+ return quote_keywordish_symbols ();
- /* Number-ish symbols. */
- if (scm_is_true (scm_i_string_to_number (scm_symbol_to_string (sym), 10)))
- return 1;
+ case '.':
+ /* Single dot conflicts with dotted-pair notation. */
+ if (len == 1)
+ return 1;
+ /* Fall through to check numbers. */
+ case '+':
+ case '-':
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ /* Number-ish symbols. Numbers with radixes already caught be #
+ above. */
+ if (scm_is_true (scm_i_string_to_number (scm_symbol_to_string (sym), 10)))
+ return 1;
+ break;
+
+ default:
+ break;
+ }
/* Other disallowed first characters. */
if (!uc_is_general_category_withtable (c, INITIAL_IDENTIFIER_MASK))
return 1;
+ /* Keywords can be identified by trailing colons too. */
+ if (scm_i_symbol_ref (sym, len - 1) == ':')
+ return quote_keywordish_symbols ();
+
/* Otherwise, any character that's in the identifier category mask is
fine to pass through as-is, provided it's not one of the ASCII
delimiters like `;'. */
static void
print_normal_symbol (SCM sym, SCM port)
{
- scm_display (scm_symbol_to_string (sym), port);
+ size_t len;
+ scm_t_string_failed_conversion_handler strategy;
+
+ len = scm_i_symbol_length (sym);
+ strategy = SCM_PTAB_ENTRY (port)->ilseq_handler;
+
+ if (scm_i_is_narrow_symbol (sym))
+ display_string (scm_i_symbol_chars (sym), 1, len, port, strategy);
+ else
+ display_string (scm_i_symbol_wide_chars (sym), 0, len, port, strategy);
}
static void
len = scm_i_symbol_length (sym);
strategy = PORT_CONVERSION_HANDLER (port);
- scm_lfwrite ("#{", 2, port);
+ scm_lfwrite_unlocked ("#{", 2, port);
for (pos = 0; pos < len; pos++)
{
}
else
{
- scm_lfwrite ("\\x", 2, port);
+ scm_lfwrite_unlocked ("\\x", 2, port);
scm_intprint (c, 16, port);
- scm_putc (';', port);
+ scm_putc_unlocked (';', port);
}
}
- scm_lfwrite ("}#", 2, port);
+ scm_lfwrite_unlocked ("}#", 2, port);
}
static void
len = scm_i_symbol_length (sym);
strategy = PORT_CONVERSION_HANDLER (port);
- scm_putc ('|', port);
+ scm_putc_unlocked ('|', port);
for (pos = 0; pos < len; pos++)
{
switch (c)
{
- case '\a': scm_lfwrite ("\\a", 2, port); break;
- case '\b': scm_lfwrite ("\\b", 2, port); break;
- case '\t': scm_lfwrite ("\\t", 2, port); break;
- case '\n': scm_lfwrite ("\\n", 2, port); break;
- case '\r': scm_lfwrite ("\\r", 2, port); break;
- case '|': scm_lfwrite ("\\|", 2, port); break;
- case '\\': scm_lfwrite ("\\x5c;", 5, port); break;
+ case '\a': scm_lfwrite_unlocked ("\\a", 2, port); break;
+ case '\b': scm_lfwrite_unlocked ("\\b", 2, port); break;
+ case '\t': scm_lfwrite_unlocked ("\\t", 2, port); break;
+ case '\n': scm_lfwrite_unlocked ("\\n", 2, port); break;
+ case '\r': scm_lfwrite_unlocked ("\\r", 2, port); break;
+ case '|': scm_lfwrite_unlocked ("\\|", 2, port); break;
+ case '\\': scm_lfwrite_unlocked ("\\x5c;", 5, port); break;
default:
if (uc_is_general_category_withtable (c,
UC_CATEGORY_MASK_L
}
else
{
- scm_lfwrite ("\\x", 2, port);
+ scm_lfwrite_unlocked ("\\x", 2, port);
scm_intprint (c, 16, port);
- scm_putc (';', port);
+ scm_putc_unlocked (';', port);
}
break;
}
}
- scm_putc ('|', port);
+ scm_putc_unlocked ('|', port);
}
/* FIXME: allow R6RS hex escapes instead of #{...}# or |...|. */
-void
-scm_i_print_symbol_name (SCM sym, SCM port)
+static void
+print_symbol (SCM sym, SCM port)
{
if (!symbol_has_extended_read_syntax (sym))
print_normal_symbol (sym, port);
void
scm_print_symbol_name (const char *str, size_t len, SCM port)
{
- SCM symbol = scm_from_locale_symboln (str, len);
- scm_i_print_symbol_name (symbol, port);
+ SCM symbol = scm_from_utf8_symboln (str, len);
+ print_symbol (symbol, port);
}
/* Print generally. Handles both write and display according to PSTATE.
scm_intprint (i, 8, port); \
else \
{ \
- scm_puts ("x", port); \
+ scm_puts_unlocked ("x", port); \
scm_intprint (i, 16, port); \
} \
} \
iprin1 (exp, port, pstate);
}
+static void
+print_vector_or_weak_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t),
+ SCM port, scm_print_state *pstate)
+{
+ long i;
+ long last = len - 1;
+ int cutp = 0;
+ if (pstate->fancyp && len > pstate->length)
+ {
+ last = pstate->length - 1;
+ cutp = 1;
+ }
+ for (i = 0; i < last; ++i)
+ {
+ scm_iprin1 (ref (v, i), port, pstate);
+ scm_putc_unlocked (' ', port);
+ }
+ if (i == last)
+ {
+ /* CHECK_INTS; */
+ scm_iprin1 (ref (v, i), port, pstate);
+ }
+ if (cutp)
+ scm_puts_unlocked (" ...", port);
+ scm_putc_unlocked (')', port);
+}
+
static void
iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
else if (SCM_IFLAGP (exp)
&& ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *))))
{
- scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
+ scm_puts_unlocked (iflagnames [SCM_IFLAGNUM (exp)], port);
}
else
{
goto print_struct;
pwps = scm_i_port_with_print_state (port, pstate->handle);
pstate->revealed = 1;
- scm_call_generic_2 (print, exp, pwps);
+ scm_call_2 (print, exp, pwps);
}
else
{
break;
}
break;
+ case scm_tc7_stringbuf:
+ scm_i_print_stringbuf (exp, port, pstate);
+ break;
case scm_tc7_string:
{
size_t len, printed;
case scm_tc7_symbol:
if (scm_i_symbol_is_interned (exp))
{
- scm_i_print_symbol_name (exp, port);
+ print_symbol (exp, port);
scm_remember_upto_here_1 (exp);
}
else
{
- scm_puts ("#<uninterned-symbol ", port);
- scm_i_print_symbol_name (exp, port);
- scm_putc (' ', port);
+ scm_puts_unlocked ("#<uninterned-symbol ", port);
+ print_symbol (exp, port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
break;
case scm_tc7_variable:
case scm_tc7_hashtable:
scm_i_hashtable_print (exp, port, pstate);
break;
+ case scm_tc7_weak_set:
+ scm_i_weak_set_print (exp, port, pstate);
+ break;
+ case scm_tc7_weak_table:
+ scm_i_weak_table_print (exp, port, pstate);
+ break;
case scm_tc7_fluid:
scm_i_fluid_print (exp, port, pstate);
break;
case scm_tc7_frame:
scm_i_frame_print (exp, port, pstate);
break;
- case scm_tc7_objcode:
- scm_i_objcode_print (exp, port, pstate);
- break;
- case scm_tc7_vm:
- scm_i_vm_print (exp, port, pstate);
- break;
+ case scm_tc7_keyword:
+ scm_puts_unlocked ("#:", port);
+ scm_iprin1 (scm_keyword_to_symbol (exp), port, pstate);
+ break;
case scm_tc7_vm_cont:
scm_i_vm_cont_print (exp, port, pstate);
break;
- case scm_tc7_prompt:
- scm_i_prompt_print (exp, port, pstate);
- break;
- case scm_tc7_with_fluids:
- scm_i_with_fluids_print (exp, port, pstate);
- break;
case scm_tc7_array:
ENTER_NESTED_DATA (pstate, exp, circref);
scm_i_print_array (exp, port, pstate);
break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
- if (SCM_IS_WHVEC (exp))
- scm_puts ("#wh(", port);
- else
- scm_puts ("#w(", port);
- goto common_vector_printer;
+ scm_puts_unlocked ("#w(", port);
+ print_vector_or_weak_vector (exp, scm_c_weak_vector_length (exp),
+ scm_c_weak_vector_ref, port, pstate);
+ EXIT_NESTED_DATA (pstate);
+ break;
case scm_tc7_vector:
ENTER_NESTED_DATA (pstate, exp, circref);
- scm_puts ("#(", port);
- common_vector_printer:
- {
- register long i;
- long last = SCM_SIMPLE_VECTOR_LENGTH (exp) - 1;
- int cutp = 0;
- if (pstate->fancyp
- && SCM_SIMPLE_VECTOR_LENGTH (exp) > pstate->length)
- {
- last = pstate->length - 1;
- cutp = 1;
- }
- if (SCM_I_WVECTP (exp))
- {
- /* Elements of weak vectors may not be accessed via the
- `SIMPLE_VECTOR_REF ()' macro. */
- for (i = 0; i < last; ++i)
- {
- scm_iprin1 (scm_c_weak_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_I_WVECTP (exp)
- ? scm_c_weak_vector_ref (exp, i)
- : SCM_SIMPLE_VECTOR_REF (exp, i),
- port, pstate);
- }
- if (cutp)
- scm_puts (" ...", port);
- scm_putc (')', port);
- }
+ scm_puts_unlocked ("#(", port);
+ print_vector_or_weak_vector (exp, SCM_SIMPLE_VECTOR_LENGTH (exp),
+ scm_c_vector_ref, port, pstate);
EXIT_NESTED_DATA (pstate);
break;
case scm_tc7_port:
{
- register long i = SCM_PTOBNUM (exp);
- if (i < scm_numptob
- && scm_ptobs[i].print
- && (scm_ptobs[i].print) (exp, port, pstate))
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (exp);
+ if (ptob->print && ptob->print (exp, port, pstate))
break;
goto punk;
}
/* INPUT was successfully converted, entirely; print the
result. */
- scm_lfwrite (utf8_buf, utf8_len, port);
+ scm_lfwrite_unlocked (utf8_buf, utf8_len, port);
printed += i - printed;
}
return len;
}
+/* Write STR to PORT as ISO-8859-1. STR is a LEN-codepoint string; it
+ is narrow if NARROW_P is true, wide otherwise. Return LEN. */
+static size_t
+display_string_as_latin1 (const void *str, int narrow_p, size_t len,
+ SCM port,
+ scm_t_string_failed_conversion_handler strategy)
+{
+ size_t printed = 0;
+
+ if (narrow_p)
+ {
+ scm_lfwrite_unlocked (str, len, port);
+ return len;
+ }
+
+ while (printed < len)
+ {
+ char buf[256];
+ size_t i;
+
+ for (i = 0; i < sizeof(buf) && printed < len; i++, printed++)
+ {
+ scm_t_wchar c = STR_REF (str, printed);
+
+ if (c < 256)
+ buf[i] = c;
+ else
+ break;
+ }
+
+ scm_lfwrite_unlocked (buf, i, port);
+
+ if (i < sizeof(buf) && printed < len)
+ {
+ if (strategy == SCM_FAILED_CONVERSION_ERROR)
+ break;
+ else if (strategy == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ write_character_escaped (STR_REF (str, printed), 1, port);
+ else
+ /* STRATEGY is `SCM_FAILED_CONVERSION_QUESTION_MARK'. */
+ display_string ("?", 1, 1, port, strategy);
+ printed++;
+ }
+ }
+
+ return printed;
+}
+
/* Convert STR through PORT's output conversion descriptor and write the
output to PORT. Return the number of codepoints written. */
static size_t
pti->at_stream_start_for_bom_read = 0;
/* Write a BOM if appropriate. */
- if (SCM_UNLIKELY (c_strcasecmp(pt->encoding, "UTF-16") == 0
- || c_strcasecmp(pt->encoding, "UTF-32") == 0))
+ if (SCM_UNLIKELY (strcmp(pt->encoding, "UTF-16") == 0
+ || strcmp(pt->encoding, "UTF-32") == 0))
display_character (SCM_UNICODE_BOM, port, iconveh_error);
}
iconv (id->output_cd, NULL, NULL, NULL, NULL);
/* Print the OUTPUT_LEN bytes successfully converted. */
- scm_lfwrite (encoded_output, output_len, port);
+ scm_lfwrite_unlocked (encoded_output, output_len, port);
/* See how many input codepoints these OUTPUT_LEN bytes
corresponds to. */
{
/* INPUT was successfully converted, entirely; print the
result. */
- scm_lfwrite (encoded_output, output_len, port);
+ scm_lfwrite_unlocked (encoded_output, output_len, port);
codepoints_read = i - printed;
printed += codepoints_read;
}
display_string (const void *str, int narrow_p,
size_t len, SCM port,
scm_t_string_failed_conversion_handler strategy)
-
{
scm_t_port_internal *pti;
if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
return display_string_as_utf8 (str, narrow_p, len, port);
+ else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ return display_string_as_latin1 (str, narrow_p, len, port, strategy);
else
- return display_string_using_iconv (str, narrow_p, len,
- port, strategy);
+ return display_string_using_iconv (str, narrow_p, len, port, strategy);
}
/* Attempt to display CH to PORT according to STRATEGY. Return one if
/* Use special escapes for some C0 controls. */
buf[0] = '\\';
buf[1] = escapes[ch - 0x07];
- scm_lfwrite (buf, 2, port);
+ scm_lfwrite_unlocked (buf, 2, port);
}
else if (!SCM_R6RS_ESCAPES_P)
{
buf[1] = 'x';
buf[2] = hex[ch / 16];
buf[3] = hex[ch % 16];
- scm_lfwrite (buf, 4, port);
+ scm_lfwrite_unlocked (buf, 4, port);
}
else if (ch <= 0xFFFF)
{
buf[3] = hex[(ch & 0xF00) >> 8];
buf[4] = hex[(ch & 0xF0) >> 4];
buf[5] = hex[(ch & 0xF)];
- scm_lfwrite (buf, 6, port);
+ scm_lfwrite_unlocked (buf, 6, port);
}
else if (ch > 0xFFFF)
{
buf[5] = hex[(ch & 0xF00) >> 8];
buf[6] = hex[(ch & 0xF0) >> 4];
buf[7] = hex[(ch & 0xF)];
- scm_lfwrite (buf, 8, port);
+ scm_lfwrite_unlocked (buf, 8, port);
}
}
else
buf[i] = 'x';
i --;
buf[i] = '\\';
- scm_lfwrite (buf + i, 9 - i, port);
+ scm_lfwrite_unlocked (buf + i, 9 - i, port);
}
}
else
name = scm_i_charname (SCM_MAKE_CHAR (ch));
if (name != NULL)
- scm_puts (name, port);
+ scm_puts_unlocked (name, port);
else
PRINT_CHAR_ESCAPE (ch, port);
}
scm_intprint (scm_t_intmax n, int radix, SCM port)
{
char num_buf[SCM_INTBUFLEN];
- scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
+ scm_lfwrite_unlocked (num_buf, scm_iint2str (n, radix, num_buf), port);
}
void
scm_uintprint (scm_t_uintmax n, int radix, SCM port)
{
char num_buf[SCM_INTBUFLEN];
- scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port);
+ scm_lfwrite_unlocked (num_buf, scm_iuint2str (n, radix, num_buf), port);
}
/* Print an object of unrecognized type.
void
scm_ipruk (char *hdr, SCM ptr, SCM port)
{
- scm_puts ("#<unknown-", port);
- scm_puts (hdr, port);
+ scm_puts_unlocked ("#<unknown-", port);
+ scm_puts_unlocked (hdr, port);
if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
{
- scm_puts (" (0x", port);
+ scm_puts_unlocked (" (0x", port);
scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
- scm_puts (" . 0x", port);
+ scm_puts_unlocked (" . 0x", port);
scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
- scm_puts (") @", port);
+ scm_puts_unlocked (") @", port);
}
- scm_puts (" 0x", port);
+ scm_puts_unlocked (" 0x", port);
scm_uintprint (SCM_UNPACK (ptr), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
{
register SCM hare, tortoise;
long floor = pstate->top - 2;
- scm_puts (hdr, port);
+ scm_puts_unlocked (hdr, port);
/* CHECK_INTS; */
if (pstate->fancyp)
goto fancy_printing;
if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
goto circref;
PUSH_REF (pstate, exp);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
/* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate);
}
if (!SCM_NULL_OR_NIL_P (exp))
{
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
scm_iprin1 (exp, port, pstate);
}
end:
- scm_putc (tlr, port);
+ scm_putc_unlocked (tlr, port);
pstate->top = floor + 2;
return;
{
if (n == 0)
{
- scm_puts (" ...", port);
+ scm_puts_unlocked (" ...", port);
goto skip_tail;
}
else
}
PUSH_REF(pstate, exp);
++pstate->list_offset;
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
/* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate);
}
}
if (!SCM_NULL_OR_NIL_P (exp))
{
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
scm_iprin1 (exp, port, pstate);
}
skip_tail:
pstate->list_offset -= pstate->top - floor - 2;
circref:
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
print_circref (port, pstate, exp);
goto end;
}
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
+ scm_dynwind_begin (0);
+ scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port));
scm_prin1 (obj, port, 1);
+ scm_dynwind_end ();
+
return SCM_UNSPECIFIED;
}
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
+ scm_dynwind_begin (0);
+ scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port));
scm_prin1 (obj, port, 0);
+ scm_dynwind_end ();
+
return SCM_UNSPECIFIED;
}
SCM_VALIDATE_OPORT_VALUE (1, port);
- scm_putc ('\n', SCM_COERCE_OUTPORT (port));
+ scm_putc_unlocked ('\n', SCM_COERCE_OUTPORT (port));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate)
{
obj = SCM_PORT_WITH_PS_PORT (obj);
- return scm_ptobs[SCM_PTOBNUM (obj)].print (obj, port, pstate);
+ return SCM_PORT_DESCRIPTOR (obj)->print (obj, port, pstate);
}
SCM
{
SCM type;
- scm_gc_register_root (&print_state_pool);
- scm_gc_register_root (&scm_print_state_vtable);
type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT),
SCM_BOOL_F);
scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port);
SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port);
SCM_API void scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate);
-SCM_INTERNAL void scm_i_print_symbol_name (SCM sym, SCM port);
SCM_API void scm_print_symbol_name (const char *str, size_t len, SCM port);
SCM_API void scm_prin1 (SCM exp, SCM port, int writingp);
SCM_API void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate);
+++ /dev/null
-/*
- * 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
-/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2004, 2006,
- * 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 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 <config.h>
#endif
-#define SCM_BUILDING_DEPRECATED_CODE
-
#include "libguile/_scm.h"
#include "libguile/alist.h"
-#include "libguile/deprecation.h"
-#include "libguile/deprecated.h"
#include "libguile/eval.h"
#include "libguile/procs.h"
#include "libguile/gsubr.h"
#include "libguile/smob.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
-#include "libguile/hashtab.h"
+#include "libguile/weak-table.h"
#include "libguile/programs.h"
+#include "libguile/vm-builtins.h"
#include "libguile/validate.h"
#include "libguile/procprop.h"
\f
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
-#if (SCM_ENABLE_DEPRECATED == 1)
-SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
-#endif
SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
static SCM overrides;
-static scm_i_pthread_mutex_t overrides_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
static SCM arity_overrides;
{
SCM o;
- scm_i_pthread_mutex_lock (&overrides_lock);
- o = scm_hashq_ref (arity_overrides, proc, SCM_BOOL_F);
- scm_i_pthread_mutex_unlock (&overrides_lock);
+ o = scm_weak_table_refq (arity_overrides, proc, SCM_BOOL_F);
if (scm_is_true (o))
{
while (!SCM_PROGRAM_P (proc))
{
- if (SCM_IMP (proc))
- return 0;
- switch (SCM_TYP7 (proc))
+ if (SCM_STRUCTP (proc))
+ {
+ if (!SCM_STRUCT_APPLICABLE_P (proc))
+ return 0;
+ proc = SCM_STRUCT_PROCEDURE (proc);
+ }
+ else if (SCM_HAS_TYP7 (proc, scm_tc7_smob))
{
- case scm_tc7_smob:
if (!SCM_SMOB_APPLICABLE_P (proc))
return 0;
- if (!scm_i_program_arity
- (SCM_SMOB_DESCRIPTOR (proc).apply_trampoline_objcode,
- req, opt, rest))
+ if (!scm_i_program_arity (SCM_SMOB_DESCRIPTOR (proc).apply_trampoline,
+ req, opt, rest))
return 0;
/* The trampoline gets the smob too, which users don't
*req -= 1;
return 1;
- case scm_tcs_struct:
- if (!SCM_STRUCT_APPLICABLE_P (proc))
- return 0;
- proc = SCM_STRUCT_PROCEDURE (proc);
- break;
- default:
- return 0;
}
+ else
+ return 0;
}
return scm_i_program_arity (proc, req, opt, rest);
SCM_VALIDATE_INT_COPY (3, opt, t);
SCM_VALIDATE_BOOL (4, rest);
- scm_i_pthread_mutex_lock (&overrides_lock);
- scm_hashq_set_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
- scm_i_pthread_mutex_unlock (&overrides_lock);
+ scm_weak_table_putq_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
return SCM_UNDEFINED;
}
#undef FUNC_NAME
"Return @var{proc}'s property list.")
#define FUNC_NAME s_scm_procedure_properties
{
- SCM ret;
+ SCM ret, user_props;
SCM_VALIDATE_PROC (1, proc);
- scm_i_pthread_mutex_lock (&overrides_lock);
- ret = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
- scm_i_pthread_mutex_unlock (&overrides_lock);
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
- if (scm_is_false (ret))
- {
- if (SCM_PROGRAM_P (proc))
- ret = scm_i_program_properties (proc);
- else
- ret = SCM_EOL;
- }
-
-#if (SCM_ENABLE_DEPRECATED == 1)
- ret = scm_acons (scm_sym_arity, scm_procedure_minimum_arity (proc), ret);
-#endif
+ if (scm_is_pair (user_props) && scm_is_true (scm_car (user_props)))
+ return scm_cdr (user_props);
+
+ if (SCM_PROGRAM_P (proc))
+ ret = scm_i_program_properties (proc);
+ else
+ ret = SCM_EOL;
+
+ if (scm_is_pair (user_props))
+ for (user_props = scm_cdr (user_props);
+ scm_is_pair (user_props);
+ user_props = scm_cdr (user_props))
+ ret = scm_assq_set_x (ret, scm_caar (user_props), scm_cdar (user_props));
return ret;
}
{
SCM_VALIDATE_PROC (1, proc);
-#if (SCM_ENABLE_DEPRECATED == 1)
- if (scm_is_true (scm_assq (scm_sym_arity, alist)))
- SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
-#endif
-
- scm_i_pthread_mutex_lock (&overrides_lock);
- scm_hashq_set_x (overrides, proc, alist);
- scm_i_pthread_mutex_unlock (&overrides_lock);
+ scm_weak_table_putq_x (overrides, proc, scm_cons (SCM_BOOL_T, alist));
return SCM_UNSPECIFIED;
}
"Return the property of @var{proc} with name @var{key}.")
#define FUNC_NAME s_scm_procedure_property
{
+ SCM user_props;
+
SCM_VALIDATE_PROC (1, proc);
-#if (SCM_ENABLE_DEPRECATED == 1)
- if (scm_is_eq (key, scm_sym_arity))
- scm_c_issue_deprecation_warning
- ("Accessing a procedure's arity via `procedure-property' is deprecated.\n"
- "Use `procedure-minimum-arity instead.");
-#endif
+ if (scm_is_eq (key, scm_sym_name))
+ return scm_procedure_name (proc);
+ if (scm_is_eq (key, scm_sym_documentation))
+ return scm_procedure_documentation (proc);
+
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_true (user_props))
+ {
+ SCM pair = scm_assq (key, scm_cdr (user_props));
+ if (scm_is_pair (pair))
+ return scm_cdr (pair);
+ if (scm_is_true (scm_car (user_props)))
+ return SCM_BOOL_F;
+ }
return scm_assq_ref (scm_procedure_properties (proc), key);
}
"@var{val}.")
#define FUNC_NAME s_scm_set_procedure_property_x
{
- SCM props;
+ SCM user_props, override_p;
SCM_VALIDATE_PROC (1, proc);
-#if (SCM_ENABLE_DEPRECATED == 1)
- if (scm_is_eq (key, scm_sym_arity))
- SCM_MISC_ERROR ("arity is a deprecated read-only property", SCM_EOL);
-#endif
-
- scm_dynwind_begin (0);
- /* Here we must block asyncs while overrides_lock is held, to avoid
- deadlocks which can happen as follows: scm_i_program_properties
- calls out to the VM, which will run asyncs. Asyncs are permitted
- to run VM code, which sometimes checks procedure properties, which
- locks overrides_lock. */
- scm_i_dynwind_pthread_mutex_lock_block_asyncs (&overrides_lock);
- props = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
- if (scm_is_false (props))
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_false (user_props))
{
- if (SCM_PROGRAM_P (proc))
- props = scm_i_program_properties (proc);
- else
- props = SCM_EOL;
+ override_p = SCM_BOOL_F;
+ user_props = SCM_EOL;
+ }
+ else
+ {
+ override_p = scm_car (user_props);
+ user_props = scm_cdr (user_props);
}
- scm_hashq_set_x (overrides, proc, scm_assq_set_x (props, key, val));
- scm_dynwind_end ();
+ scm_weak_table_putq_x (overrides, proc,
+ scm_cons (override_p,
+ scm_assq_set_x (user_props, key, val)));
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+
\f
+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 user_props;
+
+ SCM_VALIDATE_PROC (1, proc);
+
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_true (user_props))
+ {
+ SCM pair = scm_assq (scm_sym_name, scm_cdr (user_props));
+ if (scm_is_pair (pair))
+ return scm_cdr (pair);
+ if (scm_is_true (scm_car (user_props)))
+ return SCM_BOOL_F;
+ }
+
+ if (SCM_PROGRAM_P (proc))
+ return scm_i_program_name (proc);
+ else if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
+
+SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
+ (SCM proc),
+ "Return the documentation string associated with @code{proc}. By\n"
+ "convention, if a procedure contains more than one expression and the\n"
+ "first expression is a string constant, that string is assumed to contain\n"
+ "documentation for that procedure.")
+#define FUNC_NAME s_scm_procedure_documentation
+{
+ SCM user_props;
+
+ SCM_VALIDATE_PROC (1, proc);
+
+ while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ proc = SCM_STRUCT_PROCEDURE (proc);
+
+ user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
+ if (scm_is_true (user_props))
+ {
+ SCM pair = scm_assq (scm_sym_documentation, scm_cdr (user_props));
+ if (scm_is_pair (pair))
+ return scm_cdr (pair);
+ if (scm_is_true (scm_car (user_props)))
+ return SCM_BOOL_F;
+ }
+
+ if (SCM_PROGRAM_P (proc))
+ return scm_i_program_documentation (proc);
+ else
+ return SCM_BOOL_F;
+}
+#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;
+
+ if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
+ && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
+ continue;
+ }
+ while (0);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+\f
void
scm_init_procprop ()
{
- overrides = scm_make_weak_key_hash_table (SCM_UNDEFINED);
- arity_overrides = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
+ arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
#include "libguile/procprop.x"
+ scm_init_vm_builtin_properties ();
}
#ifndef SCM_PROCPROP_H
#define SCM_PROCPROP_H
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2009, 2010, 2011, 2013 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_API SCM scm_sym_name;
-#if (SCM_ENABLE_DEPRECATED == 1)
-SCM_DEPRECATED SCM scm_sym_arity;
-#endif
SCM_API SCM scm_sym_system_procedure;
+SCM_INTERNAL SCM scm_sym_documentation;
\f
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_API SCM scm_procedure_source (SCM proc);
+SCM_API SCM scm_procedure_name (SCM proc);
+SCM_API SCM scm_procedure_documentation (SCM proc);
SCM_INTERNAL void scm_init_procprop (void);
#endif /* SCM_PROCPROP_H */
/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2006, 2008, 2009,
- * 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2010, 2011, 2012, 2013 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/procs.h"
#include "libguile/procprop.h"
-#include "libguile/objcodes.h"
+#include "libguile/loader.h"
#include "libguile/programs.h"
\f
"Return @code{#t} if @var{obj} is a procedure.")
#define FUNC_NAME s_scm_procedure_p
{
- if (SCM_NIMP (obj))
- switch (SCM_TYP7 (obj))
- {
- case scm_tcs_struct:
- if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
- || SCM_STRUCT_APPLICABLE_P (obj)))
- break;
- case scm_tc7_program:
- return SCM_BOOL_T;
- case scm_tc7_smob:
- return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
- default:
- return SCM_BOOL_F;
- }
- return SCM_BOOL_F;
+ return scm_from_bool (SCM_PROGRAM_P (obj)
+ || (SCM_STRUCTP (obj) && SCM_STRUCT_APPLICABLE_P (obj))
+ || (SCM_HAS_TYP7 (obj, scm_tc7_smob)
+ && SCM_SMOB_APPLICABLE_P (obj)));
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-SCM_GLOBAL_SYMBOL (scm_sym_documentation, "documentation");
-
-SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
- (SCM proc),
- "Return the documentation string associated with @code{proc}. By\n"
- "convention, if a procedure contains more than one expression and the\n"
- "first expression is a string constant, that string is assumed to contain\n"
- "documentation for that procedure.")
-#define FUNC_NAME s_scm_procedure_documentation
-{
- SCM_VALIDATE_PROC (SCM_ARG1, proc);
- return scm_procedure_property (proc, scm_sym_documentation);
-}
-#undef FUNC_NAME
-
/* Procedure-with-setter
*/
"with the associated setter @var{setter}.")
#define FUNC_NAME s_scm_make_procedure_with_setter
{
- SCM name, ret;
SCM_VALIDATE_PROC (1, procedure);
SCM_VALIDATE_PROC (2, setter);
- 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 */
- name = scm_procedure_property (procedure, scm_sym_name);
- if (scm_is_true (name))
- scm_set_procedure_property_x (ret, scm_sym_name, name);
- return ret;
+ return scm_make_struct (pws_vtable, SCM_INUM0,
+ scm_list_2 (procedure, setter));
}
#undef FUNC_NAME
"applicable struct with a setter.")
#define FUNC_NAME s_scm_setter
{
- SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
+ if (SCM_UNLIKELY (!SCM_STRUCTP (proc)))
+ return scm_wta_dispatch_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
if (SCM_STRUCT_SETTER_P (proc))
return SCM_STRUCT_SETTER (proc);
if (SCM_PUREGENERICP (proc)
&& SCM_IS_A_P (proc, scm_class_generic_with_setter))
/* 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_wta_dispatch_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
return SCM_BOOL_F; /* not reached */
}
#undef FUNC_NAME
#define SCM_PROCS_H
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2006, 2008, 2009,
- * 2012 Free Software Foundation, Inc.
+ * 2012, 2013 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_procedure_p (SCM obj);
SCM_API SCM scm_thunk_p (SCM obj);
-SCM_API SCM scm_procedure_documentation (SCM proc);
SCM_API SCM scm_procedure_with_setter_p (SCM obj);
SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter);
SCM_API SCM scm_procedure (SCM proc);
SCM_API SCM scm_setter (SCM proc);
SCM_INTERNAL void scm_init_procs (void);
-SCM_INTERNAL SCM scm_sym_documentation;
-
#endif /* SCM_PROCS_H */
/*
-/* Copyright (C) 2001, 2009, 2010, 2011, 2013 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 <string.h>
-#include "_scm.h"
-#include "instructions.h"
-#include "modules.h"
-#include "programs.h"
-#include "procprop.h" /* scm_sym_name */
-#include "srcprop.h" /* scm_sym_filename */
-#include "vm.h"
-
-\f
-static SCM write_program = SCM_BOOL_F;
-
-SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
- (SCM objcode, SCM objtable, SCM free_variables),
- "")
-#define FUNC_NAME s_scm_make_program
-{
- SCM_VALIDATE_OBJCODE (1, objcode);
- if (SCM_UNLIKELY (SCM_UNBNDP (objtable)))
- objtable = SCM_BOOL_F;
- else if (scm_is_true (objtable))
- SCM_VALIDATE_VECTOR (2, objtable);
-
- if (SCM_UNBNDP (free_variables) || scm_is_false (free_variables))
- {
- SCM ret = scm_words (scm_tc7_program, 3);
- SCM_SET_CELL_OBJECT_1 (ret, objcode);
- SCM_SET_CELL_OBJECT_2 (ret, objtable);
- return ret;
- }
- else
- {
- size_t i, len;
- SCM ret;
- SCM_VALIDATE_VECTOR (3, free_variables);
- len = scm_c_vector_length (free_variables);
- if (SCM_UNLIKELY (len >> 16))
- SCM_OUT_OF_RANGE (3, free_variables);
- ret = scm_words (scm_tc7_program | (len<<16), 3 + len);
- SCM_SET_CELL_OBJECT_1 (ret, objcode);
- SCM_SET_CELL_OBJECT_2 (ret, objtable);
- for (i = 0; i < len; i++)
- SCM_SET_CELL_OBJECT (ret, 3+i,
- SCM_SIMPLE_VECTOR_REF (free_variables, i));
- return ret;
- }
-}
-#undef FUNC_NAME
-
-void
-scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
-{
- static int print_error = 0;
-
- 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_latin1_symbol ("write-program"));
-
- if (SCM_PROGRAM_IS_CONTINUATION (program))
- {
- /* twingliness */
- scm_puts ("#<continuation ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
- }
- else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
- {
- /* twingliness */
- scm_puts ("#<partial-continuation ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
- }
- else if (scm_is_false (write_program) || print_error)
- {
- scm_puts ("#<program ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
- }
- else
- {
- print_error = 1;
- scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
- print_error = 0;
- }
-}
-
-\f
-/*
- * Scheme interface
- */
-
-SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
- (SCM obj),
- "")
-#define FUNC_NAME s_scm_program_p
-{
- return scm_from_bool (SCM_PROGRAM_P (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_base
-{
- const struct scm_objcode *c_objcode;
-
- SCM_VALIDATE_PROGRAM (1, program);
-
- c_objcode = SCM_PROGRAM_DATA (program);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_C_OBJCODE_BASE (c_objcode));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_objects
-{
- SCM_VALIDATE_PROGRAM (1, program);
- return SCM_PROGRAM_OBJTABLE (program);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_module
-{
- SCM objs, mod;
- SCM_VALIDATE_PROGRAM (1, program);
- objs = SCM_PROGRAM_OBJTABLE (program);
- /* If a program is the result of compiling GLIL to assembly, then if
- it has an objtable, the first entry will be a module. But some
- programs are hand-coded trampolines, like boot programs and
- primitives and the like. So if a program happens to have a
- non-module in the first slot of the objtable, assume that it is
- such a trampoline, and just return #f for the module. */
- mod = scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
- return SCM_MODULEP (mod) ? mod : SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_meta
-{
- SCM metaobj;
-
- SCM_VALIDATE_PROGRAM (1, program);
-
- metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
- if (scm_is_true (metaobj))
- return scm_make_program (metaobj, SCM_PROGRAM_OBJTABLE (program),
- SCM_BOOL_F);
- else
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_bindings
-{
- SCM meta;
-
- SCM_VALIDATE_PROGRAM (1, program);
-
- meta = scm_program_meta (program);
- if (scm_is_false (meta))
- return SCM_BOOL_F;
-
- return scm_car (scm_call_0 (meta));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_sources
-{
- SCM meta, sources, ret, filename;
-
- SCM_VALIDATE_PROGRAM (1, program);
-
- meta = scm_program_meta (program);
- if (scm_is_false (meta))
- return SCM_EOL;
-
- filename = SCM_BOOL_F;
- ret = SCM_EOL;
- for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources);
- sources = scm_cdr (sources))
- {
- SCM x = scm_car (sources);
- if (scm_is_pair (x))
- {
- if (scm_is_number (scm_car (x)))
- {
- SCM addr = scm_car (x);
- ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)),
- ret);
- }
- else if (scm_is_eq (scm_car (x), scm_sym_filename))
- filename = scm_cdr (x);
- }
- }
- return scm_reverse_x (ret, SCM_UNDEFINED);
-}
-#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
-scm_i_program_properties (SCM program)
-#define FUNC_NAME "%program-properties"
-{
- SCM meta;
-
- SCM_VALIDATE_PROGRAM (1, program);
-
- meta = scm_program_meta (program);
- if (scm_is_false (meta))
- return SCM_EOL;
-
- return scm_cdddr (scm_call_0 (meta));
-}
-#undef FUNC_NAME
-
-static SCM
-program_source (SCM program, size_t ip, SCM sources)
-{
- SCM source = SCM_BOOL_F;
-
- while (!scm_is_null (sources)
- && scm_to_size_t (scm_caar (sources)) <= ip)
- {
- source = scm_car (sources);
- sources = scm_cdr (sources);
- }
-
- return source; /* (addr . (filename . (line . column))) */
-}
-
-SCM_DEFINE (scm_program_source, "program-source", 2, 1, 0,
- (SCM program, SCM ip, SCM sources),
- "")
-#define FUNC_NAME s_scm_program_source
-{
- SCM_VALIDATE_PROGRAM (1, program);
- if (SCM_UNBNDP (sources))
- sources = scm_program_sources (program);
- return program_source (program, scm_to_size_t (ip), sources);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_num_free_variables
-{
- SCM_VALIDATE_PROGRAM (1, program);
- return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0,
- (SCM program, SCM i),
- "")
-#define FUNC_NAME s_scm_program_free_variable_ref
-{
- unsigned long idx;
- SCM_VALIDATE_PROGRAM (1, program);
- SCM_VALIDATE_ULONG_COPY (2, i, idx);
- if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
- SCM_OUT_OF_RANGE (2, i);
- return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, 0,
- (SCM program, SCM i, SCM x),
- "")
-#define FUNC_NAME s_scm_program_free_variable_set_x
-{
- unsigned long idx;
- SCM_VALIDATE_PROGRAM (1, program);
- SCM_VALIDATE_ULONG_COPY (2, i, idx);
- if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
- SCM_OUT_OF_RANGE (2, i);
- SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
- (SCM program),
- "Return a @var{program}'s object code.")
-#define FUNC_NAME s_scm_program_objcode
-{
- SCM_VALIDATE_PROGRAM (1, program);
-
- return SCM_PROGRAM_OBJCODE (program);
-}
-#undef FUNC_NAME
-
-/* procedure-minimum-arity support. */
-static void
-parse_arity (SCM arity, int *req, int *opt, int *rest)
-{
- SCM x = scm_cddr (arity);
-
- 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;
-}
-
-int
-scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
-{
- SCM arities;
-
- arities = scm_program_arities (program);
- if (!scm_is_pair (arities))
- return 0;
-
- parse_arity (scm_car (arities), req, opt, rest);
- arities = scm_cdr (arities);
-
- for (; scm_is_pair (arities); arities = scm_cdr (arities))
- {
- int thisreq, thisopt, thisrest;
-
- parse_arity (scm_car (arities), &thisreq, &thisopt, &thisrest);
-
- if (thisreq < *req
- || (thisreq == *req
- && ((thisrest && (!*rest || thisopt > *opt))
- || (!thisrest && !*rest && thisopt > *opt))))
- {
- *req = thisreq;
- *opt = thisopt;
- *rest = thisrest;
- }
- }
-
- return 1;
-}
-
-\f
-
-void
-scm_bootstrap_programs (void)
-{
- scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
- "scm_init_programs",
- (scm_t_extension_init_func)scm_init_programs, NULL);
-}
-
-void
-scm_init_programs (void)
-{
-#ifndef SCM_MAGIC_SNARFER
-#include "libguile/programs.x"
-#endif
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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 <string.h>
+#include "_scm.h"
+#include "modules.h"
+#include "programs.h"
+#include "procprop.h" /* scm_sym_name */
+#include "vm.h"
+
+\f
+static SCM write_program = SCM_BOOL_F;
+
+SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_code
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ return scm_from_uintptr_t ((scm_t_uintptr) SCM_PROGRAM_CODE (program));
+}
+#undef FUNC_NAME
+
+SCM
+scm_i_program_name (SCM program)
+{
+ static SCM program_name = SCM_BOOL_F;
+
+ if (SCM_PRIMITIVE_P (program))
+ return SCM_SUBR_NAME (program);
+
+ if (scm_is_false (program_name) && scm_module_system_booted_p)
+ program_name =
+ scm_c_private_variable ("system vm program", "program-name");
+
+ return scm_call_1 (scm_variable_ref (program_name), program);
+}
+
+SCM
+scm_i_program_documentation (SCM program)
+{
+ static SCM program_documentation = SCM_BOOL_F;
+
+ if (SCM_PRIMITIVE_P (program))
+ return SCM_BOOL_F;
+
+ if (scm_is_false (program_documentation) && scm_module_system_booted_p)
+ program_documentation =
+ scm_c_private_variable ("system vm program", "program-documentation");
+
+ return scm_call_1 (scm_variable_ref (program_documentation), program);
+}
+
+SCM
+scm_i_program_properties (SCM program)
+{
+ static SCM program_properties = SCM_BOOL_F;
+
+ if (SCM_PRIMITIVE_P (program))
+ {
+ SCM name = scm_i_program_name (program);
+ if (scm_is_false (name))
+ return SCM_EOL;
+ return scm_acons (scm_sym_name, name, SCM_EOL);
+ }
+
+ if (scm_is_false (program_properties) && scm_module_system_booted_p)
+ program_properties =
+ scm_c_private_variable ("system vm program", "program-properties");
+
+ return scm_call_1 (scm_variable_ref (program_properties), program);
+}
+
+void
+scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
+{
+ static int print_error = 0;
+
+ if (scm_is_false (write_program) && scm_module_system_booted_p)
+ write_program = scm_c_private_variable ("system vm program",
+ "write-program");
+
+ if (SCM_PROGRAM_IS_CONTINUATION (program))
+ {
+ /* twingliness */
+ scm_puts_unlocked ("#<continuation ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc_unlocked ('>', port);
+ }
+ else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
+ {
+ /* twingliness */
+ scm_puts_unlocked ("#<partial-continuation ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc_unlocked ('>', port);
+ }
+ else if (scm_is_false (write_program) || print_error)
+ {
+ scm_puts_unlocked ("#<program ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc_unlocked (' ', port);
+ scm_uintprint ((scm_t_uintptr) SCM_PROGRAM_CODE (program), 16, port);
+ scm_putc_unlocked ('>', port);
+ }
+ else
+ {
+ print_error = 1;
+ scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
+ print_error = 0;
+ }
+}
+
+\f
+/*
+ * Scheme interface
+ */
+
+SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_program_p
+{
+ return scm_from_bool (SCM_PROGRAM_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_primitive_p, "primitive?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_primitive_p
+{
+ return scm_from_bool (SCM_PRIMITIVE_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
+ (SCM prim),
+ "")
+#define FUNC_NAME s_scm_primitive_p
+{
+ SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
+
+ return scm_from_uintptr_t (scm_i_primitive_call_ip (prim));
+}
+#undef FUNC_NAME
+
+SCM
+scm_find_source_for_addr (SCM ip)
+{
+ static SCM source_for_addr = SCM_BOOL_F;
+
+ if (scm_is_false (source_for_addr)) {
+ if (!scm_module_system_booted_p)
+ return SCM_BOOL_F;
+
+ source_for_addr =
+ scm_c_private_variable ("system vm program", "source-for-addr");
+ }
+
+ return scm_call_1 (scm_variable_ref (source_for_addr), ip);
+}
+
+SCM
+scm_program_address_range (SCM program)
+{
+ static SCM program_address_range = SCM_BOOL_F;
+
+ if (scm_is_false (program_address_range) && scm_module_system_booted_p)
+ program_address_range =
+ scm_c_private_variable ("system vm program", "program-address-range");
+
+ return scm_call_1 (scm_variable_ref (program_address_range), program);
+}
+
+SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_num_free_variables
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0,
+ (SCM program, SCM i),
+ "")
+#define FUNC_NAME s_scm_program_free_variable_ref
+{
+ unsigned long idx;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+ SCM_VALIDATE_ULONG_COPY (2, i, idx);
+ if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
+ SCM_OUT_OF_RANGE (2, i);
+ return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, 0,
+ (SCM program, SCM i, SCM x),
+ "")
+#define FUNC_NAME s_scm_program_free_variable_set_x
+{
+ unsigned long idx;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+ SCM_VALIDATE_ULONG_COPY (2, i, idx);
+ if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
+ SCM_OUT_OF_RANGE (2, i);
+ SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+int
+scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
+{
+ static SCM program_minimum_arity = SCM_BOOL_F;
+ SCM l;
+
+ if (SCM_PRIMITIVE_P (program))
+ return scm_i_primitive_arity (program, req, opt, rest);
+
+ if (SCM_PROGRAM_IS_FOREIGN (program))
+ return scm_i_foreign_arity (program, req, opt, rest);
+
+ if (SCM_PROGRAM_IS_CONTINUATION (program)
+ || SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
+ {
+ *req = *opt = 0;
+ *rest = 1;
+ return 1;
+ }
+
+ if (scm_is_false (program_minimum_arity) && scm_module_system_booted_p)
+ program_minimum_arity =
+ scm_c_private_variable ("system vm program", "program-minimum-arity");
+
+ l = scm_call_1 (scm_variable_ref (program_minimum_arity), program);
+ if (scm_is_false (l))
+ return 0;
+
+ *req = scm_to_int (scm_car (l));
+ *opt = scm_to_int (scm_cadr (l));
+ *rest = scm_is_true (scm_caddr (l));
+
+ return 1;
+}
+
+\f
+
+void
+scm_bootstrap_programs (void)
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_programs",
+ (scm_t_extension_init_func)scm_init_programs, NULL);
+}
+
+void
+scm_init_programs (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/programs.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
-/* Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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_PROGRAMS_H_
#include <libguile.h>
-#include <libguile/objcodes.h>
/*
* Programs
*/
+#define SCM_PROGRAM_P(x) (SCM_HAS_TYP7 (x, scm_tc7_program))
+#define SCM_PROGRAM_CODE(x) ((scm_t_uint32 *) SCM_CELL_WORD_1 (x))
+#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 2))
+#define SCM_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_PROGRAM_FREE_VARIABLES (x)[i])
+#define SCM_PROGRAM_FREE_VARIABLE_SET(x,i,v) (SCM_PROGRAM_FREE_VARIABLES (x)[i]=(v))
+#define SCM_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16)
+#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
+
#define SCM_F_PROGRAM_IS_BOOT 0x100
#define SCM_F_PROGRAM_IS_PRIMITIVE 0x200
#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x400
#define SCM_F_PROGRAM_IS_CONTINUATION 0x800
#define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x1000
+#define SCM_F_PROGRAM_IS_FOREIGN 0x2000
-#define SCM_PROGRAM_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
-#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x))
-#define SCM_PROGRAM_OBJTABLE(x) (SCM_CELL_OBJECT_2 (x))
-#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 3))
-#define SCM_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_PROGRAM_FREE_VARIABLES (x)[i])
-#define SCM_PROGRAM_FREE_VARIABLE_SET(x,i,v) (SCM_PROGRAM_FREE_VARIABLES (x)[i]=(v))
-#define SCM_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16)
-#define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
-#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
#define SCM_PROGRAM_IS_BOOT(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
#define SCM_PROGRAM_IS_PRIMITIVE(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE)
#define SCM_PROGRAM_IS_PRIMITIVE_GENERIC(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC)
#define SCM_PROGRAM_IS_CONTINUATION(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_CONTINUATION)
#define SCM_PROGRAM_IS_PARTIAL_CONTINUATION(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION)
+#define SCM_PROGRAM_IS_FOREIGN(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_FOREIGN)
+
+#ifdef BUILDING_LIBGUILE
+static inline SCM
+scm_i_make_program (const scm_t_uint32 *code)
+{
+ return scm_cell (scm_tc7_program, (scm_t_bits)code);
+}
+#endif
+
+SCM_INTERNAL SCM scm_program_p (SCM obj);
+SCM_INTERNAL SCM scm_program_code (SCM program);
+
+SCM_INTERNAL SCM scm_primitive_p (SCM obj);
+SCM_INTERNAL SCM scm_primitive_call_ip (SCM prim);
+
+SCM_INTERNAL SCM scm_i_program_name (SCM program);
+SCM_INTERNAL SCM scm_i_program_documentation (SCM program);
+SCM_INTERNAL SCM scm_i_program_properties (SCM program);
+
+SCM_INTERNAL SCM scm_find_source_for_addr (SCM ip);
+
+SCM_INTERNAL SCM scm_program_address_range (SCM program);
-SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
-
-SCM_API SCM scm_program_p (SCM obj);
-SCM_API SCM scm_program_base (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 sources);
-SCM_API SCM scm_program_arities (SCM program);
-SCM_API SCM scm_program_objects (SCM program);
-SCM_API SCM scm_program_module (SCM program);
SCM_API SCM scm_program_num_free_variables (SCM program);
SCM_API SCM scm_program_free_variable_ref (SCM program, SCM i);
SCM_API SCM scm_program_free_variable_set_x (SCM program, SCM i, SCM x);
-SCM_API SCM scm_program_objcode (SCM program);
-SCM_INTERNAL SCM scm_i_program_properties (SCM program);
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);
promise_print (SCM exp, SCM port, scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<promise ", port);
+ scm_puts
_unlocked ("#<promise ", port);
SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return !0;
}
#include <pthread.h>
#include <sched.h>
-/* `libgc' defines wrapper procedures for pthread calls. */
-#include "libguile/bdw-gc.h"
-
/* Threads
*/
#define scm_i_pthread_t pthread_t
#define scm_i_pthread_self pthread_self
-#define scm_i_pthread_create GC_pthread_create
-#define scm_i_pthread_detach GC_pthread_detach
+#define scm_i_pthread_create pthread_create
+#define scm_i_pthread_detach pthread_detach
-#if SCM_HAVE_GC_PTHREAD_EXIT
-#define scm_i_pthread_exit GC_pthread_exit
-#else
#define scm_i_pthread_exit pthread_exit
-#endif
-
-#if SCM_HAVE_GC_PTHREAD_CANCEL
-#define scm_i_pthread_cancel GC_pthread_cancel
-#else
#define scm_i_pthread_cancel pthread_cancel
-#endif
#define scm_i_pthread_cleanup_push pthread_cleanup_push
#define scm_i_pthread_cleanup_pop pthread_cleanup_pop
/* Signals
*/
-#if SCM_HAVE_GC_PTHREAD_SIGMASK
-#define scm_i_pthread_sigmask GC_pthread_sigmask
-#else
#define scm_i_pthread_sigmask pthread_sigmask
-#endif
/* Mutexes
*/
scm_t_port *c_port;
const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ port = scm_c_make_port_with_encoding (bytevector_input_port_type,
+ mode_bits,
+ NULL, /* encoding */
+ SCM_FAILED_CONVERSION_ERROR,
+ SCM_UNPACK (bv));
- port = scm_new_port_table_entry (bytevector_input_port_type);
c_port = SCM_PTAB_ENTRY (port);
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
- /* Prevent BV from being GC'd. */
- SCM_SETSTREAM (port, SCM_UNPACK (bv));
-
/* Have the port directly access the bytevector. */
c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
c_len = SCM_BYTEVECTOR_LENGTH (bv);
c_port->read_end = (unsigned char *) c_bv + c_len;
c_port->read_buf_size = c_len;
- /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
- SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
return port;
}
SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+ port = scm_c_make_port_with_encoding (custom_binary_input_port_type,
+ mode_bits,
+ NULL, /* encoding */
+ SCM_FAILED_CONVERSION_ERROR,
+ SCM_UNPACK (method_vector));
- port = scm_new_port_table_entry (custom_binary_input_port_type);
c_port = SCM_PTAB_ENTRY (port);
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
- /* Attach it the method vector. */
- SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
-
/* Have the port directly access the buffer (bytevector). */
c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
c_port->read_end = (unsigned char *) c_bv;
c_port->read_buf_size = c_len;
- /* 'setvbuf' is supported. */
- SCM_PORT_GET_INTERNAL (port)->setvbuf = cbip_setvbuf;
-
- /* Mark PORT as open and readable. */
- SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
return port;
}
scm_set_port_seek (custom_binary_input_port_type, cbp_seek);
scm_set_port_close (custom_binary_input_port_type, cbp_close);
+ scm_set_port_setvbuf (custom_binary_input_port_type, cbip_setvbuf);
}
if (SCM_LIKELY (c_count > 0))
/* XXX: `scm_c_read ()' does not update the port position. */
- c_read = scm_c_read (port, c_bv, c_count);
+ c_read = scm_c_read_unlocked (port, c_bv, c_count);
else
/* Don't invoke `scm_c_read ()' since it may block. */
c_read = 0;
scm_out_of_range (FUNC_NAME, count);
if (SCM_LIKELY (c_count > 0))
- c_read = scm_c_read (port, c_bv + c_start, c_count);
+ c_read = scm_c_read_unlocked (port, c_bv + c_start, c_count);
else
/* Don't invoke `scm_c_read ()' since it may block. */
c_read = 0;
pt = SCM_PTAB_ENTRY (port);
if (pt->rw_active == SCM_PORT_WRITE)
- scm_ptobs[SCM_PTOBNUM (port)].flush (port);
+ scm_flush_unlocked (port);
if (pt->rw_random)
pt->rw_active = SCM_PORT_READ;
if (pt->read_pos >= pt->read_end)
{
- if (scm_fill_input (port) == EOF)
+ if (scm_fill_input_unlocked (port) == EOF)
return SCM_EOF_VAL;
}
/* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
reached. */
- c_read = scm_c_read (port, c_bv + c_total, c_count);
+ c_read = scm_c_read_unlocked (port, c_bv + c_total, c_count);
c_total += c_read, c_count -= c_read;
}
while (c_count == 0);
c_len = (unsigned) c_total;
}
- result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len);
+ result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len,
+ SCM_BOOL_F);
}
return result;
SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
c_octet = scm_to_uint8 (octet);
- scm_putc ((char) c_octet, port);
+ scm_putc_unlocked ((char) c_octet, port);
return SCM_UNSPECIFIED;
}
else
c_start = 0, c_count = c_len;
- scm_c_write (port, c_bv + c_start, c_count);
+ scm_c_write_unlocked (port, c_bv + c_start, c_count);
return SCM_UNSPECIFIED;
}
scm_t_bop_buffer *buf;
const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- port = scm_new_port_table_entry (bytevector_output_port_type);
- c_port = SCM_PTAB_ENTRY (port);
-
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
bop_buffer_init (buf);
- c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
- c_port->write_buf_size = 0;
-
- SCM_SET_BOP_BUFFER (port, buf);
+ port = scm_c_make_port_with_encoding (bytevector_output_port_type,
+ mode_bits,
+ NULL, /* encoding */
+ SCM_FAILED_CONVERSION_ERROR,
+ (scm_t_bits)buf);
- /* Mark PORT as open and writable. */
- SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
+ c_port = SCM_PTAB_ENTRY (port);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = 0;
/* Make the bop procedure. */
SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf);
bop_buffer_init (buf);
if (result_buf.len == 0)
- bv = scm_c_take_gc_bytevector (NULL, 0);
+ bv = scm_c_take_gc_bytevector (NULL, 0, SCM_BOOL_F);
else
{
if (result_buf.total_len > result_buf.len)
SCM_GC_BOP);
bv = scm_c_take_gc_bytevector ((signed char *) result_buf.buffer,
- result_buf.len);
+ result_buf.len, SCM_BOOL_F);
}
return bv;
SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+ port = scm_c_make_port_with_encoding (custom_binary_output_port_type,
+ mode_bits,
+ NULL, /* encoding */
+ SCM_FAILED_CONVERSION_ERROR,
+ SCM_UNPACK (method_vector));
- port = scm_new_port_table_entry (custom_binary_output_port_type);
c_port = SCM_PTAB_ENTRY (port);
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
- /* Attach it the method vector. */
- SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
-
/* Have the port directly access the buffer (bytevector). */
c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
c_port->write_buf_size = c_port->read_buf_size = 0;
- /* Mark PORT as open, writable and unbuffered. */
- SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
return port;
}
scm_t_port *c_port;
const unsigned long mode_bits = SCM_OPN | mode;
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- port = scm_new_port_table_entry (transcoded_port_type);
-
- SCM_SETSTREAM (port, SCM_UNPACK (binary_port));
-
- SCM_SET_CELL_TYPE (port, transcoded_port_type | mode_bits);
+ port = scm_c_make_port (transcoded_port_type, mode_bits,
+ SCM_UNPACK (binary_port));
if (SCM_INPUT_PORT_P (port))
{
SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
}
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
return port;
}
static void
tp_write (SCM port, const void *data, size_t size)
{
- scm_c_write (SCM_TP_BINARY_PORT (port), data, size);
+ scm_c_write_unlocked (SCM_TP_BINARY_PORT (port), data, size);
}
static int
scm_force_output (bport);
if (c_bport->read_pos >= c_bport->read_end)
- scm_fill_input (bport);
+ scm_fill_input_unlocked (bport);
count = c_bport->read_end - c_bport->read_pos;
if (count > c_port->read_buf_size)
We just throw away the data when the underlying port is closed. */
if (SCM_OPOUTPORTP (binary_port))
- scm_c_write (binary_port, c_port->write_buf, count);
+ scm_c_write_unlocked (binary_port, c_port->write_buf, count);
c_port->write_pos = c_port->write_buf;
c_port->rw_active = SCM_PORT_NEITHER;
scm_set_port_close (transcoded_port_type, tp_close);
}
+SCM_INTERNAL SCM scm_i_make_transcoded_port (SCM);
+
SCM_DEFINE (scm_i_make_transcoded_port,
"%make-transcoded-port", 1, 0, 0,
(SCM port),
for (j = c_start; j < c_end; j++)
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if (c == EOF)
{
size_t chars_read = j - c_start;
#ifndef SCM_R6RS_PORTS_H
#define SCM_R6RS_PORTS_H
-/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011, 2013 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_get_bytevector_n_x (SCM, SCM, SCM, SCM);
SCM_API SCM scm_get_bytevector_some (SCM);
SCM_API SCM scm_get_bytevector_all (SCM);
+SCM_API SCM scm_unget_bytevector (SCM, SCM, SCM, SCM);
SCM_API SCM scm_put_u8 (SCM, SCM);
SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM);
SCM_API SCM scm_open_bytevector_output_port (SCM);
vector_scale_x (SCM v, double c)
{
size_t n;
- if (scm_is_simple_vector (v))
+ if (scm_is_vector (v))
{
n = SCM_SIMPLE_VECTOR_LENGTH (v);
while (n-- > 0)
{
double x, sum = 0.0;
size_t n;
- if (scm_is_simple_vector (v))
+ if (scm_is_vector (v))
{
n = SCM_SIMPLE_VECTOR_LENGTH (v);
while (n-- > 0)
scm_random_normal_vector_x (v, state);
vector_scale_x (v,
pow (scm_c_uniform01 (SCM_RSTATE (state)),
- 1.0 / scm_c_generalized_vector_length (v))
+ 1.0 / scm_c_array_length (v))
/ sqrt (vector_sum_squares (v)));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0,
+SCM_DEFINE (scm_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0,
(SCM v, SCM state),
"Fills vect with inexact real random numbers\n"
"the sum of whose squares is equal to 1.0.\n"
scm_generalized_vector_get_handle (v, &handle);
dim = scm_array_handle_dims (&handle);
- if (scm_is_vector (v))
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
{
SCM *elts = scm_array_handle_writable_elements (&handle);
for (i = dim->lbnd; i <= dim->ubnd; i++, elts += dim->inc)
{
size_t k;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
for (k = 0; k < num_delims; k++)
{
if (scm_i_string_ref (delims, k) == c)
{
if (scm_is_false (gobble))
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return scm_cons (SCM_MAKE_CHAR (c),
scm_from_size_t (j - cstart));
}
else
{
- buf[index] = scm_getc (port);
+ buf[index] = scm_getc_unlocked (port);
switch (buf[index])
{
case EOF:
#endif
#include <stdio.h>
-#include <ctype.h>
#include <string.h>
#include <unistd.h>
#include <unicase.h>
#include "libguile/hashtab.h"
#include "libguile/hash.h"
#include "libguile/ports.h"
+#include "libguile/ports-internal.h"
#include "libguile/fports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
{
int chr;
- chr = scm_get_byte_or_eof (port);
+ chr = scm_get_byte_or_eof_unlocked (port);
if (chr == EOF)
return 0;
else if (CHAR_IS_DELIMITER (chr))
{
- scm_unget_byte (chr, port);
+ scm_unget_byte_unlocked (chr, port);
return 0;
}
else
{
scm_t_wchar c;
while (1)
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goteof:
case ';':
lp:
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goto goteof;
break;
case '#':
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
eoferr = "read_sharp";
}
/* fall through */
default:
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return '#';
}
break;
maybe_annotate_source (SCM x, SCM port, scm_t_read_opts *opts,
long line, int column)
{
+ /* This condition can be caused by a user calling
+ set-port-column!. */
+ if (line < 0 || column < 0)
+ return x;
+
if (opts->record_positions_p)
scm_i_set_source_properties_x (x, line, column, SCM_FILENAME (port));
return x;
if (terminating_char == c)
return SCM_EOL;
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
tmp = scm_read_expression (port, opts);
/* Note that it is possible for scm_read_expression to return
"in pair: mismatched close paren: ~A",
scm_list_1 (SCM_MAKE_CHAR (c)));
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
tmp = scm_read_expression (port, opts);
/* See above note about scm_sym_dot. */
c = 0; \
while (i < ndigits) \
{ \
- a = scm_getc (port); \
+ a = scm_getc_unlocked (port); \
if (a == EOF) \
goto str_eof; \
if (terminator \
do
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if (c == EOF)
return;
}
while (c == '\t' || uc_is_general_category (c, UC_SPACE_SEPARATOR));
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
}
/* Read either a double-quoted string or an R7RS-style symbol delimited
long line = SCM_LINUM (port);
int column = SCM_COL (port) - 1;
- while (chr != (c = scm_getc (port)))
+ while (chr != (c = scm_getc_unlocked (port)))
{
if (c == EOF)
{
if (c == '\\')
{
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goto str_eof;
SCM result, str = SCM_EOL;
char local_buffer[READER_BUFFER_SIZE], *buffer;
size_t bytes_read;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
/* Need to capture line and column numbers here. */
long line = SCM_LINUM (port);
int column = SCM_COL (port) - 1;
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
&bytes_read);
- str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler);
+ str = scm_from_port_stringn (buffer, bytes_read, port);
result = scm_string_to_number (str, SCM_UNDEFINED);
if (scm_is_false (result))
size_t bytes_read;
int postfix = (opts->keyword_style == KEYWORD_STYLE_POSTFIX);
char local_buffer[READER_BUFFER_SIZE], *buffer;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM str;
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
&bytes_read);
if (bytes_read > 0)
if (postfix && ends_with_colon && (bytes_read > 1))
{
- str = scm_from_stringn (buffer, bytes_read - 1,
- pt->encoding, pt->ilseq_handler);
+ str = scm_from_port_stringn (buffer, bytes_read - 1, port);
if (opts->case_insensitive_p)
str = scm_string_downcase_x (str);
}
else
{
- str = scm_from_stringn (buffer, bytes_read,
- pt->encoding, pt->ilseq_handler);
+ str = scm_from_port_stringn (buffer, bytes_read, port);
if (opts->case_insensitive_p)
str = scm_string_downcase_x (str);
char local_buffer[READER_BUFFER_SIZE], *buffer;
unsigned int radix;
SCM str;
- scm_t_port *pt;
switch (chr)
{
break;
default:
- scm_ungetc (chr, port);
- scm_ungetc ('#', port);
+ scm_ungetc_unlocked (chr, port);
+ scm_ungetc_unlocked ('#', port);
radix = 10;
}
buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
&read);
- pt = SCM_PTAB_ENTRY (port);
- str = scm_from_stringn (buffer, read, pt->encoding, pt->ilseq_handler);
+ str = scm_from_port_stringn (buffer, read, port);
result = scm_string_to_number (str, scm_from_uint (radix));
{
scm_t_wchar c;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if ('@' == c)
p = scm_sym_uq_splicing;
else
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
p = scm_sym_unquote;
}
break;
{
int c;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if ('@' == c)
p = sym_unsyntax_splicing;
else
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
p = sym_unsyntax;
}
break;
/* We use the get_byte here because there is no need to get the
locale correct with comment input. This presumes that newline
always represents itself no matter what the encoding is. */
- for (c = scm_get_byte_or_eof (port);
+ for (c = scm_get_byte_or_eof_unlocked (port);
(c != EOF) && (c != '\n');
- c = scm_get_byte_or_eof (port));
+ c = scm_get_byte_or_eof_unlocked (port));
return SCM_UNSPECIFIED;
}
while (num_chars_read < num_chars_wanted)
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if (c == EOF)
break;
else if (c_tolower (c) != expected_chars[num_chars_read])
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
break;
}
else
else
{
while (num_chars_read > 0)
- scm_ungetc (chars_read[--num_chars_read], port);
+ scm_ungetc_unlocked (chars_read[--num_chars_read], port);
return 0;
}
}
size_t charname_len, bytes_read;
scm_t_wchar cp;
int overflow;
- scm_t_port *pt;
+ scm_t_port_internal *pti;
overflow = read_token (port, opts, buffer, READER_CHAR_NAME_MAX_SIZE,
&bytes_read);
if (bytes_read == 0)
{
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr == EOF)
scm_i_input_error (FUNC_NAME, port, "unexpected end of file "
"while reading character", SCM_EOL);
return (SCM_MAKE_CHAR (chr));
}
- pt = SCM_PTAB_ENTRY (port);
+ pti = SCM_PORT_GET_INTERNAL (port);
/* Simple ASCII characters can be processed immediately. Also, simple
ISO-8859-1 characters can be processed immediately if the encoding for this
port is ISO-8859-1. */
- if (bytes_read == 1 && ((unsigned char) buffer[0] <= 127 || pt->encoding == NULL))
+ if (bytes_read == 1 &&
+ ((unsigned char) buffer[0] <= 127
+ || pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1))
{
SCM_COL (port) += 1;
return SCM_MAKE_CHAR (buffer[0]);
/* Otherwise, convert the buffer into a proper scheme string for
processing. */
- charname = scm_from_stringn (buffer, bytes_read, pt->encoding,
- pt->ilseq_handler);
+ charname = scm_from_port_stringn (buffer, bytes_read, port);
charname_len = scm_i_string_length (charname);
SCM_COL (port) += charname_len;
cp = scm_i_string_ref (charname, 0);
if (c == '-')
{
sign = -1;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
}
while ('0' <= c && c <= '9')
"number too large", SCM_EOL);
res = 10*res + c-'0';
got_it = 1;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
}
if (got_it)
/* Disambiguate between '#f' and uniform floating point vectors. */
if (c == 'f')
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if (c != '3' && c != '6')
{
if (c == 'a' && try_read_ci_chars (port, "lse"))
return SCM_BOOL_F;
else if (c != EOF)
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return SCM_BOOL_F;
}
rank = 1;
&& tag_len < sizeof tag_buf / sizeof tag_buf[0])
{
tag_buf[tag_len++] = c;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
}
if (tag_len == 0)
tag = SCM_BOOL_T;
if (c == '@')
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
c = read_decimal_integer (port, c, &lbnd);
}
if (c == ':')
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
c = read_decimal_integer (port, c, &len);
if (len < 0)
scm_i_input_error (NULL, port,
scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
long line, int column)
{
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr != 'u')
goto syntax;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr != '8')
goto syntax;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr != '(')
goto syntax;
terribly inefficient but who cares? */
SCM s_bits = SCM_EOL;
- for (chr = scm_getc (port);
+ for (chr = scm_getc_unlocked (port);
(chr != EOF) && ((chr == '0') || (chr == '1'));
- chr = scm_getc (port))
+ chr = scm_getc_unlocked (port))
{
s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits);
}
if (chr != EOF)
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
return maybe_annotate_source
(scm_bitvector (scm_reverse_x (s_bits, SCM_EOL)),
for (;;)
{
- int c = scm_getc (port);
+ int c = scm_getc_unlocked (port);
if (c == EOF)
scm_i_input_error ("skip_block_comment", port,
while (i <= READER_DIRECTIVE_NAME_MAX_SIZE)
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if (c == EOF)
scm_i_input_error ("skip_block_comment", port,
"unterminated `#! ... !#' comment", SCM_EOL);
name[i++] = c;
else if (CHAR_IS_DELIMITER (c))
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
name[i] = '\0';
if (0 == strcmp ("r6rs", name))
; /* Silently ignore */
}
else
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
break;
}
}
while (i > 0)
- scm_ungetc (name[--i], port);
+ scm_ungetc_unlocked (name[--i], port);
return scm_read_scsh_block_comment (chr, port);
}
nested. So care must be taken. */
int nesting_level = 1;
- int a = scm_getc (port);
+ int a = scm_getc_unlocked (port);
if (a == EOF)
scm_i_input_error ("scm_read_r6rs_block_comment", port,
while (nesting_level > 0)
{
- int b = scm_getc (port);
+ int b = scm_getc_unlocked (port);
if (b == EOF)
scm_i_input_error ("scm_read_r6rs_block_comment", port,
if (EOF == c)
scm_i_input_error ("read_commented_expression", port,
"no expression after #; comment", SCM_EOL);
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
scm_read_expression (port, opts);
return SCM_UNSPECIFIED;
}
buf = scm_i_string_start_writing (buf);
- while ((chr = scm_getc (port)) != EOF)
+ while ((chr = scm_getc_unlocked (port)) != EOF)
{
if (saw_brace)
{
that the extended read syntax would never put a `\' before
an `x'. For now, we just ignore other instances of
backslash in the string. */
- switch ((chr = scm_getc (port)))
+ switch ((chr = scm_getc_unlocked (port)))
{
case EOF:
goto done;
{
SCM result;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
result = scm_read_sharp_extension (chr, port, opts);
if (!scm_is_eq (result, SCM_UNSPECIFIED))
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
case '@':
-#if SCM_ENABLE_DEPRECATED
- /* See below for 'i' and 'e'. */
- case 'a':
- case 'y':
- case 'h':
- case 'l':
-#endif
return (scm_read_array (chr, port, opts, line, column));
case 'i':
case 'e':
-#if SCM_ENABLE_DEPRECATED
- {
- /* When next char is '(', it really is an old-style
- uniform array. */
- scm_t_wchar next_c = scm_getc (port);
- if (next_c != EOF)
- scm_ungetc (next_c, port);
- if (next_c == '(')
- return scm_read_array (chr, port, opts, line, column);
- /* Fall through. */
- }
-#endif
case 'b':
case 'B':
case 'o':
{
scm_t_wchar chr;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
switch (chr)
{
int c = flush_ws (port, opts, (char *) NULL);
if (c == EOF)
return SCM_EOF_VAL;
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
line = SCM_LINUM (port);
column = SCM_COL (port);
}
new expression. For example, f{n - 1}(x) => ((f (- n 1)) x). */
for (;;)
{
- int chr = scm_getc (port);
+ int chr = scm_getc_unlocked (port);
if (chr == '(')
/* e(...) => (e ...) */
else
{
if (chr != EOF)
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
break;
}
maybe_annotate_source (expr, port, opts, line, column);
c = flush_ws (port, &opts, (char *) NULL);
if (EOF == c)
return SCM_EOF_VAL;
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return (scm_read_expression (port, &opts));
}
}
}
+static int
+is_encoding_char (char c)
+{
+ if (c >= 'a' && c <= 'z') return 1;
+ if (c >= 'A' && c <= 'Z') return 1;
+ if (c >= '0' && c <= '9') return 1;
+ return strchr ("_-.:/,+=()", c) != NULL;
+}
+
/* Maximum size of an encoding name. This is a bit more than the
longest name listed at
<http://www.iana.org/assignments/character-sets> ("ISO-2022-JP-2", 13
pt = SCM_PTAB_ENTRY (port);
if (pt->rw_active == SCM_PORT_WRITE)
- scm_flush (port);
+ scm_flush_unlocked (port);
if (pt->rw_random)
pt->rw_active = SCM_PORT_READ;
if (pt->read_pos == pt->read_end)
{
/* We can use the read buffer, and thus avoid a seek. */
- if (scm_fill_input (port) == EOF)
+ if (scm_fill_input_unlocked (port) == EOF)
return NULL;
bytes_read = pt->read_end - pt->read_pos;
if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port)))
return NULL;
- bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);
+ bytes_read = scm_c_read_unlocked (port, header, SCM_ENCODING_SEARCH_SIZE);
header[bytes_read] = '\0';
scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
}
i = 0;
while (encoding_start + i - header <= SCM_ENCODING_SEARCH_SIZE
&& encoding_start + i - header < bytes_read
- && (isalnum ((int) encoding_start[i])
- || strchr ("_-.:/,+=()", encoding_start[i]) != NULL))
+ && is_encoding_char (encoding_start[i]))
i++;
encoding_length = i;
return NULL;
encoding = scm_gc_strndup (encoding_start, encoding_length, "encoding");
- for (i = 0; i < encoding_length; i++)
- encoding[i] = toupper ((int) encoding[i]);
/* push backwards to make sure we were in a comment */
in_comment = 0;
return SCM_BOOL_F;
else
{
- s_enc = scm_from_locale_string (enc);
+ s_enc = scm_string_upcase (scm_from_locale_string (enc));
return s_enc;
}
unsigned int read_options;
new_value &= READ_OPTION_MASK;
+
+ scm_dynwind_begin (0);
+ scm_dynwind_lock_port (port);
+
scm_read_options = scm_i_port_property (port, sym_port_read_options);
if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
read_options = scm_to_uint (scm_read_options);
read_options |= new_value << option;
scm_read_options = scm_from_uint (read_options);
scm_i_set_port_property_x (port, sym_port_read_options, scm_read_options);
+
+ scm_dynwind_end ();
}
/* Set OPTS and PORT's case-insensitivity according to VALUE. */
-/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008, 2009, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
SCM_STACKITEM *stack_start)
{
struct cwdr_handler_data my_handler_data;
- SCM answer, old_winds;
+ scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
+ SCM answer;
+ scm_t_dynstack *old_dynstack;
/* Exit caller's dynamic state.
*/
- old_winds = scm_i_dynwinds ();
- scm_dowinds (SCM_EOL, scm_ilength (old_winds));
+ old_dynstack = scm_dynstack_capture_all (dynstack);
+ scm_dynstack_unwind (dynstack, SCM_DYNSTACK_FIRST (dynstack));
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_dynwind_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED));
/* Enter caller's dynamic state.
*/
- scm_dowinds (old_winds, - scm_ilength (old_winds));
+ scm_dynstack_wind (dynstack, SCM_DYNSTACK_FIRST (old_dynstack));
/* Now run the real handler iff the body did a throw. */
if (my_handler_data.run_handler)
-/* Copyright (C) 2001, 2006, 2009, 2014 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 2009, 2011, 2014 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_from_long (write_len);
}
if (pt->write_pos > pt->write_buf)
- scm_flush (port);
+ scm_flush_unlocked (port);
fdes = SCM_FPORT_FDES (port);
}
{
#if HAVE_PTHREAD_SIGMASK /* not on mingw, see notes above */
sigset_t all_sigs;
sigfillset (&all_sigs);
+ /* On libgc 7.1 and earlier, GC_do_blocking doesn't actually do
+ anything. So in that case, libgc will want to suspend the signal
+ delivery thread, so we need to allow it to do so by unmasking the
+ suspend signal. */
+ sigdelset (&all_sigs, GC_get_suspend_signal ());
scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
#endif
#undef FUNC_NAME
#endif /* HAVE_ALARM */
+static void
+pack_tv (struct timeval *tv, SCM seconds, SCM microseconds)
+{
+ tv->tv_sec = scm_to_long (seconds);
+ tv->tv_usec = scm_to_long (microseconds);
+
+ /* Allow usec to be outside the range [0, 999999). */
+ tv->tv_sec += tv->tv_usec / (1000 * 1000);
+ tv->tv_usec %= 1000 * 1000;
+}
+
+static SCM
+unpack_tv (const struct timeval *tv)
+{
+ return scm_cons (scm_from_long (tv->tv_sec), scm_from_long (tv->tv_usec));
+}
+
#ifdef HAVE_SETITIMER
SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0,
(SCM which_timer,
struct itimerval old_timer;
c_which_timer = SCM_NUM2INT(1, which_timer);
- new_timer.it_interval.tv_sec = SCM_NUM2LONG(2, interval_seconds);
- new_timer.it_interval.tv_usec = SCM_NUM2LONG(3, interval_microseconds);
- new_timer.it_value.tv_sec = SCM_NUM2LONG(4, value_seconds);
- new_timer.it_value.tv_usec = SCM_NUM2LONG(5, value_microseconds);
+ pack_tv (&new_timer.it_interval, interval_seconds, interval_microseconds);
+ pack_tv (&new_timer.it_value, value_seconds, value_microseconds);
SCM_SYSCALL(rv = setitimer(c_which_timer, &new_timer, &old_timer));
if(rv != 0)
SCM_SYSERROR;
- return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
- scm_from_long (old_timer.it_interval.tv_usec)),
- scm_cons (scm_from_long (old_timer.it_value.tv_sec),
- scm_from_long (old_timer.it_value.tv_usec)));
+ return scm_list_2 (unpack_tv (&old_timer.it_interval),
+ unpack_tv (&old_timer.it_value));
}
#undef FUNC_NAME
#endif /* HAVE_SETITIMER */
-/* Copyright (C) 1994-1998, 2000-2011, 2014 Free Software Foundation, Inc.
+/* Copyright (C) 1994-1998, 2000-2011, 2013, 2014 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 "libguile/eval.h"
#include "libguile/feature.h"
#include "libguile/load.h"
-#include "libguile/private-gc.h" /* scm_getenv_int */
#include "libguile/read.h"
#include "libguile/script.h"
#include "libguile/strings.h"
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, 2009,
- * 2010, 2012, 2014 Free Software Foundation, Inc.
+ * 2010, 2012, 2013, 2014 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
+/* Get an integer from an environment variable. */
+int
+scm_getenv_int (const char *var, int def)
+{
+ char *end = 0;
+ char *val = getenv (var);
+ long res = def;
+ if (!val)
+ return def;
+ res = strtol (val, &end, 10);
+ if (end == val)
+ return def;
+ return res;
+}
+
/* simple exit, without unwinding the scheme stack or flushing ports. */
SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0,
(SCM status),
#ifndef SCM_SIMPOS_H
#define SCM_SIMPOS_H
-/* Copyright (C) 1995,1996,1997,1998,2000, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000, 2006, 2008, 2013 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_getenv (SCM nam);
SCM_API SCM scm_primitive_exit (SCM status);
SCM_API SCM scm_primitive__exit (SCM status);
+SCM_INTERNAL int scm_getenv_int (const char *var, int def);
SCM_INTERNAL void scm_init_simpos (void);
#endif /* SCM_SIMPOS_H */
#include "libguile/async.h"
#include "libguile/goops.h"
#include "libguile/instructions.h"
-#include "libguile/objcodes.h"
#include "libguile/programs.h"
#include "libguile/smob.h"
scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
long n = SCM_SMOBNUM (exp);
- scm_puts ("#<", port);
- scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
- scm_putc (' ', port);
+ scm_puts_unlocked ("#<", port);
+ scm_puts_unlocked (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
+ scm_putc_unlocked (' ', port);
if (scm_smobs[n].size)
scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
else
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
{
long new_smob;
- SCM_CRITICAL_SECTION_START;
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
new_smob = scm_numsmob;
if (scm_numsmob != MAX_SMOB_COUNT)
++scm_numsmob;
- SCM_CRITICAL_SECTION_END;
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
if (new_smob == MAX_SMOB_COUNT)
scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
SCM trampoline = scm_smob_trampoline (req, opt, rst);
scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
- /* In 2.2 this field is renamed to "apply_trampoline". */
- scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline_objcode = trampoline;
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply_trampoline = trampoline;
if (SCM_UNPACK (scm_smob_class[0]) != 0)
scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
register SCM cell;
register scm_t_bits tc, smobnum;
- cell = PTR2SCM (addr);
+ cell = SCM_PACK_POINTER (addr);
if (SCM_TYP7 (cell) != scm_tc7_smob)
/* It is likely that the GC passed us a pointer to a free-list element
mark_stack_ptr = scm_i_pthread_getspecific (current_mark_stack_pointer);
- if (SCM_NIMP (obj))
+ if (SCM_HEAP_OBJECT_P (obj))
/* Mark the returned object. */
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
mark_stack_ptr,
void
scm_gc_mark (SCM o)
{
- if (SCM_NIMP (o))
+ if (SCM_HEAP_OBJECT_P (o))
{
void *mark_stack_ptr, *mark_stack_limit;
SCM smob;
size_t (* free_smob) (SCM);
- smob = PTR2SCM (ptr);
+ smob = SCM_PACK_POINTER (ptr);
#if 0
printf ("finalizing SMOB %p (smobnum: %u)\n",
ptr, SCM_SMOBNUM (smob));
allocates a double cell. We leave words 2 and 3 to there initial
values, which is 0. */
if (scm_smobs [smobnum].mark)
- ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
+ ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
else
- ret = PTR2SCM (GC_MALLOC (sizeof (scm_t_cell)));
+ ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell)));
SCM_SET_CELL_WORD_1 (ret, data);
SCM_SET_CELL_WORD_0 (ret, tc);
/* Use the smob_gc_kind if needed to allow the mark procedure to
run. */
if (scm_smobs [smobnum].mark)
- ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
+ ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
else
- ret = PTR2SCM (GC_MALLOC (2 * sizeof (scm_t_cell)));
+ ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell)));
SCM_SET_CELL_WORD_3 (ret, data3);
SCM_SET_CELL_WORD_2 (ret, data2);
return ret;
}
-
-\f
-
-/* These two are internal details of the previous implementation of
- SCM_NEWSMOB and are no longer used. They are still here to preserve
- ABI stability in the 2.0 series. */
-void
-scm_i_finalize_smob (void *ptr, void *data)
-{
- finalize_smob (ptr, data);
-}
-
-SCM
-scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits word1,
- scm_t_bits word2, scm_t_bits word3)
-{
- return scm_new_double_smob (tc, word1, word2, word3);
-}
-
-
\f
void
scm_smob_prehistory ()
scm_smobs[i].print = scm_smob_print;
scm_smobs[i].equalp = 0;
scm_smobs[i].apply = 0;
- scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
+ scm_smobs[i].apply_trampoline = SCM_BOOL_F;
}
}
int (*print) (SCM exp, SCM port, scm_print_state *pstate);
SCM (*equalp) (SCM, SCM);
scm_t_subr apply;
- /* In 2.2 this field is renamed to "apply_trampoline". */
- SCM apply_trampoline_objcode;
+ SCM apply_trampoline;
} scm_smob_descriptor;
#define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CELL_TYPE (x)))
/* SCM_SMOBNAME can be 0 if name is missing */
#define SCM_SMOBNAME(smobnum) (scm_smobs[smobnum].name)
-#define SCM_SMOB_PREDICATE(tag, obj) SCM_TYP16_PREDICATE (tag, obj)
+#define SCM_SMOB_PREDICATE(tag, obj) SCM_HAS_TYP16 (obj, tag)
#define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)])
#define SCM_SMOB_APPLICABLE_P(x) (SCM_SMOB_DESCRIPTOR (x).apply)
SCM_INLINE SCM scm_new_double_smob (scm_t_bits tc, scm_t_bits,
scm_t_bits, scm_t_bits);
-/* These two are internal details of the previous implementation of
- SCM_NEWSMOB and are no longer used. They are still here to preserve
- ABI stability in the 2.0 series. */
-SCM_API void scm_i_finalize_smob (void *ptr, void *data);
-SCM_API SCM scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits,
- scm_t_bits, scm_t_bits);
-
-
#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
SCM_INLINE_IMPLEMENTATION SCM
scm_new_smob (scm_t_bits tc, scm_t_bits data)
#define SCM_SNARF_H
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
+ * 2004, 2006, 2009, 2010, 2011, 2013, 2014 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_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
-#ifdef SCM_SUPPORT_STATIC_ALLOCATION
-
-/* Static subr allocation. */
-/* FIXME: how to verify that req + opt + rest < 11, all are positive, etc? */
-#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
-SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME); \
-SCM_SNARF_HERE( \
- SCM_UNUSED static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \
- SCM_API SCM FNAME ARGLIST; \
- SCM_IMMUTABLE_POINTER (scm_i_paste (FNAME, __subr_foreign), \
- (scm_t_bits) &FNAME); /* the subr */ \
- SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \
- /* FIXME: directly be the foreign */ \
- SCM_BOOL_F); \
- /* FIXME: be immutable. grr */ \
- SCM_STATIC_PROGRAM (scm_i_paste (FNAME, __subr), \
- SCM_BOOL_F, \
- SCM_PACK (&scm_i_paste (FNAME, __raw_objtable)), \
- SCM_BOOL_F); \
- SCM FNAME ARGLIST \
-) \
-SCM_SNARF_INIT( \
- /* Initialize the foreign. */ \
- scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __subr_foreign); \
- /* Initialize the procedure name (an interned symbol). */ \
- scm_i_paste (FNAME, __raw_objtable)[3] = scm_i_paste (FNAME, __name); \
- /* Initialize the objcode trampoline. */ \
- SCM_SET_CELL_OBJECT (scm_i_paste (FNAME, __subr), 1, \
- scm_subr_objcode_trampoline (REQ, OPT, VAR)); \
- \
- /* Define the subr. */ \
- scm_define (scm_i_paste (FNAME, __name), 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(\
# 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))
+SCM_SNARF_INIT(c_name = scm_from_utf8_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))
+SCM_SNARF_INIT(c_name = scm_from_utf8_symbol (scheme_name))
#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
#define SCM_IMMUTABLE_POINTER(c_name, ptr) \
SCM_IMMUTABLE_CELL (c_name, scm_tc7_pointer, ptr)
-/* for primitive-generics, add a foreign to the end */
-#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
- static SCM_ALIGNED (8) SCM c_name[4] = \
- { \
- SCM_PACK (scm_tc7_vector | (2 << 8)), \
- SCM_PACK (0), \
- foreign, \
- SCM_BOOL_F, /* the name */ \
- }
-
-#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
- static SCM_ALIGNED (8) SCM_UNUSED SCM \
- scm_i_paste (c_name, _raw_cell)[] = \
- { \
- SCM_PACK (scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE), \
- objcode, \
- objtable, \
- freevars \
- }; \
- static SCM_UNUSED const SCM c_name = \
- SCM_PACK (& scm_i_paste (c_name, _raw_cell))
-
#endif /* SCM_SUPPORT_STATIC_ALLOCATION */
\f
flg = scm_to_int (flags);
fd = SCM_FPORT_FDES (sock);
-#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_UNLIKELY (scm_is_string (buf)))
- {
- SCM msg;
- char *dest;
- size_t len;
-
- scm_c_issue_deprecation_warning
- ("Passing a string to `recv!' is deprecated, "
- "use a bytevector instead.");
-
- len = scm_i_string_length (buf);
- msg = scm_i_make_string (len, &dest, 0);
- SCM_SYSCALL (rv = recv (fd, dest, len, flg));
- scm_string_copy_x (buf, scm_from_int (0),
- msg, scm_from_int (0), scm_from_size_t (len));
- }
- else
-#endif
- {
- SCM_VALIDATE_BYTEVECTOR (1, buf);
+ SCM_VALIDATE_BYTEVECTOR (1, buf);
- SCM_SYSCALL (rv = recv (fd,
- SCM_BYTEVECTOR_CONTENTS (buf),
- SCM_BYTEVECTOR_LENGTH (buf),
- flg));
- }
+ SCM_SYSCALL (rv = recv (fd,
+ SCM_BYTEVECTOR_CONTENTS (buf),
+ SCM_BYTEVECTOR_LENGTH (buf),
+ flg));
if (SCM_UNLIKELY (rv == -1))
SCM_SYSERROR;
fd = SCM_FPORT_FDES (sock);
-#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_UNLIKELY (scm_is_string (message)))
- {
- scm_c_issue_deprecation_warning
- ("Passing a string to `send' is deprecated, "
- "use a bytevector instead.");
-
- /* If the string is wide, see if it can be coerced into a narrow
- string. */
- if (!scm_i_is_narrow_string (message)
- || !scm_i_try_narrow_string (message))
- SCM_MISC_ERROR ("the message string is not 8-bit: ~s",
- scm_list_1 (message));
-
- SCM_SYSCALL (rv = send (fd,
- scm_i_string_chars (message),
- scm_i_string_length (message),
- flg));
- }
- else
-#endif
- {
- SCM_VALIDATE_BYTEVECTOR (1, message);
+ SCM_VALIDATE_BYTEVECTOR (1, message);
- SCM_SYSCALL (rv = send (fd,
- SCM_BYTEVECTOR_CONTENTS (message),
- SCM_BYTEVECTOR_LENGTH (message),
- flg));
- }
+ SCM_SYSCALL (rv = send (fd,
+ SCM_BYTEVECTOR_CONTENTS (message),
+ SCM_BYTEVECTOR_LENGTH (message),
+ flg));
if (rv == -1)
SCM_SYSERROR;
((struct sockaddr *) &addr)->sa_family = AF_UNSPEC;
-#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_UNLIKELY (scm_is_string (buf)))
- {
- char *cbuf;
-
- scm_c_issue_deprecation_warning
- ("Passing a string to `recvfrom!' is deprecated, "
- "use a bytevector instead.");
-
- scm_i_get_substring_spec (scm_i_string_length (buf),
- start, &offset, end, &cend);
+ SCM_VALIDATE_BYTEVECTOR (1, buf);
- buf = scm_i_string_start_writing (buf);
- cbuf = scm_i_string_writable_chars (buf);
+ if (SCM_UNBNDP (start))
+ offset = 0;
+ else
+ offset = scm_to_size_t (start);
- SCM_SYSCALL (rv = recvfrom (fd, cbuf + offset,
- cend - offset, flg,
- (struct sockaddr *) &addr, &addr_size));
- scm_i_string_stop_writing ();
- }
+ if (SCM_UNBNDP (end))
+ cend = SCM_BYTEVECTOR_LENGTH (buf);
else
-#endif
{
- SCM_VALIDATE_BYTEVECTOR (1, buf);
-
- if (SCM_UNBNDP (start))
- offset = 0;
- else
- offset = scm_to_size_t (start);
-
- if (SCM_UNBNDP (end))
- cend = SCM_BYTEVECTOR_LENGTH (buf);
- else
- {
- cend = scm_to_size_t (end);
- if (SCM_UNLIKELY (cend >= SCM_BYTEVECTOR_LENGTH (buf)
- || cend < offset))
- scm_out_of_range (FUNC_NAME, end);
- }
-
- SCM_SYSCALL (rv = recvfrom (fd,
- SCM_BYTEVECTOR_CONTENTS (buf) + offset,
- cend - offset, flg,
- (struct sockaddr *) &addr, &addr_size));
+ cend = scm_to_size_t (end);
+ if (SCM_UNLIKELY (cend >= SCM_BYTEVECTOR_LENGTH (buf)
+ || cend < offset))
+ scm_out_of_range (FUNC_NAME, end);
}
+ SCM_SYSCALL (rv = recvfrom (fd,
+ SCM_BYTEVECTOR_CONTENTS (buf) + offset,
+ cend - offset, flg,
+ (struct sockaddr *) &addr, &addr_size));
+
if (rv == -1)
SCM_SYSERROR;
flg = SCM_NUM2ULONG (5, SCM_CAR (args_and_flags));
}
-#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_UNLIKELY (scm_is_string (message)))
- {
- scm_c_issue_deprecation_warning
- ("Passing a string to `sendto' is deprecated, "
- "use a bytevector instead.");
-
- /* If the string is wide, see if it can be coerced into a narrow
- string. */
- if (!scm_i_is_narrow_string (message)
- || !scm_i_try_narrow_string (message))
- SCM_MISC_ERROR ("the message string is not 8-bit: ~s",
- scm_list_1 (message));
-
- SCM_SYSCALL (rv = sendto (fd,
- scm_i_string_chars (message),
- scm_i_string_length (message),
- flg, soka, size));
- }
- else
-#endif
- {
- SCM_VALIDATE_BYTEVECTOR (1, message);
+ SCM_VALIDATE_BYTEVECTOR (1, message);
- SCM_SYSCALL (rv = sendto (fd,
- SCM_BYTEVECTOR_CONTENTS (message),
- SCM_BYTEVECTOR_LENGTH (message),
- flg, soka, size));
- }
+ SCM_SYSCALL (rv = sendto (fd,
+ SCM_BYTEVECTOR_CONTENTS (message),
+ SCM_BYTEVECTOR_LENGTH (message),
+ flg, soka, size));
if (rv == -1)
{
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, less, len);
}
- else if (scm_is_simple_vector (items)
- || (scm_is_array (items) && scm_c_array_rank (items) == 1))
+ else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
{
scm_restricted_vector_sort_x (items,
less,
if (scm_is_pair (items))
return scm_sort_x (scm_list_copy (items), less);
- else if (scm_is_simple_vector (items)
- || (scm_is_array (items) && scm_c_array_rank (items) == 1))
+ else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
return scm_sort_x (scm_vector_copy (items), less);
else
SCM_WRONG_TYPE_ARG (1, items);
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, less, len);
}
- else if (scm_is_simple_vector (items)
- || (scm_is_array (items) && scm_c_array_rank (items) == 1))
+ else if (scm_is_array (items) && 1 == scm_c_array_rank (items))
{
scm_t_array_handle temp_handle, vec_handle;
SCM temp, *temp_elts, *vec_elts;
if (scm_is_pair (items))
return scm_stable_sort_x (scm_list_copy (items), less);
- else if (scm_is_simple_vector (items)
- || (scm_is_array (items) && scm_c_array_rank (items) == 1))
- return scm_stable_sort_x (scm_vector_copy (items), less);
else
- SCM_WRONG_TYPE_ARG (1, items);
+ return scm_stable_sort_x (scm_vector_copy (items), less);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
+SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
(SCM items, SCM less),
"Sort the list @var{items}, using @var{less} for comparing the\n"
"list elements. The sorting is destructive, that means that the\n"
#include "libguile/hash.h"
#include "libguile/ports.h"
#include "libguile/root.h"
-#include "libguile/weaks.h"
#include "libguile/gc.h"
#include "libguile/validate.h"
SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
static SCM scm_source_whash;
-static scm_i_pthread_mutex_t source_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/*
srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<srcprops ", port);
+ scm_puts_unlocked ("#<srcprops ", port);
SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (scm_srcprops_to_alist (obj), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
return SCM_EOL;
else
{
- SCM p;
-
- scm_i_pthread_mutex_lock (&source_lock);
- p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
- scm_i_pthread_mutex_unlock (&source_lock);
+ SCM p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);
if (SRCPROPSP (p))
return scm_srcprops_to_alist (p);
{
SCM_VALIDATE_NIM (1, obj);
- scm_i_pthread_mutex_lock (&source_lock);
- scm_hashq_set_x (scm_source_whash, obj, alist);
- scm_i_pthread_mutex_unlock (&source_lock);
+ scm_weak_table_putq_x (scm_source_whash, obj, alist);
return alist;
}
if (SCM_IMP (obj))
return 0;
else
- {
- int ret;
-
- scm_i_pthread_mutex_lock (&source_lock);
- ret = scm_is_true (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F));
- scm_i_pthread_mutex_unlock (&source_lock);
-
- return ret;
- }
+ return scm_is_true (scm_weak_table_refq (scm_source_whash, obj, SCM_BOOL_F));
}
#undef FUNC_NAME
{
SCM_VALIDATE_NIM (1, obj);
- scm_i_pthread_mutex_lock (&source_lock);
- scm_hashq_set_x (scm_source_whash, obj,
- scm_make_srcprops (line, col, fname,
- SCM_COPY_SOURCE_P
- ? scm_copy_tree (obj)
- : SCM_UNDEFINED,
- SCM_EOL));
- scm_i_pthread_mutex_unlock (&source_lock);
+ scm_weak_table_putq_x (scm_source_whash, obj,
+ scm_make_srcprops (line, col, fname,
+ SCM_COPY_SOURCE_P
+ ? scm_copy_tree (obj)
+ : SCM_UNDEFINED,
+ SCM_EOL));
}
#undef FUNC_NAME
"@var{obj}'s source property list.")
#define FUNC_NAME s_scm_source_property
{
+ SCM p;
+
if (SCM_IMP (obj))
return SCM_BOOL_F;
+
+ p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);
+
+ if (!SRCPROPSP (p))
+ goto alist;
+ if (scm_is_eq (scm_sym_line, key))
+ return scm_from_int (SRCPROPLINE (p));
+ else if (scm_is_eq (scm_sym_column, key))
+ return scm_from_int (SRCPROPCOL (p));
+ else if (scm_is_eq (scm_sym_copy, key))
+ return SRCPROPCOPY (p);
else
{
- SCM p;
-
- scm_i_pthread_mutex_lock (&source_lock);
- p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
- scm_i_pthread_mutex_unlock (&source_lock);
-
- if (!SRCPROPSP (p))
- goto alist;
- if (scm_is_eq (scm_sym_line, key))
- p = scm_from_int (SRCPROPLINE (p));
- else if (scm_is_eq (scm_sym_column, key))
- p = scm_from_int (SRCPROPCOL (p));
- else if (scm_is_eq (scm_sym_copy, key))
- p = SRCPROPCOPY (p);
- else
- {
- p = SRCPROPALIST (p);
- alist:
- p = scm_assoc (key, p);
- return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
- }
- return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
+ p = SRCPROPALIST (p);
+ alist:
+ p = scm_assoc (key, p);
+ return (scm_is_pair (p) ? SCM_CDR (p) : SCM_BOOL_F);
}
}
#undef FUNC_NAME
SCM p;
SCM_VALIDATE_NIM (1, obj);
- scm_i_pthread_mutex_lock (&source_lock);
- p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);
if (scm_is_eq (scm_sym_line, key))
{
if (SRCPROPSP (p))
SETSRCPROPLINE (p, scm_to_int (datum));
else
- scm_hashq_set_x (scm_source_whash, obj,
- scm_make_srcprops (scm_to_int (datum), 0,
- SCM_UNDEFINED, SCM_UNDEFINED, p));
+ scm_weak_table_putq_x (scm_source_whash, obj,
+ scm_make_srcprops (scm_to_int (datum), 0,
+ SCM_UNDEFINED, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_column, key))
{
if (SRCPROPSP (p))
SETSRCPROPCOL (p, scm_to_int (datum));
else
- scm_hashq_set_x (scm_source_whash, obj,
- scm_make_srcprops (0, scm_to_int (datum),
- SCM_UNDEFINED, SCM_UNDEFINED, p));
+ scm_weak_table_putq_x (scm_source_whash, obj,
+ scm_make_srcprops (0, scm_to_int (datum),
+ SCM_UNDEFINED, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_copy, key))
{
if (SRCPROPSP (p))
SETSRCPROPCOPY (p, datum);
else
- scm_hashq_set_x (scm_source_whash, obj,
- scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
+ scm_weak_table_putq_x (scm_source_whash, obj,
+ scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
}
else
{
if (SRCPROPSP (p))
SETSRCPROPALIST (p, scm_acons (key, datum, SRCPROPALIST (p)));
else
- scm_hashq_set_x (scm_source_whash, obj,
- scm_acons (key, datum, p));
+ scm_weak_table_putq_x (scm_source_whash, obj,
+ scm_acons (key, datum, p));
}
- scm_i_pthread_mutex_unlock (&source_lock);
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
return SCM_UNSPECIFIED;
}
{
SCM p, z;
z = scm_cons (x, y);
- scm_i_pthread_mutex_lock (&source_lock);
/* Copy source properties possibly associated with xorig. */
- p = scm_hashq_ref (scm_source_whash, xorig, SCM_BOOL_F);
+ p = scm_weak_table_refq (scm_source_whash, xorig, SCM_BOOL_F);
if (scm_is_true (p))
- scm_hashq_set_x (scm_source_whash, z, p);
- scm_i_pthread_mutex_unlock (&source_lock);
+ scm_weak_table_putq_x (scm_source_whash, z, p);
return z;
}
#undef FUNC_NAME
scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0);
scm_set_smob_print (scm_tc16_srcprops, srcprops_print);
- scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
+ scm_source_whash = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
scm_c_define ("source-whash", scm_source_whash);
scm_last_alist_filename = scm_cons (SCM_EOL,
/* srfi-1.c --- SRFI-1 procedures for Guile
*
- * Copyright (C) 1995-1997, 2000-2003, 2005, 2006, 2008-2011,
+ * Copyright (C) 1995-1997, 2000-2003, 2005, 2006, 2008-2011, 2013
* 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
}
- count += scm_is_true (scm_apply (pred, args, SCM_EOL));
+ count += scm_is_true (scm_apply_0 (pred, args));
}
}
p = SCM_CHARSET_DATA (charset);
- scm_puts ("#<charset {", port);
+ scm_puts_unlocked ("#<charset {", port);
for (i = 0; i < p->len; i++)
{
if (first)
first = 0;
else
- scm_puts (" ", port);
+ scm_puts_unlocked (" ", port);
scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port);
if (p->ranges[i].lo != p->ranges[i].hi)
{
- scm_puts ("..", port);
+ scm_puts_unlocked ("..", port);
scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port);
}
if (i >= max_ranges_to_print)
{
/* Too many to print here. Quit early. */
- scm_puts (" ...", port);
+ scm_puts_unlocked (" ...", port);
break;
}
}
- scm_puts ("}>", port);
+ scm_puts_unlocked ("}>", port);
return 1;
}
cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
- scm_puts ("#<charset-cursor ", port);
+ scm_puts_unlocked ("#<charset-cursor ", port);
if (cur->range == (size_t) (-1))
- scm_puts ("(empty)", port);
+ scm_puts_unlocked ("(empty)", port);
else
{
scm_write (scm_from_size_t (cur->range), port);
- scm_puts (":", port);
+ scm_puts_unlocked (":", port);
scm_write (scm_from_int32 (cur->n), port);
}
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
/* srfi-14.c --- SRFI-14 procedures for Guile
*
- * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#define SCM_CHARSET_GET(cs,idx) \
scm_i_charset_get((scm_t_char_set *)SCM_SMOB_DATA(cs),idx)
-#define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset))
+#define SCM_CHARSETP(x) (SCM_HAS_TYP16 (x, scm_tc16_charset))
/* Smob type code for character sets. */
SCM_API int scm_tc16_charset;
/* srfi-4.c --- Uniform numeric vector datatypes.
*
- * Copyright (C) 2001, 2004, 2006, 2009, 2010, 2014 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2009, 2010, 2011, 2014 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/eval.h"
#include "libguile/extensions.h"
#include "libguile/uniform.h"
-#include "libguile/generalized-vectors.h"
#include "libguile/validate.h"
#define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype, width) \
SCM scm_take_##tag##vector (ctype *data, size_t n) \
{ \
- return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG)); \
+ return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG), \
+ SCM_BOOL_F); \
} \
const ctype* scm_array_handle_##tag##_elements (scm_t_array_handle *h) \
{ \
#define SCM_SRFI_4_H
/* srfi-4.c --- Homogeneous numeric vector datatypes.
*
- * Copyright (C) 2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2008, 2009, 2010, 2011, 2014 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
size_t *lenp,
ssize_t *incp);
-SCM_INTERNAL SCM scm_i_generalized_vector_type (SCM vec);
-SCM_INTERNAL const char *scm_i_uniform_vector_tag (SCM uvec);
-SCM_INTERNAL scm_i_t_array_ref scm_i_uniform_vector_ref_proc (SCM uvec);
-SCM_INTERNAL scm_i_t_array_set scm_i_uniform_vector_set_proc (SCM uvec);
-
-#if SCM_ENABLE_DEPRECATED
-
-/* Deprecated because we want people to use the scm_t_array_handle
- interface.
-*/
-
-SCM_DEPRECATED size_t scm_uniform_element_size (SCM obj);
-
-#endif
-
SCM_INTERNAL void scm_init_srfi_4 (void);
#endif /* SCM_SRFI_4_H */
-/* Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008, 2010, 2011, 2014 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
/* {Stack Checking}
*/
-#ifdef STACK_CHECKING
int scm_stack_checking_enabled_p;
-SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
-
-static void
-reset_scm_stack_checking_enabled_p (void *arg)
-{
- scm_stack_checking_enabled_p = (int)(scm_t_bits)arg;
-}
-
-void
-scm_report_stack_overflow ()
-{
- scm_dynwind_begin (0); /* non-rewindable frame */
- scm_dynwind_unwind_handler (reset_scm_stack_checking_enabled_p,
- (void*)(scm_t_bits)scm_stack_checking_enabled_p,
- SCM_F_WIND_EXPLICITLY);
-
- scm_stack_checking_enabled_p = 0;
-
- scm_error (scm_stack_overflow_key,
- NULL,
- "Stack overflow",
- SCM_BOOL_F,
- SCM_BOOL_F);
-
- /* not reached */
- scm_dynwind_end ();
-}
-
-#endif
-
long
scm_stack_size (SCM_STACKITEM *start)
{
scm_uintprint ((scm_stack_size (thread->continuation_base)
* sizeof (SCM_STACKITEM)),
16, port);
- scm_puts (" of stack: 0x", port);
+ scm_puts_unlocked (" of stack: 0x", port);
scm_uintprint ((scm_t_bits) thread->continuation_base, 16, port);
- scm_puts (" - 0x", port);
+ scm_puts_unlocked (" - 0x", port);
scm_uintprint ((scm_t_bits) &stack, 16, port);
- scm_puts ("\n", port);
+ scm_puts_unlocked ("\n", port);
}
#ifndef SCM_STACKCHK_H
#define SCM_STACKCHK_H
-/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008, 2009, 2010, 2011, 2014 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
-#if defined BUILDING_LIBGUILE && defined STACK_CHECKING
+#if defined BUILDING_LIBGUILE
#include "libguile/private-options.h"
# if SCM_STACK_GROWS_UP
# define SCM_STACK_OVERFLOW_P(s)\
\f
-SCM_API void scm_report_stack_overflow (void);
SCM_API long scm_stack_size (SCM_STACKITEM *start);
SCM_API void scm_stack_report (void);
SCM_API SCM scm_sys_get_stack_size (void);
/* A stack holds a frame chain
- * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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
/* Count number of debug info frames on a stack, beginning with FRAME.
*/
static long
-stack_depth (SCM frame)
+stack_depth (enum scm_vm_frame_kind kind, const struct scm_frame *frame)
{
- long n = 0;
- /* count frames, skipping boot frames */
- for (; scm_is_true (frame); frame = scm_frame_previous (frame))
+ struct scm_frame tmp;
+ long n = 1;
+ memcpy (&tmp, frame, sizeof tmp);
+ while (scm_c_frame_previous (kind, &tmp))
++n;
return n;
}
* encountered.
*/
-static SCM
+static scm_t_ptrdiff
find_prompt (SCM key)
{
- SCM winds;
- for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = scm_cdr (winds))
- {
- SCM elt = scm_car (winds);
- if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), key))
- return elt;
- }
- scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
- scm_list_1 (key));
- return SCM_BOOL_F; /* not reached */
+ scm_t_ptrdiff fp_offset;
+
+ if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key,
+ NULL, &fp_offset, NULL, NULL, NULL))
+ scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
+ scm_list_1 (key));
+
+ return fp_offset;
}
-static void
-narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
+static long
+narrow_stack (long len, enum scm_vm_frame_kind kind, struct scm_frame *frame,
+ SCM inner_cut, SCM outer_cut)
{
- unsigned long int len;
- SCM frame;
-
- len = SCM_STACK_LENGTH (stack);
- frame = SCM_STACK_FRAME (stack);
+ /* Resolve procedure cuts to address ranges, if possible. If the
+ debug information has been stripped, this might not be
+ possible. */
+ if (scm_is_true (scm_program_p (inner_cut)))
+ {
+ SCM addr_range = scm_program_address_range (inner_cut);
+ if (scm_is_pair (addr_range))
+ inner_cut = addr_range;
+ }
+ if (scm_is_true (scm_program_p (outer_cut)))
+ {
+ SCM addr_range = scm_program_address_range (outer_cut);
+ if (scm_is_pair (addr_range))
+ outer_cut = addr_range;
+ }
/* Cut inner part. */
- if (scm_is_true (scm_procedure_p (inner_key)))
+ if (scm_is_true (scm_procedure_p (inner_cut)))
{
/* Cut until the given procedure is seen. */
- for (; inner && len ; --inner)
+ for (; len ;)
{
- SCM proc = scm_frame_procedure (frame);
+ SCM proc = scm_c_frame_closure (kind, frame);
len--;
- frame = scm_frame_previous (frame);
- if (scm_is_eq (proc, inner_key))
+ scm_c_frame_previous (kind, frame);
+ if (scm_is_eq (proc, inner_cut))
break;
}
}
- else if (scm_is_symbol (inner_key))
+ else if (scm_is_pair (inner_cut)
+ && scm_is_integer (scm_car (inner_cut))
+ && scm_is_integer (scm_cdr (inner_cut)))
{
- /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
- symbols. */
- SCM prompt = find_prompt (inner_key);
- for (; len; len--, frame = scm_frame_previous (frame))
- if (SCM_PROMPT_REGISTERS (prompt)->fp
- == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
- break;
+ /* Cut until an IP within the given range is found. */
+ scm_t_uintptr low_pc, high_pc, pc;
+
+ low_pc = scm_to_uintptr_t (scm_car (inner_cut));
+ high_pc = scm_to_uintptr_t (scm_cdr (inner_cut));
+
+ for (; len ;)
+ {
+ pc = (scm_t_uintptr) frame->ip;
+ len--;
+ scm_c_frame_previous (kind, frame);
+ if (low_pc <= pc && pc < high_pc)
+ break;
+ }
}
- else
+ else if (scm_is_integer (inner_cut))
{
/* Cut specified number of frames. */
+ long inner = scm_to_int (inner_cut);
+
for (; inner && len; --inner)
{
len--;
- frame = scm_frame_previous (frame);
+ scm_c_frame_previous (kind, frame);
}
}
-
- SCM_SET_STACK_LENGTH (stack, len);
- SCM_SET_STACK_FRAME (stack, frame);
+ else
+ {
+ /* Cut until the given prompt tag is seen. */
+ scm_t_ptrdiff fp_offset = find_prompt (inner_cut);
+ for (; len; len--, scm_c_frame_previous (kind, frame))
+ if (fp_offset == frame->fp_offset)
+ break;
+ }
/* Cut outer part. */
- if (scm_is_true (scm_procedure_p (outer_key)))
+ if (scm_is_true (scm_procedure_p (outer_cut)))
{
+ long i, new_len;
+ struct scm_frame tmp;
+
+ memcpy (&tmp, frame, sizeof tmp);
+
/* Cut until the given procedure is seen. */
- 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;
- }
+ for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
+ if (scm_is_eq (scm_c_frame_closure (kind, &tmp), outer_cut))
+ new_len = i;
+
+ len = new_len;
}
- else if (scm_is_symbol (outer_key))
+ else if (scm_is_pair (outer_cut)
+ && scm_is_integer (scm_car (outer_cut))
+ && scm_is_integer (scm_cdr (outer_cut)))
{
- /* Cut until the given prompt tag is seen. FIXME, assumes prompt tags are
- symbols. */
- SCM prompt = find_prompt (outer_key);
- while (len)
+ /* Cut until an IP within the given range is found. */
+ scm_t_uintptr low_pc, high_pc, pc;
+ long i, new_len;
+ struct scm_frame tmp;
+
+ low_pc = scm_to_uintptr_t (scm_car (outer_cut));
+ high_pc = scm_to_uintptr_t (scm_cdr (outer_cut));
+
+ memcpy (&tmp, frame, sizeof tmp);
+
+ /* Cut until the given procedure is seen. */
+ for (new_len = i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
{
- frame = scm_stack_ref (stack, scm_from_long (len - 1));
- len--;
- if (SCM_PROMPT_REGISTERS (prompt)->fp
- == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame))
- break;
+ pc = (scm_t_uintptr) tmp.ip;
+ if (low_pc <= pc && pc < high_pc)
+ new_len = i;
}
+
+ len = new_len;
}
- else
+ else if (scm_is_integer (outer_cut))
{
/* Cut specified number of frames. */
+ long outer = scm_to_int (outer_cut);
+
if (outer < len)
len -= outer;
else
len = 0;
}
+ else
+ {
+ /* Cut until the given prompt tag is seen. */
+ long i;
+ struct scm_frame tmp;
+ scm_t_ptrdiff fp_offset = find_prompt (outer_cut);
+
+ memcpy (&tmp, frame, sizeof tmp);
+
+ for (i = 0; i < len; i++, scm_c_frame_previous (kind, &tmp))
+ if (tmp.fp_offset == fp_offset)
+ break;
- SCM_SET_STACK_LENGTH (stack, len);
+ if (i < len)
+ len = i;
+ else
+ len = 0;
+ }
+
+ return len;
}
\f
"a continuation or a frame object).\n"
"\n"
"@var{args} should be a list containing any combination of\n"
- "integer, procedure, prompt tag and @code{#t} values.\n"
+ "integer, procedure, address range, prompt tag and @code{#t}\n"
+ "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{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
"@var{outer_cut_2} @dots{})}.\n"
"\n"
- "Each @var{inner_cut_i} can be @code{#t}, an integer, a prompt\n"
- "tag, or a procedure. @code{#t} means to cut away all frames up\n"
- "to but excluding the first user module frame. An integer means\n"
- "to cut away exactly that number of frames. A prompt tag means\n"
- "to cut away all frames that are inside a prompt with the given\n"
- "tag. A procedure means to cut away all frames up to but\n"
- "excluding the application frame whose procedure matches the\n"
- "specified one.\n"
+ "Each @var{inner_cut_i} can be an integer, a procedure, an\n"
+ "address range, or a prompt tag. An integer means to cut away\n"
+ "exactly that number of frames. A procedure means to cut\n"
+ "away all frames up to but excluding the frame whose procedure\n"
+ "matches the specified one. An address range is a pair of\n"
+ "integers indicating the low and high addresses of a procedure's\n"
+ "code, and is the same as cutting away to a procedure (though\n"
+ "with less work). Anything else is interpreted as a prompt tag\n"
+ "which cuts away all frames that are inside a prompt with the\n"
+ "given tag.\n"
"\n"
- "Each @var{outer_cut_i} can be an integer, a prompt tag, or a\n"
- "procedure. An integer means to cut away that number of frames.\n"
- "A prompt tag means to cut away all frames that are outside a\n"
- "prompt with the given tag. A procedure means to cut away\n"
- "frames down to but excluding the application frame whose\n"
- "procedure matches the specified one.\n"
+ "Each @var{outer_cut_i} can be an integer, a procedure, an\n"
+ "address range, or a prompt tag. An integer means to cut away\n"
+ "that number of frames. A procedure means to cut away frames\n"
+ "down to but excluding the frame whose procedure matches the\n"
+ "specified one. An address range is the same, but with the\n"
+ "procedure's code specified as an address range. Anything else\n"
+ "is taken to be a prompt tag, which cuts away all frames that are\n"
+ "outside a prompt with the given tag.\n"
"\n"
- "If the @var{outer_cut_i} of the last pair is missing, it is\n"
- "taken as 0.")
+ "If the @var{outer_cut_i} of the last pair is missing, it is\n"
+ "taken as 0.")
#define FUNC_NAME s_scm_make_stack
{
long n;
- SCM frame;
- SCM stack;
SCM inner_cut, outer_cut;
+ enum scm_vm_frame_kind kind;
+ struct scm_frame frame;
/* Extract a pointer to the innermost frame of whatever object
scm_make_stack was given. */
SCM cont;
struct scm_vm_cont *c;
- cont = scm_i_vm_capture_continuation (scm_the_vm ());
+ cont = scm_i_capture_current_stack ();
c = SCM_VM_CONT_DATA (cont);
- frame = scm_c_make_frame (cont, c->fp + c->reloc,
- c->sp + c->reloc, c->ra,
- c->reloc);
+ kind = SCM_VM_FRAME_KIND_CONT;
+ frame.stack_holder = c;
+ frame.fp_offset = (c->fp + c->reloc) - c->stack_base;
+ frame.sp_offset = (c->sp + c->reloc) - c->stack_base;
+ frame.ip = c->ra;
}
else if (SCM_VM_FRAME_P (obj))
- frame = obj;
+ {
+ kind = SCM_VM_FRAME_KIND (obj);
+ memcpy (&frame, SCM_VM_FRAME_DATA (obj), sizeof frame);
+ }
else if (SCM_CONTINUATIONP (obj))
/* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
that were in place when the continuation was captured. */
- frame = scm_i_continuation_to_frame (obj);
+ {
+ kind = SCM_VM_FRAME_KIND_CONT;
+ if (!scm_i_continuation_to_frame (obj, &frame))
+ return SCM_BOOL_F;
+ }
+ else if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (obj))
+ {
+ kind = SCM_VM_FRAME_KIND_CONT;
+ if (!scm_i_vm_cont_to_frame (SCM_PROGRAM_FREE_VARIABLE_REF (obj, 0),
+ &frame))
+ return SCM_BOOL_F;
+ }
else
{
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
/* not reached */
}
- /* FIXME: is this even possible? */
- if (scm_is_true (frame)
- && SCM_PROGRAM_P (scm_frame_procedure (frame))
- && SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame)))
- frame = scm_frame_previous (frame);
-
- if (scm_is_false (frame))
+ /* Skip initial boot frame, if any. This is possible if the frame
+ originates from a captured continuation. */
+ if (SCM_PROGRAM_P (scm_c_frame_closure (kind, &frame))
+ && SCM_PROGRAM_IS_BOOT (scm_c_frame_closure (kind, &frame))
+ && !scm_c_frame_previous (kind, &frame))
return SCM_BOOL_F;
/* Count number of frames. Also get stack id tag and check whether
there are more stackframes than we want to record
(SCM_BACKTRACE_MAXDEPTH). */
- n = stack_depth (frame);
+ n = stack_depth (kind, &frame);
- /* 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, scm_stack_id (obj));
- 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))
args = SCM_CDR (args);
}
- narrow_stack (stack,
- scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
- scm_is_integer (inner_cut) ? SCM_BOOL_T : inner_cut,
- scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
- scm_is_integer (outer_cut) ? SCM_BOOL_T : outer_cut);
-
- n = SCM_STACK_LENGTH (stack);
+ n = narrow_stack (n, kind, &frame, inner_cut, outer_cut);
}
if (n > 0)
- return stack;
+ {
+ /* Make the stack object. */
+ SCM stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL);
+ SCM_SET_STACK_LENGTH (stack, n);
+ SCM_SET_STACK_ID (stack, scm_stack_id (obj));
+ SCM_SET_STACK_FRAME (stack, scm_c_make_frame (kind, &frame));
+ return stack;
+ }
else
return SCM_BOOL_F;
}
else if (SCM_CONTINUATIONP (stack))
/* FIXME: implement me */
return SCM_BOOL_F;
+ else if (SCM_PROGRAM_P (stack) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (stack))
+ /* FIXME: implement me */
+ return SCM_BOOL_F;
else
{
SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
static void
bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
{
- SCM_ASSERT (scm_is_simple_vector (sbd_time)
+ SCM_ASSERT (scm_is_vector (sbd_time)
&& SCM_SIMPLE_VECTOR_LENGTH (sbd_time) == 11,
sbd_time, pos, subr);
-/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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 <uninorm.h>
#include <unistr.h>
#include <uniconv.h>
+#include <c-strcase.h>
#include "striconveh.h"
#include "libguile/chars.h"
#include "libguile/root.h"
#include "libguile/strings.h"
+#include "libguile/ports.h"
+#include "libguile/ports-internal.h"
#include "libguile/error.h"
#include "libguile/generalized-vectors.h"
#include "libguile/deprecation.h"
lenhist[1000]++;
#endif
- buf = PTR2SCM (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + len + 1,
+ buf = SCM_PACK_POINTER (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + len + 1,
"string"));
SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG);
#endif
raw_len = (len + 1) * sizeof (scm_t_wchar);
- buf = PTR2SCM (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + raw_len,
+ buf = SCM_PACK_POINTER (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + raw_len,
"string"));
SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG | STRINGBUF_F_WIDE);
#define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf))
#define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start))
-#define IS_STRING(str) (SCM_NIMP(str) && SCM_TYP7(str) == STRING_TAG)
+#define IS_STRING(str) (SCM_HAS_TYP7 (str, STRING_TAG))
/* Read-only strings.
*/
#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
+void
+scm_i_print_stringbuf (SCM exp, SCM port, scm_print_state *pstate)
+{
+ SCM str;
+
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
+ SET_STRINGBUF_SHARED (exp);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
+
+ str = scm_double_cell (RO_STRING_TAG, SCM_UNPACK(exp),
+ 0, STRINGBUF_LENGTH (exp));
+
+ scm_puts ("#<stringbuf ", port);
+ scm_iprin1 (str, port, pstate);
+ scm_puts (">", port);
+}
+
SCM scm_nullstr;
static SCM null_stringbuf;
\f
/* String conversion to/from C. */
+static void
+decoding_error (const char *func_name, int errno_save,
+ const char *str, size_t len)
+{
+ /* Raise an error and pass the raw C string as a bytevector to the `throw'
+ handler. */
+ SCM bv;
+ signed char *buf;
+
+ buf = scm_gc_malloc_pointerless (len, "bytevector");
+ memcpy (buf, str, len);
+ bv = scm_c_take_gc_bytevector (buf, len, SCM_BOOL_F);
+
+ scm_decoding_error (func_name, errno_save,
+ "input locale conversion error", bv);
+}
+
SCM
scm_from_stringn (const char *str, size_t len, const char *encoding,
scm_t_string_failed_conversion_handler handler)
if (len == (size_t) -1)
len = strlen (str);
- if (encoding == NULL || len == 0)
- {
- /* If encoding is null (or the string is empty), use Latin-1. */
- char *buf;
- res = scm_i_make_string (len, &buf, 0);
- memcpy (buf, str, len);
- return res;
- }
+ if (c_strcasecmp (encoding, "ISO-8859-1") == 0 || len == 0)
+ return scm_from_latin1_stringn (str, len);
+ else if (c_strcasecmp (encoding, "UTF-8") == 0
+ && handler == SCM_FAILED_CONVERSION_ERROR)
+ return scm_from_utf8_stringn (str, len);
u32len = 0;
u32 = (scm_t_wchar *) u32_conv_from_encoding (encoding,
NULL, &u32len);
if (SCM_UNLIKELY (u32 == NULL))
- {
- /* Raise an error and pass the raw C string as a bytevector to the `throw'
- handler. */
- SCM bv;
- signed char *buf;
-
- buf = scm_gc_malloc_pointerless (len, "bytevector");
- memcpy (buf, str, len);
- bv = scm_c_take_gc_bytevector (buf, len);
-
- scm_decoding_error (__func__, errno,
- "input locale conversion error", bv);
- }
+ decoding_error (__func__, errno, str, len);
i = 0;
while (i < u32len)
SCM
scm_from_utf8_stringn (const char *str, size_t len)
{
- return scm_from_stringn (str, len, "UTF-8", SCM_FAILED_CONVERSION_ERROR);
+ size_t i, char_len;
+ const scm_t_uint8 *ustr = (const scm_t_uint8 *) str;
+ int ascii = 1, narrow = 1;
+ SCM res;
+
+ if (len == (size_t) -1)
+ len = strlen (str);
+
+ i = 0;
+ char_len = 0;
+
+ while (i < len)
+ {
+ if (ustr[i] <= 127)
+ {
+ char_len++;
+ i++;
+ }
+ else
+ {
+ ucs4_t c;
+ int nbytes;
+
+ ascii = 0;
+
+ nbytes = u8_mbtouc (&c, ustr + i, len - i);
+
+ if (c == 0xfffd)
+ /* Bad UTF-8. */
+ decoding_error (__func__, errno, str, len);
+
+ if (c > 255)
+ narrow = 0;
+
+ char_len++;
+ i += nbytes;
+ }
+ }
+
+ if (ascii)
+ {
+ char *dst;
+ res = scm_i_make_string (char_len, &dst, 0);
+ memcpy (dst, str, len);
+ }
+ else if (narrow)
+ {
+ char *dst;
+ size_t j;
+ ucs4_t c;
+
+ res = scm_i_make_string (char_len, &dst, 0);
+
+ for (i = 0, j = 0; i < len; j++)
+ {
+ i += u8_mbtouc_unsafe (&c, ustr + i, len - i);
+ dst[j] = (signed char) c;
+ }
+ }
+ else
+ {
+ scm_t_wchar *dst;
+ size_t j;
+ ucs4_t c;
+
+ res = scm_i_make_wide_string (char_len, &dst, 0);
+
+ for (i = 0, j = 0; i < len; j++)
+ {
+ i += u8_mbtouc_unsafe (&c, ustr + i, len - i);
+ dst[j] = c;
+ }
+ }
+
+ return res;
}
SCM
return result;
}
+SCM
+scm_from_port_string (const char *str, SCM port)
+{
+ return scm_from_port_stringn (str, -1, port);
+}
+
+SCM
+scm_from_port_stringn (const char *str, size_t len, SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
+
+ if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ return scm_from_latin1_stringn (str, len);
+ else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8
+ && (pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR
+ || (u8_check ((uint8_t *) str, len) == NULL)))
+ return scm_from_utf8_stringn (str, len);
+ else
+ return scm_from_stringn (str, len, pt->encoding, pt->ilseq_handler);
+}
+
/* 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
}
#undef FUNC_NAME
+char *
+scm_to_port_string (SCM str, SCM port)
+{
+ return scm_to_port_stringn (str, NULL, port);
+}
+
+char *
+scm_to_port_stringn (SCM str, size_t *lenp, SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
+
+ if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1
+ && pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR)
+ return scm_to_latin1_stringn (str, lenp);
+ else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
+ return scm_to_utf8_stringn (str, lenp);
+ else
+ return scm_to_stringn (str, lenp, pt->encoding, pt->ilseq_handler);
+}
+
/* Return a malloc(3)-allocated buffer containing the contents of STR encoded
according to ENCODING. If LENP is non-NULL, set it to the size in bytes of
the returned buffer. If the conversion to ENCODING fails, apply the strategy
"string contains #\\nul character: ~S",
scm_list_1 (str));
- if (scm_i_is_narrow_string (str) && (encoding == NULL))
+ if (scm_i_is_narrow_string (str)
+ && c_strcasecmp (encoding, "ISO-8859-1") == 0)
{
/* If using native Latin-1 encoding, just copy the string
contents. */
*cend = scm_to_unsigned_integer (end, *cstart, len);
}
-#if SCM_ENABLE_DEPRECATED
-
-/* When these definitions are removed, it becomes reasonable to use
- read-only strings for string literals. For that, change the reader
- to create string literals with scm_c_substring_read_only instead of
- with scm_c_substring_copy.
-*/
-
-int
-scm_i_deprecated_stringp (SCM str)
-{
- scm_c_issue_deprecation_warning
- ("SCM_STRINGP is deprecated. Use scm_is_string instead.");
-
- return scm_is_string (str);
-}
-
-char *
-scm_i_deprecated_string_chars (SCM str)
-{
- char *chars;
-
- scm_c_issue_deprecation_warning
- ("SCM_STRING_CHARS is deprecated. See the manual for alternatives.");
-
- /* We don't accept shared substrings here since they are not
- null-terminated.
- */
- if (IS_SH_STRING (str))
- 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
- error message.
- */
-
- if (IS_RO_STRING (str))
- 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);
- chars = scm_i_string_writable_chars (str);
- scm_i_string_stop_writing ();
- return chars;
-}
-
-size_t
-scm_i_deprecated_string_length (SCM str)
-{
- scm_c_issue_deprecation_warning
- ("SCM_STRING_LENGTH is deprecated. Use scm_c_string_length instead.");
- return scm_c_string_length (str);
-}
-
-#endif
-
-static SCM
-string_handle_ref (scm_t_array_handle *h, size_t index)
-{
- return scm_c_string_ref (h->array, index);
-}
-
-static void
-string_handle_set (scm_t_array_handle *h, size_t index, SCM val)
-{
- scm_c_string_set_x (h->array, index, val);
-}
-
-static void
-string_get_handle (SCM v, scm_t_array_handle *h)
-{
- h->array = v;
- h->ndims = 1;
- h->dims = &h->dim0;
- h->dim0.lbnd = 0;
- h->dim0.ubnd = scm_c_string_length (v) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_ARRAY_ELEMENT_TYPE_CHAR;
- h->elements = h->writable_elements = NULL;
-}
-
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f,
- string_handle_ref, string_handle_set,
- string_get_handle)
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string)
void
#ifndef SCM_STRINGS_H
#define SCM_STRINGS_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2013 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_from_utf32_string (const scm_t_wchar *str);
SCM_API SCM scm_from_utf32_stringn (const scm_t_wchar *str, size_t len);
+SCM_API char *scm_to_port_string (SCM str, SCM port);
+SCM_API char *scm_to_port_stringn (SCM str, size_t *lenp, SCM port);
+SCM_API SCM scm_from_port_string (const char *str, SCM port);
+SCM_API SCM scm_from_port_stringn (const char *str, size_t len, SCM port);
+
SCM_API char *scm_to_stringn (SCM str, size_t *lenp, const char *encoding,
scm_t_string_failed_conversion_handler handler);
SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len);
#define SCM_I_STRINGBUF_F_SHARED 0x100
#define SCM_I_STRINGBUF_F_WIDE 0x400
+SCM_INTERNAL void scm_i_print_stringbuf (SCM exp, SCM port,
+ scm_print_state *pstate);
/* internal accessor functions. Arguments must be valid. */
-/* deprecated stuff */
-
-#if SCM_ENABLE_DEPRECATED
-
-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)
-#define SCM_STRING_LENGTH(x) scm_i_deprecated_string_length(x)
-#define SCM_STRING_UCHARS(str) ((unsigned char *)SCM_STRING_CHARS (str))
-
-#endif
-
SCM_INTERNAL void scm_init_strings (void);
#endif /* SCM_STRINGS_H */
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2006,
- * 2009, 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
+ * 2009, 2010, 2011, 2012, 2013, 2014 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
/* NOTES:
write_buf/write_end point to the ends of the allocated bytevector.
- read_buf/read_end in principle point to the part of the bytevector which
- has been written to, but this is only updated after a flush.
- read_pos and write_pos in principle should be equal, but this is only true
- when rw_active is SCM_PORT_NEITHER.
+ read_buf/read_end point to the part of the bytevector which has been
+ written to. read_pos and write_pos are always equal.
ENHANCE-ME - output blocks:
static int
-stfill_buffer (SCM port)
+st_fill_input (SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (pt->read_pos >= pt->read_end)
return EOF;
else
- return scm_return_first_int (*pt->read_pos, port);
+ return *pt->read_pos;
}
/* Change the size of a port's bytevector to NEW_SIZE. This doesn't
unsigned long int old_size = SCM_BYTEVECTOR_LENGTH (old_stream);
unsigned long int min_size = min (old_size, new_size);
- scm_t_off index = pt->write_pos - pt->write_buf;
+ scm_t_off offset = pt->write_pos - pt->write_buf;
pt->write_buf_size = new_size;
{
pt->stream = SCM_UNPACK (new_stream);
pt->read_buf = pt->write_buf = (unsigned char *)dst;
- pt->read_pos = pt->write_pos = pt->write_buf + index;
+ pt->read_pos = pt->write_pos = pt->write_buf + offset;
pt->write_end = pt->write_buf + pt->write_buf_size;
pt->read_end = pt->read_buf + pt->read_buf_size;
}
}
-/* Ensure that `write_pos' < `write_end' by enlarging the buffer when
- necessary. Update `read_buf' to account for written chars. The
- buffer is enlarged geometrically. */
static void
-st_flush (SCM port)
+st_write (SCM port, const void *data, size_t size)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- if (pt->write_pos == pt->write_end)
- st_resize_port (pt, pt->write_buf_size * 2);
+ if (size > pt->write_end - pt->write_pos)
+ st_resize_port (pt, max (pt->write_buf_size * 2,
+ pt->write_end - pt->write_pos + size));
+
+ memcpy ((char *) pt->write_pos, data, size);
+ pt->read_pos = (pt->write_pos += size);
- pt->read_pos = pt->write_pos;
if (pt->read_pos > pt->read_end)
{
pt->read_end = (unsigned char *) pt->read_pos;
pt->read_buf_size = pt->read_end - pt->read_buf;
}
- pt->rw_active = SCM_PORT_NEITHER;
-}
-
-static void
-st_write (SCM port, const void *data, size_t size)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- const char *input = (char *) data;
-
- while (size > 0)
- {
- int space = pt->write_end - pt->write_pos;
- int write_len = (size > space) ? space : size;
-
- memcpy ((char *) pt->write_pos, input, write_len);
- pt->write_pos += write_len;
- size -= write_len;
- input += write_len;
- if (write_len == space)
- st_flush (port);
- }
}
static void
else
/* all other cases. */
{
- if (pt->rw_active == SCM_PORT_WRITE)
- st_flush (port);
-
if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ scm_end_input_unlocked (port);
+
+ pt->rw_active = SCM_PORT_NEITHER;
switch (whence)
{
pt->read_buf_size = length;
pt->read_end = pt->read_buf + length;
if (pt->read_pos > pt->read_end)
- pt->read_pos = pt->read_end;
-
- if (pt->write_pos > pt->read_end)
- pt->write_pos = pt->read_end;
+ pt->read_pos = pt->write_pos = pt->read_end;
}
/* The initial size in bytes of a string port's buffer. */
{
SCM z, buf;
scm_t_port *pt;
- size_t str_len, c_pos;
+ size_t read_buf_size, num_bytes, c_byte_pos;
char *c_buf;
if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- z = scm_new_port_table_entry (scm_tc16_strport);
- SCM_SET_CELL_TYPE (z, scm_tc16_strport);
- pt = SCM_PTAB_ENTRY (z);
-
- /* Make PT initially empty, and release the port-table mutex
- immediately. This is so that if one of the function calls below
- raises an exception, a pre-unwind catch handler can still create
- new ports; for instance, `display-backtrace' needs to be able to
- allocate a new string port. See <http://bugs.gnu.org/11197>. */
- scm_port_non_buffer (pt);
- SCM_SETSTREAM (z, SCM_UNPACK (scm_null_bytevector));
-
- scm_dynwind_end ();
-
if (scm_is_false (str))
{
/* Allocate a new buffer to write to. */
- str_len = INITIAL_BUFFER_SIZE;
- buf = scm_c_make_bytevector (str_len);
+ num_bytes = INITIAL_BUFFER_SIZE;
+ buf = scm_c_make_bytevector (num_bytes);
c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
- c_pos = 0;
+
+ /* Reset `read_buf_size'. It will contain the actual number of
+ bytes written to the port. */
+ read_buf_size = 0;
+ c_byte_pos = 0;
}
else
{
- /* STR is a string. */
char *copy;
SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
- /* Create a copy of STR in the encoding of PT. */
- copy = scm_to_stringn (str, &str_len, pt->encoding,
- SCM_FAILED_CONVERSION_ERROR);
- buf = scm_c_make_bytevector (str_len);
+ /* STR is a string. */
+ /* Create a copy of STR in UTF-8. */
+ copy = scm_to_utf8_stringn (str, &num_bytes);
+ buf = scm_c_make_bytevector (num_bytes);
c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
- memcpy (c_buf, copy, str_len);
+ memcpy (c_buf, copy, num_bytes);
free (copy);
- c_pos = scm_to_unsigned_integer (pos, 0, str_len);
- }
+ read_buf_size = num_bytes;
- /* Now, finish up the port. */
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+ if (scm_is_eq (pos, SCM_INUM0))
+ c_byte_pos = 0;
+ else
+ /* Inefficient but simple way to convert the character position
+ POS into a byte position C_BYTE_POS. */
+ free (scm_to_utf8_stringn (scm_substring (str, SCM_INUM0, pos),
+ &c_byte_pos));
+ }
- SCM_SETSTREAM (z, SCM_UNPACK (buf));
- SCM_SET_CELL_TYPE (z, scm_tc16_strport | modes);
+ z = scm_c_make_port_with_encoding (scm_tc16_strport, modes,
+ "UTF-8",
+ scm_i_default_port_conversion_handler (),
+ SCM_UNPACK (buf));
- if (scm_is_false (str))
- /* Reset `read_buf_size'. It will contain the actual number of
- bytes written to PT. */
- pt->read_buf_size = 0;
- else
- pt->read_buf_size = str_len;
+ pt = SCM_PTAB_ENTRY (z);
pt->write_buf = pt->read_buf = (unsigned char *) c_buf;
- pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
- pt->write_buf_size = str_len;
+ pt->read_pos = pt->write_pos = pt->read_buf + c_byte_pos;
+ pt->read_buf_size = read_buf_size;
+ pt->write_buf_size = num_bytes;
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);
-
return z;
}
SCM
scm_strport_to_string (SCM port)
{
- SCM str;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- if (pt->rw_active == SCM_PORT_WRITE)
- st_flush (port);
-
if (pt->read_buf_size == 0)
return scm_nullstr;
- if (pt->encoding == NULL)
- {
- char *buf;
- str = scm_i_make_string (pt->read_buf_size, &buf, 0);
- 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 str;
+ return scm_from_port_stringn ((char *)pt->read_buf, pt->read_buf_size, port);
}
SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
}
#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"
- "port. When the function returns, the string composed of the characters\n"
- "written into the port is returned.")
-#define FUNC_NAME s_scm_call_with_output_string
+SCM
+scm_call_with_output_string (SCM proc)
{
- SCM p;
+ static SCM var = SCM_BOOL_F;
- p = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
- SCM_OPN | SCM_WRTNG,
- FUNC_NAME);
- scm_call_1 (proc, p);
+ if (scm_is_false (var))
+ var = scm_c_private_lookup ("guile", "call-with-output-string");
- return scm_get_output_string (p);
+ return scm_call_1 (scm_variable_ref (var), proc);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_call_with_input_string, "call-with-input-string", 2, 0, 0,
- (SCM string, SCM proc),
- "Calls the one-argument procedure @var{proc} with a newly\n"
- "created input port from which @var{string}'s contents may be\n"
- "read. The value yielded by the @var{proc} is returned.")
-#define FUNC_NAME s_scm_call_with_input_string
+SCM
+scm_call_with_input_string (SCM string, SCM proc)
{
- SCM p = scm_mkstrport(SCM_INUM0, string, SCM_OPN | SCM_RDNG, FUNC_NAME);
- return scm_call_1 (proc, p);
+ static SCM var = SCM_BOOL_F;
+
+ if (scm_is_false (var))
+ var = scm_c_private_lookup ("guile", "call-with-input-string");
+
+ return scm_call_2 (scm_variable_ref (var), string, proc);
}
-#undef FUNC_NAME
SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0,
(SCM str),
static scm_t_bits
scm_make_stptob ()
{
- scm_t_bits tc = scm_make_port_type ("string", stfill_buffer, st_write);
+ scm_t_bits tc = scm_make_port_type ("string", st_fill_input, st_write);
scm_set_port_end_input (tc, st_end_input);
- scm_set_port_flush (tc, st_flush);
scm_set_port_seek (tc, st_seek);
scm_set_port_truncate (tc, st_truncate);
#ifndef SCM_STRPORTS_H
#define SCM_STRPORTS_H
-/* Copyright (C) 1995,1996,2000,2001,2002, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001,2002, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
\f
-#define SCM_STRPORTP(x) (!SCM_IMP (x) && \
- (SCM_TYP16 (x) == scm_tc16_strport))
+#define SCM_STRPORTP(x) (SCM_HAS_TYP16 (x, scm_tc16_strport))
#define SCM_OPSTRPORTP(x) (SCM_STRPORTP (x) && \
(SCM_CELL_WORD_0 (x) & SCM_OPN))
#define SCM_OPINSTRPORTP(x) (SCM_OPSTRPORTP (x) && \
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007,
+ * 2008, 2009, 2010, 2011, 2012, 2013 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/chars.h"
#include "libguile/eval.h"
#include "libguile/alist.h"
-#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
return scm_c_make_structv (vtable, n_tail, n_init, v);
}
+SCM_DEFINE (scm_allocate_struct, "allocate-struct", 2, 0, 0,
+ (SCM vtable, SCM nfields),
+ "Allocate a new structure with space for @var{nfields} fields.\n\n"
+ "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
+ "@var{nfields} must be a non-negative integer. Strictly speaking\n"
+ "@var{nfields} is redundant, as the vtable carries the size\n"
+ "for its instances. However passing it is useful as a sanity\n"
+ "check, given that one module can inline a constructor in\n"
+ "another.\n\n"
+ "Fields will be initialized with their default values.")
+#define FUNC_NAME s_scm_allocate_struct
+{
+ SCM ret;
+ size_t c_nfields;
+
+ SCM_VALIDATE_VTABLE (1, vtable);
+ c_nfields = scm_to_size_t (nfields);
+
+ SCM_ASSERT (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) == c_nfields,
+ nfields, 2, FUNC_NAME);
+
+ ret = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), c_nfields);
+
+ if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)))
+ {
+ size_t n;
+ for (n = 0; n < c_nfields; n++)
+ SCM_STRUCT_DATA_SET (ret, n, SCM_UNPACK (SCM_BOOL_F));
+ }
+ else
+ scm_struct_init (ret, SCM_VTABLE_LAYOUT (vtable), 0, 0, NULL);
+
+ return ret;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
(SCM vtable, SCM tail_array_size, SCM init),
"Create a new structure.\n\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"
- "For more information, see the documentation for @code{make-vtable-vtable}.")
+ "initialized to 0.")
#define FUNC_NAME s_scm_make_struct
{
size_t i, n_init;
}
#undef FUNC_NAME
-
-
-#if SCM_ENABLE_DEPRECATED == 1
-SCM
-scm_make_vtable_vtable (SCM user_fields, SCM tail_array_size, SCM init)
-#define FUNC_NAME "make-vtable-vtable"
-{
- SCM fields, layout, obj;
- size_t basic_size, n_tail, i, n_init;
- long ilen;
- scm_t_bits *v;
-
- SCM_VALIDATE_STRING (1, user_fields);
- 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);
- if (!scm_is_valid_vtable_layout (layout))
- SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields));
-
- basic_size = scm_i_symbol_length (layout) / 2;
- 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;
- obj = scm_i_alloc_struct (NULL, basic_size + n_tail);
- /* Make it so that the vtable of OBJ is itself. */
- SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) | scm_tc3_struct);
- SCM_CRITICAL_SECTION_END;
-
- scm_struct_init (obj, layout, n_tail, n_init, v);
- SCM_SET_VTABLE_FLAGS (obj,
- SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED);
-
- return obj;
-}
-#undef FUNC_NAME
-#endif
-
SCM
scm_i_make_vtable_vtable (SCM user_fields)
#define FUNC_NAME "make-vtable-vtable"
return SCM_UNPACK (obj) % n;
}
-/* Return the hash of struct OBJ, modulo N. Traverse OBJ's fields to
- compute the result, unless DEPTH is zero. */
-unsigned long
-scm_i_struct_hash (SCM obj, unsigned long n, size_t depth)
-#define FUNC_NAME "hash"
-{
- SCM layout;
- scm_t_bits *data;
- size_t struct_size, field_num;
- unsigned long hash;
-
- SCM_VALIDATE_STRUCT (1, obj);
-
- layout = SCM_STRUCT_LAYOUT (obj);
- struct_size = scm_i_symbol_length (layout) / 2;
- data = SCM_STRUCT_DATA (obj);
-
- hash = SCM_UNPACK (SCM_STRUCT_VTABLE (obj)) % n;
- if (depth > 0)
- for (field_num = 0; field_num < struct_size; field_num++)
- {
- int protection;
-
- protection = scm_i_symbol_ref (layout, field_num * 2 + 1);
- if (protection != 'h' && protection != 'o')
- {
- int type;
- type = scm_i_symbol_ref (layout, field_num * 2);
- switch (type)
- {
- case 'p':
- hash ^= scm_hasher (SCM_PACK (data[field_num]), n,
- depth / 2);
- break;
- case 'u':
- hash ^= data[field_num] % n;
- break;
- default:
- /* Ignore 's' fields. */;
- }
- }
- }
-
- /* FIXME: Tail elements should be taken into account. */
-
- return hash % n;
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
(SCM vtable),
"Return the name of the vtable @var{vtable}.")
{
SCM vtable = SCM_STRUCT_VTABLE (exp);
SCM name = scm_struct_vtable_name (vtable);
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
if (scm_is_true (name))
{
scm_display (name, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
else
{
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE))
- scm_puts ("vtable:", port);
+ scm_puts_unlocked ("vtable:", port);
else
- scm_puts ("struct:", port);
+ scm_puts_unlocked ("struct:", port);
scm_uintprint (SCM_UNPACK (vtable), 16, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_write (SCM_VTABLE_LAYOUT (vtable), port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
scm_uintprint (SCM_UNPACK (exp), 16, port);
/* hackety hack */
{
if (scm_is_true (SCM_STRUCT_PROCEDURE (exp)))
{
- scm_puts (" proc: ", port);
+ scm_puts_unlocked (" 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);
+ scm_puts_unlocked ("(not a procedure?)", port);
}
if (SCM_STRUCT_SETTER_P (exp))
{
- scm_puts (" setter: ", port);
+ scm_puts_unlocked (" setter: ", port);
scm_write (SCM_STRUCT_SETTER (exp), port);
}
}
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
}
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"
-#if SCM_ENABLE_DEPRECATED
- scm_c_define_gsubr ("make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
-#endif
}
/*
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_INTERNAL SCM scm_allocate_struct (SCM vtable, SCM n_words);
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_t_bits init[]);
SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
SCM_INTERNAL SCM scm_i_make_vtable_vtable (SCM extra_fields);
-#if SCM_ENABLE_DEPRECATED == 1
-SCM_DEPRECATED SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
-#endif
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_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
-SCM_INTERNAL unsigned long scm_i_struct_hash (SCM s, unsigned long n,
- size_t depth);
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);
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004,
- * 2006, 2009, 2011 Free Software Foundation, Inc.
+ * 2006, 2009, 2011, 2013 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 <unistr.h>
+
#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/fluids.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
-#include "libguile/hashtab.h"
-#include "libguile/weaks.h"
+#include "libguile/weak-set.h"
#include "libguile/modules.h"
#include "libguile/read.h"
#include "libguile/srfi-13.h"
\f
static SCM symbols;
-static scm_i_pthread_mutex_t symbols_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
#ifdef GUILE_DEBUG
SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0,
lookup_interned_symbol (SCM name, unsigned long raw_hash)
{
struct string_lookup_data data;
- SCM handle;
data.string = name;
data.string_hash = raw_hash;
- scm_i_pthread_mutex_lock (&symbols_lock);
- handle = scm_hash_fn_get_handle_by_hash (symbols, raw_hash,
- string_lookup_predicate_fn,
- &data);
- scm_i_pthread_mutex_unlock (&symbols_lock);
-
- if (scm_is_true (handle))
- return SCM_CAR (handle);
- else
- return SCM_BOOL_F;
+ return scm_c_weak_set_lookup (symbols, raw_hash,
+ string_lookup_predicate_fn,
+ &data, SCM_BOOL_F);
}
struct latin1_lookup_data
unsigned long raw_hash)
{
struct latin1_lookup_data data;
- SCM handle;
data.str = str;
data.len = len;
data.string_hash = raw_hash;
- scm_i_pthread_mutex_lock (&symbols_lock);
- handle = scm_hash_fn_get_handle_by_hash (symbols, raw_hash,
- latin1_lookup_predicate_fn,
- &data);
- scm_i_pthread_mutex_unlock (&symbols_lock);
-
- if (scm_is_true (handle))
- return SCM_CAR (handle);
- else
- return SCM_BOOL_F;
+ return scm_c_weak_set_lookup (symbols, raw_hash,
+ latin1_lookup_predicate_fn,
+ &data, SCM_BOOL_F);
}
-static unsigned long
-symbol_lookup_hash_fn (SCM obj, unsigned long max, void *closure)
+struct utf8_lookup_data
{
- return scm_i_symbol_hash (obj) % max;
-}
+ const char *str;
+ size_t len;
+ unsigned long string_hash;
+};
-static SCM
-symbol_lookup_assoc_fn (SCM obj, SCM alist, void *closure)
+static int
+utf8_string_equals_wide_string (const scm_t_uint8 *narrow, size_t nlen,
+ const scm_t_wchar *wide, size_t wlen)
{
- for (; !scm_is_null (alist); alist = SCM_CDR (alist))
+ size_t byte_idx = 0, char_idx = 0;
+
+ while (byte_idx < nlen && char_idx < wlen)
{
- SCM sym = SCM_CAAR (alist);
-
- if (scm_i_symbol_hash (sym) == scm_i_symbol_hash (obj)
- && scm_is_true (scm_string_equal_p (scm_symbol_to_string (sym),
- scm_symbol_to_string (obj))))
- return SCM_CAR (alist);
+ ucs4_t c;
+ int nbytes;
+
+ nbytes = u8_mbtouc (&c, narrow + byte_idx, nlen - byte_idx);
+ if (nbytes == 0)
+ break;
+ else if (c == 0xfffd)
+ /* Bad UTF-8. */
+ return 0;
+ else if (c != wide[char_idx])
+ return 0;
+
+ byte_idx += nbytes;
+ char_idx++;
}
- return SCM_BOOL_F;
+ return byte_idx == nlen && char_idx == wlen;
}
-/* Intern SYMBOL, an uninterned symbol. Might return a different
- symbol, if another one was interned at the same time. */
-static SCM
-intern_symbol (SCM symbol)
+static int
+utf8_lookup_predicate_fn (SCM sym, void *closure)
{
- SCM handle;
+ struct utf8_lookup_data *data = closure;
- scm_i_pthread_mutex_lock (&symbols_lock);
- handle = scm_hash_fn_create_handle_x (symbols, symbol, SCM_UNDEFINED,
- symbol_lookup_hash_fn,
- symbol_lookup_assoc_fn,
- NULL);
- scm_i_pthread_mutex_unlock (&symbols_lock);
+ if (scm_i_symbol_hash (sym) != data->string_hash)
+ return 0;
+
+ if (scm_i_is_narrow_symbol (sym))
+ return (scm_i_symbol_length (sym) == data->len
+ && strncmp (scm_i_symbol_chars (sym), data->str, data->len) == 0);
+ else
+ return utf8_string_equals_wide_string ((const scm_t_uint8 *) data->str,
+ data->len,
+ scm_i_symbol_wide_chars (sym),
+ scm_i_symbol_length (sym));
+}
- return SCM_CAR (handle);
+static SCM
+lookup_interned_utf8_symbol (const char *str, size_t len,
+ unsigned long raw_hash)
+{
+ struct utf8_lookup_data data;
+
+ data.str = str;
+ data.len = len;
+ data.string_hash = raw_hash;
+
+ return scm_c_weak_set_lookup (symbols, raw_hash,
+ utf8_lookup_predicate_fn,
+ &data, SCM_BOOL_F);
}
+static int
+symbol_lookup_predicate_fn (SCM sym, void *closure)
+{
+ SCM other = SCM_PACK_POINTER (closure);
+
+ if (scm_i_symbol_hash (sym) == scm_i_symbol_hash (other)
+ && scm_i_symbol_length (sym) == scm_i_symbol_length (other))
+ {
+ if (scm_i_is_narrow_symbol (sym))
+ return scm_i_is_narrow_symbol (other)
+ && (strncmp (scm_i_symbol_chars (sym),
+ scm_i_symbol_chars (other),
+ scm_i_symbol_length (other)) == 0);
+ else
+ return scm_is_true
+ (scm_string_equal_p (scm_symbol_to_string (sym),
+ scm_symbol_to_string (other)));
+ }
+ return 0;
+}
+
static SCM
scm_i_str2symbol (SCM str)
{
/* The symbol was not found, create it. */
symbol = scm_i_make_symbol (str, 0, raw_hash,
scm_cons (SCM_BOOL_F, SCM_EOL));
- return intern_symbol (symbol);
+
+ /* Might return a different symbol, if another one was interned at
+ the same time. */
+ return scm_c_weak_set_add_x (symbols, raw_hash,
+ symbol_lookup_predicate_fn,
+ SCM_UNPACK_POINTER (symbol), symbol);
}
}
SCM
scm_from_utf8_symboln (const char *sym, size_t len)
{
- SCM str = scm_from_utf8_stringn (sym, len);
- return scm_i_str2symbol (str);
+ unsigned long hash;
+ SCM ret;
+
+ if (len == (size_t) -1)
+ len = strlen (sym);
+ hash = scm_i_utf8_string_hash (sym, len);
+
+ ret = lookup_interned_utf8_symbol (sym, len, hash);
+ if (scm_is_false (ret))
+ {
+ SCM str = scm_from_utf8_stringn (sym, len);
+ ret = scm_i_str2symbol (str);
+ }
+
+ return ret;
}
void
scm_symbols_prehistory ()
{
- symbols = scm_make_weak_key_hash_table (scm_from_int (2139));
+ symbols = scm_c_make_weak_set (5000);
}
#ifndef SCM_SYMBOLS_H
#define SCM_SYMBOLS_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include "libguile/__scm.h"
\f
-#define scm_is_symbol(x) (!SCM_IMP (x) \
- && (SCM_TYP7 (x) == scm_tc7_symbol))
+#define scm_is_symbol(x) (SCM_HAS_TYP7 (x, scm_tc7_symbol))
#define scm_i_symbol_hash(x) ((unsigned long) SCM_CELL_WORD_2 (x))
#define scm_i_symbol_is_interned(x) \
(!(SCM_CELL_WORD_0 (x) & SCM_I_F_SYMBOL_UNINTERNED))
/* internal functions. */
SCM_INTERNAL unsigned long scm_i_hash_symbol (SCM obj, unsigned long n,
- void *closure);
+ void *closure);
SCM_INTERNAL void scm_symbols_prehistory (void);
SCM_INTERNAL void scm_init_symbols (void);
#ifndef SCM_TAGS_H
#define SCM_TAGS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2012
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013,2014,2015
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
# define SCM_PACK(x) ((SCM) (x))
#endif
+/* Packing SCM objects into and out of pointers.
+ */
+#define SCM_UNPACK_POINTER(x) ((scm_t_bits *) (SCM_UNPACK (x)))
+#define SCM_PACK_POINTER(x) (SCM_PACK ((scm_t_bits) (x)))
+
/* SCM values can not be compared by using the operator ==. Use the following
* macro instead, which is the equivalent of the scheme predicate 'eq?'.
/* Representation of scheme objects:
*
- * Guile's type system is designed to work on systems where scm_t_bits and SCM
- * variables consist of at least 32 bits. The objects that a SCM variable can
- * represent belong to one of the following two major categories:
- *
- * - Immediates -- meaning that the SCM variable contains an entire Scheme
- * object. That means, all the object's data (including the type tagging
- * information that is required to identify the object's type) must fit into
- * 32 bits.
- *
- * - Non-immediates -- meaning that the SCM variable holds a pointer into the
- * heap of cells (see below). On systems where a pointer needs more than 32
- * bits this means that scm_t_bits and SCM variables need to be large enough
- * to hold such pointers. In contrast to immediates, the object's data of
- * a non-immediate can consume arbitrary amounts of memory: The heap cell
- * being pointed to consists of at least two scm_t_bits variables and thus
- * can be used to hold pointers to malloc'ed memory of any size.
- *
- * The 'heap' is the memory area that is under control of Guile's garbage
- * collector. It holds 'single-cells' or 'double-cells', which consist of
- * either two or four scm_t_bits variables, respectively. It is guaranteed
- * that the address of a cell on the heap is 8-byte aligned. That is, since
- * non-immediates hold a cell address, the three least significant bits of a
- * non-immediate can be used to store additional information. The bits are
- * used to store information about the object's type and thus are called
- * tc3-bits, where tc stands for type-code.
- *
- * For a given SCM value, the distinction whether it holds an immediate or
- * non-immediate object is based on the tc3-bits (see above) of its scm_t_bits
+ * Guile's type system is designed to work on systems where scm_t_bits
+ * and SCM variables consist of at least 32 bits. The objects that a
+ * SCM variable can represent belong to one of the following two major
+ * categories:
+ *
+ * - Immediates -- meaning that the SCM variable contains an entire
+ * Scheme object. That means, all the object's data (including the
+ * type tagging information that is required to identify the object's
+ * type) must fit into 32 bits.
+ *
+ * - Heap objects -- meaning that the SCM variable holds a pointer into
+ * the heap. On systems where a pointer needs more than 32 bits this
+ * means that scm_t_bits and SCM variables need to be large enough to
+ * hold such pointers. In contrast to immediates, the data associated
+ * with a heap object can consume arbitrary amounts of memory.
+ *
+ * The 'heap' is the memory area that is under control of Guile's
+ * garbage collector. It holds allocated memory of various sizes. The
+ * impact on the runtime type system is that Guile needs to be able to
+ * determine the type of an object given the pointer. Usually the way
+ * that Guile does this is by storing a "type tag" in the first word of
+ * the object.
+ *
+ * Some objects are common enough that they get special treatment.
+ * Since Guile guarantees that the address of a GC-allocated object on
+ * the heap is 8-byte aligned, Guile can play tricks with the lower 3
+ * bits. That is, since heap objects encode a pointer to an
+ * 8-byte-aligned pointer, the three least significant bits of a SCM can
+ * be used to store additional information. The bits are used to store
+ * information about the object's type and thus are called tc3-bits,
+ * where tc stands for type-code.
+ *
+ * For a given SCM value, the distinction whether it holds an immediate
+ * or heap object is based on the tc3-bits (see above) of its scm_t_bits
* equivalent: If the tc3-bits equal #b000, then the SCM value holds a
- * non-immediate, and the scm_t_bits variable's value is just the pointer to
- * the heap cell.
+ * heap object, and the scm_t_bits variable's value is just the pointer
+ * to the heap cell.
*
* Summarized, the data of a scheme object that is represented by a SCM
- * variable consists of a) the SCM variable itself, b) in case of
- * non-immediates the data of the single-cell or double-cell the SCM object
- * points to, c) in case of non-immediates potentially additional data outside
- * of the heap (like for example malloc'ed data), and d) in case of
- * non-immediates potentially additional data inside of the heap, since data
- * stored in b) and c) may hold references to other cells.
+ * variable consists of a) the SCM variable itself, b) in case of heap
+ * objects memory that the SCM object points to, c) in case of heap
+ * objects potentially additional data outside of the heap (like for
+ * example malloc'ed data), and d) in case of heap objects potentially
+ * additional data inside of the heap, since data stored in b) and c)
+ * may hold references to other cells.
*
*
* Immediates
*
* Operations on immediate objects can typically be processed faster than on
- * non-immediates. The reason is that the object's data can be extracted
+ * heap objects. The reason is that the object's data can be extracted
* directly from the SCM variable (or rather a corresponding scm_t_bits
* variable), instead of having to perform additional memory accesses to
* obtain the object's data from the heap. In order to get the best possible
* special objects listed above.
*
*
- * Non-Immediates
- *
- * All object types not mentioned above in the list of immedate objects are
- * represented as non-immediates. Whether a non-immediate scheme object is
- * represented by a single-cell or a double-cell depends on the object's type,
- * namely on the set of attributes that have to be stored with objects of that
- * type. Every non-immediate type is allowed to define its own layout and
- * interpretation of the data stored in its cell (with some restrictions, see
- * below).
- *
- * One of the design goals of guile's type system is to make it possible to
- * store a scheme pair with as little memory usage as possible. The minimum
- * amount of memory that is required to store two scheme objects (car and cdr
- * of a pair) is the amount of memory required by two scm_t_bits or SCM
- * variables. Therefore pairs in guile are stored in single-cells.
- *
- * Another design goal for the type system is to store procedure objects
- * created by lambda expresssions (closures) and class instances (goops
- * objects) with as little memory usage as possible. Closures are represented
- * by a reference to the function code and a reference to the closure's
- * environment. Class instances are represented by a reference to the
- * instance's class definition and a reference to the instance's data. Thus,
- * closures as well as class instances also can be stored in single-cells.
- *
- * Certain other non-immediate types also store their data in single-cells.
- * By design decision, the heap is split into areas for single-cells and
- * double-cells, but not into areas for single-cells-holding-pairs and areas
- * for single-cells-holding-non-pairs. Any single-cell on the heap therefore
- * can hold pairs (consisting of two scm_t_bits variables representing two
- * scheme objects - the car and cdr of the pair) and non-pairs (consisting of
- * two scm_t_bits variables that hold bit patterns as defined by the layout of
- * the corresponding object's type).
+ * Heap Objects
+ *
+ * All object types not mentioned above in the list of immedate objects
+ * are represented as heap objects. The amount of memory referenced by
+ * a heap object depends on the object's type, namely on the set of
+ * attributes that have to be stored with objects of that type. Every
+ * heap object type is allowed to define its own layout and
+ * interpretation of the data stored in its cell (with some
+ * restrictions, see below).
+ *
+ * One of the design goals of guile's type system is to make it possible
+ * to store a scheme pair with as little memory usage as possible. The
+ * minimum amount of memory that is required to store two scheme objects
+ * (car and cdr of a pair) is the amount of memory required by two
+ * scm_t_bits or SCM variables. Therefore pairs in guile are stored in
+ * two words, and are tagged with a bit pattern in the SCM value, not
+ * with a type tag on the heap.
*
*
* Garbage collection
*
- * During garbage collection, unreachable cells on the heap will be freed.
- * That is, the garbage collector will detect cells which have no SCM variable
- * pointing towards them. In order to properly release all memory belonging
- * to the object to which a cell belongs, the gc needs to be able to interpret
- * the cell contents in the correct way. That means that the gc needs to be
- * able to determine the object type associated with a cell only from the cell
- * itself.
- *
- * Consequently, if the gc detects an unreachable single-cell, those two
- * scm_t_bits variables must provide enough information to determine whether
- * they belong to a pair (i. e. both scm_t_bits variables represent valid
- * scheme objects), to a closure, a class instance or if they belong to any
- * other non-immediate. Guile's type system is designed to make it possible
- * to determine a the type to which a cell belongs in the majority of cases
- * from the cell's first scm_t_bits variable. (Given a SCM variable X holding
- * a non-immediate object, the macro SCM_CELL_TYPE(X) will deliver the
- * corresponding cell's first scm_t_bits variable.)
- *
- * If the cell holds a scheme pair, then we already know that the first
- * scm_t_bits variable of the cell will hold a scheme object with one of the
- * following tc3-codes: #b000 (non-immediate), #b010 (small integer), #b110
- * (small integer), #b100 (non-integer immediate). All these tc3-codes have
- * in common, that their least significant bit is #b0. This fact is used by
- * the garbage collector to identify cells that hold pairs. The remaining
- * tc3-codes are assigned as follows: #b001 (class instance or, more
- * precisely, a struct, of which a class instance is a special case), #b011
- * (closure), #b101/#b111 (all remaining non-immediate types).
+ * During garbage collection, unreachable objects on the heap will be
+ * freed. To determine the set of reachable objects, by default, the GC
+ * just traces all words in all heap objects. It is possible to
+ * register custom tracing ("marking") procedures.
+ *
+ * If an object is unreachable, by default, the GC just notes this fact
+ * and moves on. Later allocations will clear out the memory associated
+ * with the object, and re-use it. It is possible to register custom
+ * finalizers, however.
+ *
+ *
+ * Run-time type introspection
+ *
+ * Guile's type system is designed to make it possible to determine a
+ * the type of a heap object from the object's first scm_t_bits
+ * variable. (Given a SCM variable X holding a heap object, the macro
+ * SCM_CELL_TYPE(X) will deliver the corresponding object's first
+ * scm_t_bits variable.)
+ *
+ * If the object holds a scheme pair, then we already know that the
+ * first scm_t_bits variable of the cell will hold a scheme object with
+ * one of the following tc3-codes: #b000 (heap object), #b010 (small
+ * integer), #b110 (small integer), #b100 (non-integer immediate). All
+ * these tc3-codes have in common, that their least significant bit is
+ * #b0. This fact is used by the garbage collector to identify cells
+ * that hold pairs. The remaining tc3-codes are assigned as follows:
+ * #b001 (class instance or, more precisely, a struct, of which a class
+ * instance is a special case), #b011 (closure), #b101/#b111 (all
+ * remaining heap object types).
*
*
* Summary of type codes of scheme objects (SCM variables)
* of the SCM variables corresponding scm_t_bits value.
*
* Note that (as has been explained above) tc1==1 can only occur in the first
- * scm_t_bits variable of a cell belonging to a non-immediate object that is
+ * scm_t_bits variable of a cell belonging to a heap object that is
* not a pair. For an explanation of the tc tags with tc1==1, see the next
* section with the summary of the type codes on the heap.
*
* (1: This can never be the case for a scheme object.)
*
* tc2:
- * 00: Either a non-immediate or some non-integer immediate
+ * 00: Either a heap object or some non-integer immediate
* (01: This can never be the case for a scheme object.)
* 10: Small integer
* (11: This can never be the case for a scheme object.)
*
* tc3:
- * 000: a non-immediate object (pair, closure, class instance etc.)
+ * 000: a heap object (pair, closure, class instance etc.)
* (001: This can never be the case for a scheme object.)
* 010: an even small integer (least significant bit is 0).
* (011: This can never be the case for a scheme object.)
* 110: an odd small integer (least significant bit is 1).
* (111: This can never be the case for a scheme object.)
*
- * The remaining bits of the non-immediate objects form the pointer to the
- * heap cell. The remaining bits of the small integers form the integer's
+ * The remaining bits of the heap objects form the pointer to the heap
+ * cell. The remaining bits of the small integers form the integer's
* value and sign. Thus, the only scheme objects for which a further
* subdivision is of interest are the ones with tc3==100.
*
*
* tc2:
* 00: the cell belongs to a pair with no short integer in its car.
- * 01: the cell belongs to a non-pair (struct or some other non-immediate).
+ * 01: the cell belongs to a non-pair (struct or some other heap object).
* 10: the cell belongs to a pair with a short integer in its car.
- * 11: the cell belongs to a non-pair (closure or some other non-immediate).
+ * 11: the cell belongs to a non-pair (closure or some other heap object).
*
* tc3:
- * 000: the cell belongs to a pair with a non-immediate in its car.
+ * 000: the cell belongs to a pair with a heap object in its car.
* 001: the cell belongs to a struct
* 010: the cell belongs to a pair with an even short integer in its car.
* 011: the cell belongs to a closure
* 100: the cell belongs to a pair with a non-integer immediate in its car.
- * 101: the cell belongs to some other non-immediate.
+ * 101: the cell belongs to some other heap object.
* 110: the cell belongs to a pair with an odd short integer in its car.
- * 111: the cell belongs to some other non-immediate.
+ * 111: the cell belongs to some other heap object.
*
* tc7 (for tc3==1x1):
- * See below for the list of types. Note the special case of scm_tc7_vector
- * and scm_tc7_wvect: vectors and weak vectors are treated the same in many
- * cases. Thus, their tc7-codes are chosen to only differ in one bit. This
- * makes it possible to check an object at the same time for being a vector
- * or a weak vector by comparing its tc7 code with that bit masked (using
- * the TYP7S macro). Three more special tc7-codes are of interest:
- * numbers, ports and smobs in fact each represent collections of types,
- * which are subdivided using tc16-codes.
+ * See below for the list of types. Three special tc7-codes are of
+ * interest: numbers, ports and smobs in fact each represent
+ * collections of types, which are subdivided using tc16-codes.
*
* tc16 (for tc7==scm_tc7_smob):
* The largest part of the space of smob types is not subdivided in a
\f
-/* Checking if a SCM variable holds an immediate or a non-immediate object:
+/* Checking if a SCM variable holds an immediate or a heap object:
* This check can either be performed by checking for tc3==000 or tc3==00x,
* since for a SCM variable it is known that tc1==0. */
#define SCM_IMP(x) (6 & SCM_UNPACK (x))
#define SCM_NIMP(x) (!SCM_IMP (x))
+#define SCM_HEAP_OBJECT_P(x) (SCM_NIMP (x))
/* Checking if a SCM variable holds an immediate integer: See numbers.h for
* the definition of the following macros: SCM_I_FIXNUM_BIT,
/* Checking if a SCM variable holds a pair (for historical reasons, in Guile
* also known as a cons-cell): This is done by first checking that the SCM
- * variable holds a non-immediate, and second, by checking that tc1==0 holds
+ * variable holds a heap object, and second, by checking that tc1==0 holds
* for the SCM_CELL_TYPE of the SCM variable.
*/
#define SCM_ITAG7(x) (127 & SCM_UNPACK (x))
#define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x))
-#define SCM_TYP7S(x) ((0x7f & ~2) & SCM_CELL_TYPE (x))
+#define SCM_HAS_HEAP_TYPE(x, type, tag) \
+ (SCM_NIMP (x) && type (x) == (tag))
+#define SCM_HAS_TYP7(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag))
+
+/* If you change these numbers, change them also in (system vm
+ assembler). */
#define scm_tc7_symbol 5
#define scm_tc7_variable 7
#define scm_tc7_dynamic_state 45
#define scm_tc7_frame 47
-#define scm_tc7_objcode 53
-#define scm_tc7_vm 55
+#define scm_tc7_keyword 53
+#define scm_tc7_unused_55 55
#define scm_tc7_vm_cont 71
-#define scm_tc7_prompt 61
-#define scm_tc7_with_fluids 63
-#define scm_tc7_unused_19 69
-#define scm_tc7_program 79
-#define scm_tc7_array 85
-#define scm_tc7_bitvector 87
-#define scm_tc7_unused_20 93
-#define scm_tc7_unused_11 95
+#define scm_tc7_unused_17 61
+#define scm_tc7_unused_21 63
+#define scm_tc7_program 69
+#define scm_tc7_unused_79 79
+#define scm_tc7_weak_set 85
+#define scm_tc7_weak_table 87
+#define scm_tc7_array 93
+#define scm_tc7_bitvector 95
#define scm_tc7_unused_12 101
#define scm_tc7_unused_18 103
#define scm_tc7_unused_13 109
/* Definitions for tc16: */
#define SCM_TYP16(x) (0xffff & SCM_CELL_TYPE (x))
-#define SCM_TYP16_PREDICATE(tag, x) (!SCM_IMP (x) && SCM_TYP16 (x) == (tag))
+#define SCM_HAS_TYP16(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP16, tag))
+#define SCM_TYP16_PREDICATE(tag, x) (SCM_HAS_TYP16 (x, tag))
\f
case scm_tc2_int + 112: case scm_tc2_int + 116: case scm_tc3_imm24 + 112:\
case scm_tc2_int + 120: case scm_tc2_int + 124: case scm_tc3_imm24 + 120
-/* For cons pairs with non-immediate values in the SCM_CAR
+/* For cons pairs with heap objects in the SCM_CAR
*/
#define scm_tcs_cons_nimcar \
scm_tc3_cons + 0:\
\f
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-#define SCM_CELLP(x) (((sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0)
-#define SCM_NCELLP(x) (!SCM_CELLP (x))
-
-#endif
-
#endif /* SCM_TAGS_H */
/*
#endif
#include "libguile/bdw-gc.h"
+#include <gc/gc_mark.h>
#include "libguile/_scm.h"
#include <stdlib.h>
#include "libguile/fluids.h"
#include "libguile/continuations.h"
#include "libguile/gc.h"
+#include "libguile/gc-inline.h"
#include "libguile/init.h"
#include "libguile/scmsigs.h"
#include "libguile/strings.h"
-#include "libguile/weaks.h"
+#include "libguile/vm.h"
#include <full-read.h>
\f
-/* First some libgc shims. */
-
-/* Make sure GC_fn_type is defined; it is missing from the public
- headers of GC 7.1 and earlier. */
-#ifndef HAVE_GC_FN_TYPE
-typedef void * (* GC_fn_type) (void *);
-#endif
-
-
-#ifndef GC_SUCCESS
-#define GC_SUCCESS 0
-#endif
-
-#ifndef GC_UNIMPLEMENTED
-#define GC_UNIMPLEMENTED 3
-#endif
-
-/* Likewise struct GC_stack_base is missing before 7.1. */
-#ifndef HAVE_GC_STACK_BASE
-struct GC_stack_base {
- void * mem_base; /* Base of memory stack. */
-#ifdef __ia64__
- void * reg_base; /* Base of separate register stack. */
-#endif
-};
-
-static int
-GC_register_my_thread (struct GC_stack_base *stack_base)
-{
- return GC_UNIMPLEMENTED;
-}
-
-static void
-GC_unregister_my_thread ()
-{
-}
-
-#if !SCM_USE_PTHREAD_THREADS
-/* No threads; we can just use GC_stackbottom. */
-static void *
-get_thread_stack_base ()
-{
- return GC_stackbottom;
-}
-
-#elif defined HAVE_PTHREAD_ATTR_GETSTACK && defined HAVE_PTHREAD_GETATTR_NP \
- && defined PTHREAD_ATTR_GETSTACK_WORKS
-/* This method for GNU/Linux and perhaps some other systems.
- It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
- available on them. */
-static void *
-get_thread_stack_base ()
-{
- pthread_attr_t attr;
- void *start, *end;
- size_t size;
-
- pthread_getattr_np (pthread_self (), &attr);
- pthread_attr_getstack (&attr, &start, &size);
- end = (char *)start + size;
-
-#if SCM_STACK_GROWS_UP
- return start;
-#else
- return end;
-#endif
-}
-
-#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 void *
-get_thread_stack_base ()
-{
- return pthread_get_stackaddr_np (pthread_self ());
-}
-
-#elif HAVE_PTHREAD_ATTR_GET_NP
-/* This one is for FreeBSD 9. */
-static void *
-get_thread_stack_base ()
-{
- pthread_attr_t attr;
- void *start, *end;
- size_t size;
-
- pthread_attr_init (&attr);
- pthread_attr_get_np (pthread_self (), &attr);
- pthread_attr_getstack (&attr, &start, &size);
- pthread_attr_destroy (&attr);
-
- end = (char *)start + size;
-
-#if SCM_STACK_GROWS_UP
- return start;
-#else
- return end;
-#endif
-}
-
-#else
-#error Threads enabled with old BDW-GC, but missing get_thread_stack_base impl. Please upgrade to libgc >= 7.1.
-#endif
-
-static int
-GC_get_stack_base (struct GC_stack_base *stack_base)
-{
- stack_base->mem_base = get_thread_stack_base ();
-#ifdef __ia64__
- /* Calculate and store off the base of this thread's register
- backing store (RBS). Unfortunately our implementation(s) of
- scm_ia64_register_backing_store_base are only reliable for the
- main thread. For other threads, therefore, find out the current
- top of the RBS, and use that as a maximum. */
- stack_base->reg_base = scm_ia64_register_backing_store_base ();
- {
- ucontext_t ctx;
- void *bsp;
- getcontext (&ctx);
- bsp = scm_ia64_ar_bsp (&ctx);
- if (stack_base->reg_base > bsp)
- stack_base->reg_base = bsp;
- }
-#endif
- return GC_SUCCESS;
-}
-
-static void *
-GC_call_with_stack_base(void * (*fn) (struct GC_stack_base*, void*), void *arg)
-{
- struct GC_stack_base stack_base;
-
- stack_base.mem_base = (void*)&stack_base;
-#ifdef __ia64__
- /* FIXME: Untested. */
- {
- ucontext_t ctx;
- getcontext (&ctx);
- stack_base.reg_base = scm_ia64_ar_bsp (&ctx);
- }
-#endif
-
- return fn (&stack_base, arg);
-}
-#endif /* HAVE_GC_STACK_BASE */
-
-
-/* Now define with_gc_active and with_gc_inactive. */
-
-#if (defined(HAVE_GC_DO_BLOCKING) && defined (HAVE_DECL_GC_DO_BLOCKING) && defined (HAVE_GC_CALL_WITH_GC_ACTIVE))
+/* The GC "kind" for threads that allow them to mark their VM
+ stacks. */
+static int thread_gc_kind;
+
+static struct GC_ms_entry *
+thread_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
+ struct GC_ms_entry *mark_stack_limit, GC_word env)
+{
+ int word;
+ const struct scm_i_thread *t = (struct scm_i_thread *) addr;
+
+ if (SCM_UNPACK (t->handle) == 0)
+ /* T must be on the free-list; ignore. (See warning in
+ gc_mark.h.) */
+ return mark_stack_ptr;
+
+ /* Mark T. We could be more precise, but it doesn't matter. */
+ for (word = 0; word * sizeof (*addr) < sizeof (*t); word++)
+ mark_stack_ptr = GC_MARK_AND_PUSH ((void *) addr[word],
+ mark_stack_ptr, mark_stack_limit,
+ NULL);
+
+ /* The pointerless freelists are threaded through their first word,
+ but GC doesn't know to trace them (as they are pointerless), so we
+ need to do that here. See the comments at the top of libgc's
+ gc_inline.h. */
+ if (t->pointerless_freelists)
+ {
+ size_t n;
+ for (n = 0; n < SCM_INLINE_GC_FREELIST_COUNT; n++)
+ {
+ void *chain = t->pointerless_freelists[n];
+ if (chain)
+ {
+ /* The first link is already marked by the freelist vector,
+ so we just have to mark the tail. */
+ while ((chain = *(void **)chain))
+ mark_stack_ptr = GC_mark_and_push (chain, mark_stack_ptr,
+ mark_stack_limit, NULL);
+ }
+ }
+ }
-/* We have a sufficiently new libgc (7.2 or newer). */
+ if (t->vp)
+ mark_stack_ptr = scm_i_vm_mark_stack (t->vp, mark_stack_ptr,
+ mark_stack_limit);
-static void*
-with_gc_inactive (GC_fn_type func, void *data)
-{
- return GC_do_blocking (func, data);
-}
-
-static void*
-with_gc_active (GC_fn_type func, void *data)
-{
- return GC_call_with_gc_active (func, data);
+ return mark_stack_ptr;
}
-#else
-
-/* libgc not new enough, so never actually deactivate GC.
-
- Note that though GC 7.1 does have a GC_do_blocking, it doesn't have
- GC_call_with_gc_active. */
-
-static void*
-with_gc_inactive (GC_fn_type func, void *data)
-{
- return func (data);
-}
-
-static void*
-with_gc_active (GC_fn_type func, void *data)
-{
- return func (data);
-}
-
-#endif /* HAVE_GC_DO_BLOCKING */
-
\f
static void
}
}
+
\f
/*** Queues */
else
id = u.um;
- scm_puts ("#<thread ", port);
+ scm_puts_unlocked ("#<thread ", port);
scm_uintprint (id, 10, port);
- scm_puts (" (", port);
+ scm_puts_unlocked (" (", port);
scm_uintprint ((scm_t_bits)t, 16, port);
- scm_puts (")>", port);
+ scm_puts_unlocked (")>", port);
return 1;
}
t.mutexes = SCM_EOL;
t.held_mutex = NULL;
t.join_queue = SCM_EOL;
+ t.freelists = NULL;
+ t.pointerless_freelists = NULL;
t.dynamic_state = SCM_BOOL_F;
- t.dynwinds = SCM_EOL;
+ t.dynstack.base = NULL;
+ t.dynstack.top = NULL;
+ t.dynstack.limit = NULL;
t.active_asyncs = SCM_EOL;
t.block_asyncs = 1;
t.pending_asyncs = 1;
t.sleep_mutex = NULL;
t.sleep_object = SCM_BOOL_F;
t.sleep_fd = -1;
+ t.vp = NULL;
if (pipe2 (t.sleep_pipe, O_CLOEXEC) != 0)
/* FIXME: Error conditions during the initialization phase are handled
abort ();
scm_i_pthread_mutex_init (&t.admin_mutex, NULL);
- t.current_mark_stack_ptr = NULL;
- t.current_mark_stack_limit = NULL;
t.canceled = 0;
t.exited = 0;
t.guile_mode = 0;
scm_i_thread *t_ptr = &t;
GC_disable ();
- t_ptr = GC_malloc (sizeof (scm_i_thread));
+ t_ptr = GC_generic_malloc (sizeof (*t_ptr), thread_gc_kind);
memcpy (t_ptr, &t, sizeof t);
scm_i_pthread_setspecific (scm_i_thread_key, t_ptr);
t->continuation_root = scm_cons (t->handle, SCM_EOL);
t->continuation_base = t->base;
- t->vm = SCM_BOOL_F;
+
+ {
+ size_t size = SCM_INLINE_GC_FREELIST_COUNT * sizeof (void *);
+ t->freelists = scm_gc_malloc (size, "freelists");
+ t->pointerless_freelists = scm_gc_malloc (size, "atomic freelists");
+ }
if (scm_is_true (parent))
t->dynamic_state = scm_make_dynamic_state (parent);
else
t->dynamic_state = scm_i_make_initial_dynamic_state ();
+ t->dynstack.base = scm_gc_malloc (16 * sizeof (scm_t_bits), "dynstack");
+ t->dynstack.limit = t->dynstack.base + 16;
+ t->dynstack.top = t->dynstack.base + SCM_DYNSTACK_HEADER_LEN;
+
t->join_queue = make_queue ();
t->block_asyncs = 0;
{
scm_i_thread *t = (scm_i_thread *) v;
- /* Ensure the signal handling thread has been launched, because we might be
- shutting it down. This needs to be done in Guile mode. */
- scm_i_ensure_signal_delivery_thread ();
-
if (!scm_is_false (t->cleanup_handler))
{
SCM ptr = t->cleanup_handler;
while (!scm_is_null (t->mutexes))
{
- SCM mutex = SCM_WEAK_PAIR_CAR (t->mutexes);
+ SCM mutex = scm_c_weak_vector_ref (scm_car (t->mutexes), 0);
- if (!SCM_UNBNDP (mutex))
+ if (scm_is_true (mutex))
{
fat_mutex *m = SCM_MUTEX_DATA (mutex);
scm_i_pthread_mutex_unlock (&m->lock);
}
- t->mutexes = SCM_WEAK_PAIR_CDR (t->mutexes);
+ t->mutexes = scm_cdr (t->mutexes);
}
scm_i_pthread_mutex_unlock (&t->admin_mutex);
scm_i_pthread_setspecific (scm_i_thread_key, NULL);
+ if (t->vp)
+ {
+ scm_i_vm_free_stack (t->vp);
+ t->vp = NULL;
+ }
+
#if SCM_USE_PTHREAD_THREADS
GC_unregister_my_thread ();
#endif
*/
scm_i_init_guile (base);
-#if defined (HAVE_GC_ALLOW_REGISTER_THREADS) && SCM_USE_PTHREAD_THREADS
+#if SCM_USE_PTHREAD_THREADS
/* Allow other threads to come in later. */
GC_allow_register_threads ();
#endif
#endif
t->guile_mode = 1;
- res = with_gc_active (with_guile_trampoline, args);
+ res = GC_call_with_gc_active (with_guile_trampoline, args);
t->guile_mode = 0;
}
return res;
if (t->guile_mode)
{
SCM_I_CURRENT_THREAD->guile_mode = 0;
- result = with_gc_inactive (func, data);
+ result = GC_do_blocking (func, data);
SCM_I_CURRENT_THREAD->guile_mode = 1;
}
else
#undef FUNC_NAME
-static size_t
-fat_mutex_free (SCM mx)
-{
- fat_mutex *m = SCM_MUTEX_DATA (mx);
- scm_i_pthread_mutex_destroy (&m->lock);
- return 0;
-}
-
static int
fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED)
{
fat_mutex *m = SCM_MUTEX_DATA (mx);
- scm_puts ("#<mutex ", port);
+ scm_puts_unlocked ("#<mutex ", port);
scm_uintprint ((scm_t_bits)m, 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
{
fat_mutex *m;
SCM mx;
+ scm_i_pthread_mutex_t lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
m = scm_gc_malloc (sizeof (fat_mutex), "mutex");
- scm_i_pthread_mutex_init (&m->lock, NULL);
+ /* Because PTHREAD_MUTEX_INITIALIZER is static, it's plain old data,
+ and so we can just copy it. */
+ memcpy (&m->lock, &lock, sizeof (m->lock));
m->owner = SCM_BOOL_F;
m->level = 0;
The weak pair itself is eventually removed when MUTEX
is unlocked. Note that `t->mutexes' lists mutexes
currently held by T, so it should be small. */
- t->mutexes = scm_weak_car_pair (mutex, t->mutexes);
+ t->mutexes = scm_cons (scm_make_weak_vector (SCM_INUM1, mutex),
+ t->mutexes);
scm_i_pthread_mutex_unlock (&t->admin_mutex);
}
#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
#define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
+static void
+remove_mutex_from_thread (SCM mutex, scm_i_thread *t)
+{
+ SCM walk, prev;
+
+ for (prev = SCM_BOOL_F, walk = t->mutexes; scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_eq (mutex, scm_c_weak_vector_ref (SCM_CAR (walk), 0)))
+ {
+ if (scm_is_pair (prev))
+ SCM_SETCDR (prev, SCM_CDR (walk));
+ else
+ t->mutexes = SCM_CDR (walk);
+ break;
+ }
+ }
+}
+
static int
fat_mutex_unlock (SCM mutex, SCM cond,
const scm_t_timespec *waittime, int relock)
if (m->level == 0)
{
/* Change the owner of MUTEX. */
- t->mutexes = scm_delq_x (mutex, t->mutexes);
+ remove_mutex_from_thread (mutex, t);
m->owner = unblock_from_queue (m->waiting);
}
}
t->block_asyncs--;
- scm_async_click ();
+ scm_async_tick ();
scm_remember_upto_here_2 (cond, mutex);
if (m->level == 0)
{
/* Change the owner of MUTEX. */
- t->mutexes = scm_delq_x (mutex, t->mutexes);
+ remove_mutex_from_thread (mutex, t);
m->owner = unblock_from_queue (m->waiting);
}
fat_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED)
{
fat_cond *c = SCM_CONDVAR_DATA (cv);
- scm_puts ("#<condition-variable ", port);
+ scm_puts_unlocked ("#<condition-variable ", port);
scm_uintprint ((scm_t_bits)c, 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
scm_i_pthread_mutex_init (&scm_i_misc_mutex, NULL);
scm_i_pthread_cond_init (&wake_up_cond, NULL);
+ thread_gc_kind =
+ GC_new_kind (GC_new_free_list (),
+ GC_MAKE_PROC (GC_new_proc (thread_mark), 0),
+ 0, 1);
+
guilify_self_1 ((struct GC_stack_base *) base);
}
scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (fat_mutex));
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));
#define SCM_THREADS_H
/* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006,
- * 2007, 2008, 2009, 2011, 2013 Free Software Foundation, Inc.
+ * 2007, 2008, 2009, 2011, 2012, 2013, 2014 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/procs.h"
#include "libguile/throw.h"
#include "libguile/root.h"
+#include "libguile/dynstack.h"
#include "libguile/iselect.h"
-#include "libguile/dynwind.h"
#include "libguile/continuations.h"
#if SCM_USE_PTHREAD_THREADS
scm_i_pthread_cond_t sleep_cond;
int sleep_fd, sleep_pipe[2];
- /* XXX: These two fields used to hold information about the BDW-GC
- mark stack during the mark phase. They are no longer used. */
- void *current_mark_stack_ptr;
- void *current_mark_stack_limit;
+ /* Thread-local freelists; see gc-inline.h. */
+ void **freelists;
+ void **pointerless_freelists;
/* Other thread local things.
*/
SCM dynamic_state;
- SCM dynwinds;
+
+ /* The dynamic stack. */
+ scm_t_dynstack dynstack;
/* For system asyncs.
*/
SCM_STACKITEM *continuation_base;
/* For keeping track of the stack and registers. */
- SCM vm;
+ struct scm_vm *vp;
SCM_STACKITEM *base;
scm_i_jmp_buf regs;
#ifdef __ia64__
SCM_INTERNAL void scm_i_dynwind_pthread_mutex_lock_block_asyncs (scm_i_pthread_mutex_t *mutex);
-#define SCM_THREAD_SWITCHING_CODE \
- do { } while (0)
-
SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler);
SCM_API SCM scm_yield (void);
SCM_API SCM scm_cancel_thread (SCM t);
# 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 */
-
SCM_INTERNAL scm_i_pthread_mutex_t scm_i_misc_mutex;
/* Convenience functions for working with the pthread API in guile
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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 <stdio.h>
#include <unistdio.h>
#include "libguile/_scm.h"
#include "libguile/private-options.h"
-/* Pleasantly enough, the guts of catch are defined in Scheme, in terms of
- prompt, abort, and the %exception-handler fluid. This file just provides
- shims so that it's easy to have catch functionality from C.
+/* Pleasantly enough, the guts of catch are defined in Scheme, in terms
+ of prompt, abort, and the %exception-handler fluid. Check boot-9 for
+ the definitions.
+
+ Still, it's useful to be able to throw unwind-only exceptions from C,
+ for example so that we can recover from stack overflow. We also need
+ to have an implementation of catch and throw handy before boot time.
+ For that reason we have a parallel implementation of "catch" that
+ uses the same fluids here. Throws from C still call out to Scheme
+ though, so that pre-unwind handlers can be run. Getting the dynamic
+ environment right for pre-unwind handlers is tricky, and it's
+ important to have all of the implementation in one place.
All of these function names and prototypes carry a fair bit of historical
baggage. */
\f
-static SCM catch_var, throw_var, with_throw_handler_var;
+static SCM throw_var;
-SCM
-scm_catch (SCM key, SCM thunk, SCM handler)
+static SCM exception_handler_fluid;
+
+static SCM
+catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
{
- return scm_call_3 (scm_variable_ref (catch_var), key, thunk, handler);
+ struct scm_vm *vp;
+ SCM eh, prompt_tag;
+ SCM res;
+ scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
+ SCM dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state;
+ scm_i_jmp_buf registers;
+ scm_t_ptrdiff saved_stack_depth;
+
+ if (!scm_is_eq (tag, SCM_BOOL_T) && !scm_is_symbol (tag))
+ scm_wrong_type_arg ("catch", 1, tag);
+
+ if (SCM_UNBNDP (handler))
+ handler = SCM_BOOL_F;
+ else if (!scm_is_true (scm_procedure_p (handler)))
+ scm_wrong_type_arg ("catch", 3, handler);
+
+ if (SCM_UNBNDP (pre_unwind_handler))
+ pre_unwind_handler = SCM_BOOL_F;
+ else if (!scm_is_true (scm_procedure_p (pre_unwind_handler)))
+ scm_wrong_type_arg ("catch", 4, pre_unwind_handler);
+
+ prompt_tag = scm_cons (SCM_INUM0, SCM_EOL);
+
+ eh = scm_c_make_vector (4, SCM_BOOL_F);
+ scm_c_vector_set_x (eh, 0, scm_fluid_ref (exception_handler_fluid));
+ scm_c_vector_set_x (eh, 1, tag);
+ scm_c_vector_set_x (eh, 2, prompt_tag);
+ scm_c_vector_set_x (eh, 3, pre_unwind_handler);
+
+ vp = scm_the_vm ();
+ saved_stack_depth = vp->sp - vp->stack_base;
+
+ /* Push the prompt and exception handler onto the dynamic stack. */
+ scm_dynstack_push_prompt (dynstack,
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
+ | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
+ prompt_tag,
+ vp->fp - vp->stack_base,
+ saved_stack_depth,
+ vp->ip,
+ ®isters);
+ scm_dynstack_push_fluid (dynstack, exception_handler_fluid, eh,
+ dynamic_state);
+
+ if (SCM_I_SETJMP (registers))
+ {
+ /* A non-local return. */
+ SCM args;
+
+ scm_gc_after_nonlocal_exit ();
+
+ /* FIXME: We know where the args will be on the stack; we could
+ avoid consing them. */
+ args = scm_i_prompt_pop_abort_args_x (vp);
+
+ /* Cdr past the continuation. */
+ args = scm_cdr (args);
+
+ return scm_apply_0 (handler, args);
+ }
+
+ res = scm_call_0 (thunk);
+
+ scm_dynstack_unwind_fluid (dynstack, dynamic_state);
+ scm_dynstack_pop (dynstack);
+
+ return res;
}
-SCM
-scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
- SCM pre_unwind_handler)
+static void
+default_exception_handler (SCM k, SCM args)
{
- if (SCM_UNBNDP (pre_unwind_handler))
- return scm_catch (key, thunk, handler);
+ static int error_printing_error = 0;
+ static int error_printing_fallback = 0;
+
+ if (error_printing_fallback)
+ fprintf (stderr, "\nFailed to print exception.\n");
+ else if (error_printing_error)
+ {
+ fprintf (stderr, "\nError while printing exception:\n");
+ error_printing_fallback = 1;
+ fprintf (stderr, "Key: ");
+ scm_write (k, scm_current_error_port ());
+ fprintf (stderr, ", args: ");
+ scm_write (args, scm_current_error_port ());
+ scm_newline (scm_current_error_port ());
+ }
else
- return scm_call_4 (scm_variable_ref (catch_var), key, thunk, handler,
- pre_unwind_handler);
+ {
+ fprintf (stderr, "Uncaught exception:\n");
+ error_printing_error = 1;
+ scm_handle_by_message (NULL, k, args);
+ }
+
+ /* Normally we don't get here, because scm_handle_by_message will
+ exit. */
+ fprintf (stderr, "Aborting.\n");
+ abort ();
}
+/* A version of scm_abort_to_prompt_star that avoids the need to cons
+ "tag" to "args", because we might be out of memory. */
static void
-init_with_throw_handler_var (void)
+abort_to_prompt (SCM prompt_tag, SCM tag, SCM args)
{
- with_throw_handler_var
- = scm_module_variable (scm_the_root_module (),
- scm_from_latin1_symbol ("with-throw-handler"));
+ SCM *argv;
+ size_t i;
+ long n;
+
+ n = scm_ilength (args) + 1;
+ argv = alloca (sizeof (SCM)*n);
+ argv[0] = tag;
+ for (i = 1; i < n; i++, args = scm_cdr (args))
+ argv[i] = scm_car (args);
+
+ scm_c_abort (scm_the_vm (), prompt_tag, n, argv, NULL);
+
+ /* Oh, what, you're still here? The abort must have been reinstated. Actually,
+ that's quite impossible, given that we're already in C-land here, so...
+ abort! */
+
+ abort ();
+}
+
+static SCM
+throw_without_pre_unwind (SCM tag, SCM args)
+{
+ SCM eh;
+
+ /* This function is not only the boot implementation of "throw", it is
+ also called in response to resource allocation failures such as
+ stack-overflow or out-of-memory. For that reason we need to be
+ careful to avoid allocating memory. */
+ for (eh = scm_fluid_ref (exception_handler_fluid);
+ scm_is_true (eh);
+ eh = scm_c_vector_ref (eh, 0))
+ {
+ SCM catch_key, prompt_tag;
+
+ catch_key = scm_c_vector_ref (eh, 1);
+ if (!scm_is_eq (catch_key, SCM_BOOL_T) && !scm_is_eq (catch_key, tag))
+ continue;
+
+ if (scm_is_true (scm_c_vector_ref (eh, 3)))
+ {
+ const char *key_chars;
+
+ if (scm_i_is_narrow_symbol (tag))
+ key_chars = scm_i_symbol_chars (tag);
+ else
+ key_chars = "(wide symbol)";
+
+ fprintf (stderr, "Warning: Unwind-only `%s' exception; "
+ "skipping pre-unwind handler.\n", key_chars);
+ }
+
+ prompt_tag = scm_c_vector_ref (eh, 2);
+ if (scm_is_true (prompt_tag))
+ abort_to_prompt (prompt_tag, tag, args);
+ }
+
+ default_exception_handler (tag, args);
+ return SCM_UNSPECIFIED;
}
SCM
-scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
+scm_catch (SCM key, SCM thunk, SCM handler)
+{
+ return catch (key, thunk, handler, SCM_UNDEFINED);
+}
+
+SCM
+scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
+ SCM pre_unwind_handler)
{
- static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
- scm_i_pthread_once (&once, init_with_throw_handler_var);
+ return catch (key, thunk, handler, pre_unwind_handler);
+}
- return scm_call_3 (scm_variable_ref (with_throw_handler_var),
- key, thunk, handler);
+SCM
+scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
+{
+ return catch (key, thunk, SCM_UNDEFINED, handler);
}
SCM
int
scm_exit_status (SCM args)
{
- if (!SCM_NULL_OR_NIL_P (args))
+ if (scm_is_pair (args))
{
SCM cqa = SCM_CAR (args);
if (scm_is_integer (cqa))
return (scm_to_int (cqa));
else if (scm_is_false (cqa))
- return 1;
+ return EXIT_FAILURE;
+ else
+ return EXIT_SUCCESS;
}
- return 0;
+ else if (scm_is_null (args))
+ return EXIT_SUCCESS;
+ else
+ /* A type error. Strictly speaking we shouldn't get here. */
+ return EXIT_FAILURE;
}
if (should_print_backtrace (tag, stack))
{
- scm_puts ("Backtrace:\n", p);
+ scm_puts_unlocked ("Backtrace:\n", p);
scm_display_backtrace_with_highlights (stack, p,
SCM_BOOL_F, SCM_BOOL_F,
SCM_EOL);
return scm_throw (key, args);
}
-/* Unfortunately we have to support catch and throw before boot-9 has, um,
- booted. So here are lame versions, which will get replaced with their scheme
- equivalents. */
-
-SCM_SYMBOL (sym_pre_init_catch_tag, "%pre-init-catch-tag");
+SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
+SCM_SYMBOL (scm_out_of_memory_key, "out-of-memory");
-static SCM
-pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
-{
- SCM vm, prompt, res;
+static SCM stack_overflow_args = SCM_BOOL_F;
+static SCM out_of_memory_args = SCM_BOOL_F;
- /* Only handle catch-alls without pre-unwind handlers */
- if (!SCM_UNBNDP (pre_unwind_handler))
- abort ();
- if (scm_is_false (scm_eqv_p (tag, SCM_BOOL_T)))
- abort ();
-
- vm = scm_the_vm ();
- prompt = scm_c_make_prompt (sym_pre_init_catch_tag,
- SCM_VM_DATA (vm)->fp, SCM_VM_DATA (vm)->sp,
- SCM_VM_DATA (vm)->ip, 1, -1, scm_i_dynwinds ());
- scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
-
- if (SCM_PROMPT_SETJMP (prompt))
- {
- /* nonlocal exit */
- SCM args = scm_i_prompt_pop_abort_args_x (vm);
- /* cdr past the continuation */
- return scm_apply_0 (handler, scm_cdr (args));
- }
+/* Since these two functions may be called in response to resource
+ exhaustion, we have to avoid allocating memory. */
- res = scm_call_0 (thunk);
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
-
- return res;
-}
-
-static int
-find_pre_init_catch (void)
+void
+scm_report_stack_overflow (void)
{
- SCM winds;
-
- /* Search the wind list for an appropriate prompt.
- "Waiter, please bring us the wind list." */
- for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = SCM_CDR (winds))
- if (SCM_PROMPT_P (SCM_CAR (winds))
- && scm_is_eq (SCM_PROMPT_TAG (SCM_CAR (winds)), sym_pre_init_catch_tag))
- return 1;
+ if (scm_is_false (stack_overflow_args))
+ abort ();
+ throw_without_pre_unwind (scm_stack_overflow_key, stack_overflow_args);
- return 0;
+ /* Not reached. */
+ abort ();
}
-static SCM
-pre_init_throw (SCM k, SCM args)
+void
+scm_report_out_of_memory (void)
{
- if (find_pre_init_catch ())
- return scm_at_abort (sym_pre_init_catch_tag, scm_cons (k, args));
- else
- {
- static int error_printing_error = 0;
- static int error_printing_fallback = 0;
-
- if (error_printing_fallback)
- fprintf (stderr, "\nFailed to print exception.\n");
- else if (error_printing_error)
- {
- fprintf (stderr, "\nError while printing exception:\n");
- error_printing_fallback = 1;
- fprintf (stderr, "Key: ");
- scm_write (k, scm_current_error_port ());
- fprintf (stderr, ", args: ");
- scm_write (args, scm_current_error_port ());
- scm_newline (scm_current_error_port ());
- }
- else
- {
- fprintf (stderr, "Throw without catch before boot:\n");
- error_printing_error = 1;
- scm_handle_by_message_noexit (NULL, k, args);
- }
+ if (scm_is_false (out_of_memory_args))
+ abort ();
+ throw_without_pre_unwind (scm_out_of_memory_key, out_of_memory_args);
- fprintf (stderr, "Aborting.\n");
- abort ();
- return SCM_BOOL_F; /* not reached */
- }
+ /* Not reached. */
+ abort ();
}
void
tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
- catch_var = scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0,
- pre_init_catch));
+ exception_handler_fluid = scm_make_fluid_with_default (SCM_BOOL_F);
+ /* This binding is later removed when the Scheme definitions of catch,
+ throw, and with-throw-handler are created in boot-9.scm. */
+ scm_c_define ("%exception-handler", exception_handler_fluid);
+
+ scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, catch));
throw_var = scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
- pre_init_throw));
+ throw_without_pre_unwind));
+
+ /* Arguments as if from:
+
+ scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
+
+ We build the arguments manually because we throw without running
+ pre-unwind handlers. (Pre-unwind handlers could rewind the
+ stack.) */
+ stack_overflow_args = scm_list_4 (SCM_BOOL_F,
+ scm_from_latin1_string ("Stack overflow"),
+ SCM_BOOL_F,
+ SCM_BOOL_F);
+ out_of_memory_args = scm_list_4 (SCM_BOOL_F,
+ scm_from_latin1_string ("Out of memory"),
+ SCM_BOOL_F,
+ SCM_BOOL_F);
#include "libguile/throw.x"
}
#ifndef SCM_THROW_H
#define SCM_THROW_H
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2010, 2014 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_with_throw_handler (SCM tag, SCM thunk, SCM handler);
SCM_API SCM scm_ithrow (SCM key, SCM args, int no_return);
+/* This throws to the `stack-overflow' key, without running pre-unwind
+ handlers. */
+SCM_API void scm_report_stack_overflow (void);
+
+/* This throws to the `out-of-memory' key, without running pre-unwind
+ handlers. */
+SCM_API void scm_report_out_of_memory (void);
+
SCM_API SCM scm_throw (SCM key, SCM args);
SCM_INTERNAL void scm_init_throw (void);
unsigned int tortoise_delay)
#define FUNC_NAME s_scm_copy_tree
{
- if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj))
+ if (!scm_is_pair (hare->obj) && !scm_is_vector (hare->obj))
{
return hare->obj;
}
--tortoise_delay;
}
- if (scm_is_simple_vector (hare->obj))
+ if (scm_is_vector (hare->obj))
{
size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013, 2014 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
-
-#define SCM_BUILDING_DEPRECATED_CODE
-
-#include "libguile/_scm.h"
-#include "libguile/__scm.h"
-
-#include "libguile/uniform.h"
-#include "libguile/deprecation.h"
-
-
-const size_t scm_i_array_element_type_sizes[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = {
- 0,
- 0,
- 1,
- 8,
- 8, 8,
- 16, 16,
- 32, 32,
- 64, 64,
- 32, 64,
- 64, 128
-};
-
-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");
-}
-
-const void *
-scm_array_handle_uniform_elements (scm_t_array_handle *h)
-{
- return scm_array_handle_uniform_writable_elements (h);
-}
-
-void *
-scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
-{
- size_t esize;
- scm_t_uint8 *ret;
-
- esize = scm_array_handle_uniform_element_size (h);
- ret = ((scm_t_uint8*) h->writable_elements) + h->base * esize;
- return ret;
-}
-
-#if SCM_ENABLE_DEPRECATED
-
-int
-scm_is_uniform_vector (SCM obj)
-{
- scm_t_array_handle h;
- int ret = 0;
-
- scm_c_issue_deprecation_warning
- ("scm_is_uniform_vector is deprecated. "
- "Use scm_is_bytevector || scm_is_bitvector instead.");
-
- if (scm_is_generalized_vector (obj))
- {
- scm_generalized_vector_get_handle (obj, &h);
- ret = SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type);
- scm_array_handle_release (&h);
- }
- return ret;
-}
-
-size_t
-scm_c_uniform_vector_length (SCM uvec)
-{
- scm_c_issue_deprecation_warning
- ("scm_c_uniform_vector_length is deprecated. "
- "Use scm_c_array_length instead.");
-
- if (!scm_is_uniform_vector (uvec))
- scm_wrong_type_arg_msg ("uniform-vector-length", 1, uvec,
- "uniform vector");
-
- return scm_c_generalized_vector_length (uvec);
-}
-
-SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a uniform vector.")
-#define FUNC_NAME s_scm_uniform_vector_p
-{
- scm_c_issue_deprecation_warning
- ("uniform-vector? is deprecated. Use bytevector? and bitvector?, or "
- "use array-type and array-rank instead.");
-
- return scm_from_bool (scm_is_uniform_vector (obj));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_vector_element_type, "uniform-vector-element-type", 1, 0, 0,
- (SCM 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;
- SCM ret;
-
- scm_c_issue_deprecation_warning
- ("uniform-vector-element-type is deprecated. Use array-type instead.");
-
- 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;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_vector_element_size, "uniform-vector-element-size", 1, 0, 0,
- (SCM v),
- "Return the number of bytes allocated to each element in the\n"
- "uniform vector, @var{v}.")
-#define FUNC_NAME s_scm_uniform_vector_element_size
-{
- scm_t_array_handle h;
- size_t len;
- ssize_t inc;
- SCM ret;
-
- scm_c_issue_deprecation_warning
- ("uniform-vector-element-size is deprecated. Instead, treat the "
- "uniform vector as a bytevector.");
-
- scm_uniform_vector_elements (v, &h, &len, &inc);
- ret = scm_from_size_t (scm_array_handle_uniform_element_size (&h));
- scm_array_handle_release (&h);
- return ret;
-}
-#undef FUNC_NAME
-
-SCM
-scm_c_uniform_vector_ref (SCM v, size_t idx)
-{
- scm_c_issue_deprecation_warning
- ("scm_c_uniform_vector_ref is deprecated. Use scm_c_array_ref_1 instead.");
-
- 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,
- (SCM v, SCM idx),
- "Return the element at index @var{idx} of the\n"
- "homogeneous numeric vector @var{v}.")
-#define FUNC_NAME s_scm_uniform_vector_ref
-{
- scm_c_issue_deprecation_warning
- ("uniform-vector-ref is deprecated. Use array-ref instead.");
-
- return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
-}
-#undef FUNC_NAME
-
-void
-scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
-{
- scm_c_issue_deprecation_warning
- ("scm_c_uniform_vector_set_x is deprecated. Instead, use "
- "scm_c_array_set_1_x, but note the change in the order of the arguments.");
-
- 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,
- (SCM v, SCM idx, SCM val),
- "Set the element at index @var{idx} of the\n"
- "homogeneous numeric vector @var{v} to @var{val}.")
-#define FUNC_NAME s_scm_uniform_vector_set_x
-{
- scm_c_issue_deprecation_warning
- ("uniform-vector-set! is deprecated. Instead, use array-set!, "
- "but note the change in the order of the arguments.");
-
- scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
- (SCM uvec),
- "Convert the uniform numeric vector @var{uvec} to a list.")
-#define FUNC_NAME s_scm_uniform_vector_to_list
-{
- scm_c_issue_deprecation_warning
- ("uniform-vector->list is deprecated. Use array->list instead.");
-
- if (!scm_is_uniform_vector (uvec))
- scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec, "uniform vector");
- return scm_array_to_list (uvec);
-}
-#undef FUNC_NAME
-
-const void *
-scm_uniform_vector_elements (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp, ssize_t *incp)
-{
- scm_c_issue_deprecation_warning
- ("scm_uniform_vector_elements is deprecated. Use "
- "scm_array_handle_uniform_elements instead.");
-
- return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
-}
-
-void *
-scm_uniform_vector_writable_elements (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp, ssize_t *incp)
-{
- void *ret;
-
- scm_c_issue_deprecation_warning
- ("scm_uniform_vector_writable_elements is deprecated. Use "
- "scm_array_handle_uniform_writable_elements instead.");
-
- scm_generalized_vector_get_handle (uvec, h);
- /* FIXME nonlocal exit */
- ret = scm_array_handle_uniform_writable_elements (h);
- if (lenp)
- {
- scm_t_array_dim *dim = scm_array_handle_dims (h);
- *lenp = dim->ubnd - dim->lbnd + 1;
- *incp = dim->inc;
- }
- return ret;
-}
-
-SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
- (SCM v),
- "Return the number of elements in the uniform vector @var{v}.")
-#define FUNC_NAME s_scm_uniform_vector_length
-{
- scm_c_issue_deprecation_warning
- ("uniform-vector-length is deprecated. Use array-length instead.");
-
- return scm_from_size_t (scm_c_uniform_vector_length (v));
-}
-#undef FUNC_NAME
-
-
-#endif /* SCM_ENABLE_DEPRECATED */
-
-
-void
-scm_init_uniform (void)
-{
-#include "libguile/uniform.x"
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013, 2014 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/__scm.h"
+
+#include "libguile/uniform.h"
+
+
+const size_t scm_i_array_element_type_sizes[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = {
+ 0,
+ 0,
+ 1,
+ 8,
+ 8, 8,
+ 16, 16,
+ 32, 32,
+ 64, 64,
+ 32, 64,
+ 64, 128
+};
+
+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");
+}
+
+const void *
+scm_array_handle_uniform_elements (scm_t_array_handle *h)
+{
+ return scm_array_handle_uniform_writable_elements (h);
+}
+
+void *
+scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
+{
+ size_t esize;
+ scm_t_uint8 *ret;
+
+ esize = scm_array_handle_uniform_element_size (h);
+ ret = ((scm_t_uint8*) h->writable_elements) + h->base * esize;
+ return ret;
+}
+
+void
+scm_init_uniform (void)
+{
+#include "libguile/uniform.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
#define SCM_UNIFORM_H
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009,
- * 2014 Free Software Foundation, Inc.
+ * 2013, 2014 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
#include "libguile/__scm.h"
-#include "libguile/generalized-vectors.h"
\f
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);
-#if SCM_ENABLE_DEPRECATED
-
-SCM_DEPRECATED SCM scm_uniform_vector_p (SCM v);
-SCM_DEPRECATED SCM scm_uniform_vector_length (SCM v);
-SCM_DEPRECATED SCM scm_uniform_vector_element_type (SCM v);
-SCM_DEPRECATED SCM scm_uniform_vector_element_size (SCM v);
-SCM_DEPRECATED SCM scm_uniform_vector_ref (SCM v, SCM idx);
-SCM_DEPRECATED SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val);
-SCM_DEPRECATED SCM scm_uniform_vector_to_list (SCM v);
-SCM_DEPRECATED SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd,
- SCM start, SCM end);
-SCM_DEPRECATED SCM scm_uniform_vector_write (SCM v, SCM port_or_fd,
- SCM start, SCM end);
-
-SCM_DEPRECATED int scm_is_uniform_vector (SCM obj);
-SCM_DEPRECATED size_t scm_c_uniform_vector_length (SCM v);
-SCM_DEPRECATED SCM scm_c_uniform_vector_ref (SCM v, size_t idx);
-SCM_DEPRECATED void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val);
-SCM_DEPRECATED const void *scm_uniform_vector_elements (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp,
- ssize_t *incp);
-SCM_DEPRECATED void *scm_uniform_vector_writable_elements (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp,
- ssize_t *incp);
-
-#endif
-
SCM_INTERNAL void scm_init_uniform (void);
+
#endif /* SCM_UNIFORM_H */
/*
#define SCM_VALIDATE_H
/* Copyright (C) 1999, 2000, 2001, 2002, 2004, 2006, 2007, 2009,
- * 2012 Free Software Foundation, Inc.
+ * 2011, 2012, 2013, 2014 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_VARIABLE(pos, var) SCM_MAKE_VALIDATE_MSG (pos, var, VARIABLEP, "variable")
-#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, MEMOIZED_P, "memoized code")
-
#define SCM_VALIDATE_PROC(pos, proc) \
do { \
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \
#define SCM_VALIDATE_ARRAY(pos, v) \
do { \
- SCM_ASSERT (!SCM_IMP (v) \
+ SCM_ASSERT (SCM_HEAP_OBJECT_P (v) \
&& scm_is_true (scm_array_p (v, SCM_UNDEFINED)), \
v, pos, FUNC_NAME); \
} while (0)
#define SCM_VALIDATE_VECTOR(pos, v) \
do { \
- SCM_ASSERT (scm_is_simple_vector (v), v, pos, FUNC_NAME); \
+ SCM_ASSERT (scm_is_vector (v), v, pos, FUNC_NAME); \
} while (0)
#define SCM_VALIDATE_VECTOR_OR_DVECTOR(pos, v) \
do { \
- SCM_ASSERT ((scm_is_simple_vector (v) \
- || (scm_is_true (scm_f64vector_p (v)))), \
+ SCM_ASSERT (scm_is_vector (v) || scm_is_true (scm_f64vector_p (v)), \
v, pos, FUNC_NAME); \
} while (0)
SCM port = SCM_PORT_WITH_PS_PORT (pwps);
scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps));
- scm_puts ("#<values ", port);
+ scm_puts_unlocked ("#<values ", port);
scm_iprin1 (values, port, ps);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return SCM_UNSPECIFIED;
}
void
scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<variable ", port);
+ scm_puts_unlocked ("#<variable ", port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_puts (" value: ", port);
+ scm_puts_unlocked (" value: ", port);
scm_iprin1 (SCM_VARIABLE_REF (exp), port, pstate);
- scm_putc('>', port);
+ scm_putc_unlocked('>', port);
}
\f
#ifndef SCM_VARIABLE_H
#define SCM_VARIABLE_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
/* Variables
*/
-#define SCM_VARIABLEP(X) (!SCM_IMP (X) && SCM_TYP7(X) == scm_tc7_variable)
+#define SCM_VARIABLEP(X) (SCM_HAS_TYP7 (X, scm_tc7_variable))
#define SCM_VARIABLE_REF(V) SCM_CELL_OBJECT_1 (V)
#define SCM_VARIABLE_SET(V, X) SCM_SET_CELL_OBJECT_1 (V, X)
#define SCM_VARIABLE_LOC(V) (SCM_CELL_OBJECT_LOC ((V), 1))
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/dynwind.h"
-#include "libguile/deprecation.h"
#include "libguile/bdw-gc.h"
int
scm_is_vector (SCM obj)
{
- if (SCM_I_IS_NONWEAK_VECTOR (obj))
- return 1;
- if (SCM_I_WVECTP (obj))
- {
- scm_c_issue_deprecation_warning
- ("Expecting vector? to be true for weak vectors is deprecated. "
- "Use weak-vector? instead.");
- return 1;
- }
- if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
- {
- SCM v = SCM_I_ARRAY_V (obj);
- if (SCM_I_IS_VECTOR (v))
- {
- scm_c_issue_deprecation_warning
- ("Expecting vector? to be true for rank-1 arrays is deprecated. "
- "Use array?, array-rank, and array-type instead.");
- return 1;
- }
- return 0;
- }
- return 0;
+ return SCM_I_IS_VECTOR (obj);
}
int
scm_is_simple_vector (SCM obj)
{
- if (SCM_I_IS_NONWEAK_VECTOR (obj))
- return 1;
- if (SCM_I_WVECTP (obj))
- {
- scm_c_issue_deprecation_warning
- ("Expecting scm_is_simple_vector to be true for weak vectors is "
- "deprecated. Use scm_is_weak_vector instead.");
- return 1;
- }
- return 0;
+ return SCM_I_IS_VECTOR (obj);
}
const SCM *
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_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
scm_generalized_vector_get_handle (vec, h);
if (lenp)
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_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
scm_generalized_vector_get_handle (vec, h);
if (lenp)
}
#undef FUNC_NAME
-SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length);
-/* Returns the number of elements in @var{vector} as an exact integer. */
-SCM
-scm_vector_length (SCM v)
+SCM_DEFINE (scm_vector_length, "vector-length", 1, 0, 0,
+ (SCM v),
+ "Returns the number of elements in @var{vector} as an exact integer.")
+#define FUNC_NAME s_scm_vector_length
{
- if (SCM_I_IS_VECTOR (v))
- {
- if (SCM_I_WVECTP (v))
- scm_c_issue_deprecation_warning
- ("Using vector-length on weak vectors is deprecated. "
- "Use weak-vector-length from (ice-9 weak-vectors) instead.");
- return scm_from_size_t (SCM_I_VECTOR_LENGTH (v));
- }
- else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
- {
- scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
- scm_c_issue_deprecation_warning
- ("Using vector-length on arrays is deprecated. "
- "Use array-length instead.");
- return scm_from_size_t (dim->ubnd - dim->lbnd + 1);
- }
- else if (SCM_UNPACK (g_vector_length))
- {
- scm_c_issue_deprecation_warning
- ("Using vector-length as a primitive-generic is deprecated.");
- return scm_call_generic_1 (g_vector_length, v);
- }
- else
- {
- scm_wrong_type_arg_msg ("vector-length", 1, v, "vector");
- return SCM_UNDEFINED; /* not reached */
- }
+ return scm_from_size_t (scm_c_vector_length (v));
}
+#undef FUNC_NAME
size_t
scm_c_vector_length (SCM v)
+#define FUNC_NAME s_scm_vector_length
{
- if (SCM_I_IS_NONWEAK_VECTOR (v))
- return SCM_I_VECTOR_LENGTH (v);
- else
- return scm_to_size_t (scm_vector_length (v));
+ SCM_VALIDATE_VECTOR (1, v);
+
+ return SCM_I_VECTOR_LENGTH (v);
}
+#undef FUNC_NAME
SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
/*
}
#undef FUNC_NAME
-SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref);
-
-/*
- "@var{k} must be a valid index of @var{vector}.\n"
- "@samp{Vector-ref} returns the contents of element @var{k} of\n"
- "@var{vector}.\n\n"
- "@lisp\n"
- "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
- "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
- " (let ((i (round (* 2 (acos -1)))))\n"
- " (if (inexact? i)\n"
- " (inexact->exact i)\n"
- " i))) @result{} 13\n"
- "@end lisp"
-*/
-
-SCM
-scm_vector_ref (SCM v, SCM k)
-#define FUNC_NAME s_vector_ref
+SCM_DEFINE (scm_vector_ref, "vector-ref", 2, 0, 0,
+ (SCM vector, SCM k),
+ "@var{k} must be a valid index of @var{vector}.\n"
+ "@samp{Vector-ref} returns the contents of element @var{k} of\n"
+ "@var{vector}.\n\n"
+ "@lisp\n"
+ "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
+ "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
+ " (let ((i (round (* 2 (acos -1)))))\n"
+ " (if (inexact? i)\n"
+ " (inexact->exact i)\n"
+ " i))) @result{} 13\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_vector_ref
{
- return scm_c_vector_ref (v, scm_to_size_t (k));
+ return scm_c_vector_ref (vector, scm_to_size_t (k));
}
#undef FUNC_NAME
SCM
scm_c_vector_ref (SCM v, size_t k)
+#define FUNC_NAME s_scm_vector_ref
{
- if (SCM_I_IS_NONWEAK_VECTOR (v))
- {
- register SCM elt;
+ SCM_VALIDATE_VECTOR (1, v);
- if (k >= SCM_I_VECTOR_LENGTH (v))
- scm_out_of_range (NULL, scm_from_size_t (k));
- elt = (SCM_I_VECTOR_ELTS(v))[k];
+ if (k >= SCM_I_VECTOR_LENGTH (v))
+ scm_out_of_range (NULL, scm_from_size_t (k));
- return elt;
- }
- else if (SCM_I_WVECTP (v))
- {
- scm_c_issue_deprecation_warning
- ("Using vector-ref on weak vectors is deprecated. "
- "Instead, use weak-vector-ref from (ice-9 weak-vectors).");
- return scm_c_weak_vector_ref (v, k);
- }
- else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
- {
- scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
- SCM vv = SCM_I_ARRAY_V (v);
- if (SCM_I_IS_VECTOR (vv))
- {
- register SCM elt;
-
- scm_c_issue_deprecation_warning
- ("Using vector-ref on arrays is deprecated. "
- "Use array-ref instead.");
-
- 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;
- elt = (SCM_I_VECTOR_ELTS (vv))[k];
-
- if (SCM_UNPACK (elt) == 0 && (SCM_I_WVECTP (vv)))
- {
- scm_c_issue_deprecation_warning
- ("Weak arrays are deprecated. Use weak vectors instead.");
- /* 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");
- }
- else if (SCM_UNPACK (g_vector_ref))
- {
- scm_c_issue_deprecation_warning
- ("Using vector-ref as a primitive-generic is deprecated.");
- return scm_call_generic_2 (g_vector_ref, v, scm_from_size_t (k));
- }
- else
- {
- scm_wrong_type_arg_msg ("vector-ref", 1, v, "vector");
- return SCM_UNDEFINED; /* not reached */
- }
+ return SCM_SIMPLE_VECTOR_REF (v, k);
}
+#undef FUNC_NAME
-SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x);
-
-/* "@var{k} must be a valid index of @var{vector}.\n"
- "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
- "The value returned by @samp{vector-set!} is unspecified.\n"
- "@lisp\n"
- "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
- " (vector-set! vec 1 '("Sue" "Sue"))\n"
- " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n"
- "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
- "@end lisp"
-*/
-
-SCM
-scm_vector_set_x (SCM v, SCM k, SCM obj)
-#define FUNC_NAME s_vector_set_x
+SCM_DEFINE (scm_vector_set_x, "vector-set!", 3, 0, 0,
+ (SCM vector, SCM k, SCM obj),
+ "@var{k} must be a valid index of @var{vector}.\n"
+ "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
+ "The value returned by @samp{vector-set!} is unspecified.\n"
+ "@lisp\n"
+ "(let ((vec (vector 0 '(2 2 2 2) \"Anna\")))\n"
+ " (vector-set! vec 1 '(\"Sue\" \"Sue\"))\n"
+ " vec) @result{} #(0 (\"Sue\" \"Sue\") \"Anna\")\n"
+ "(vector-set! '#(0 1 2) 1 \"doe\") @result{} @emph{error} ; constant vector\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_vector_set_x
{
- scm_c_vector_set_x (v, scm_to_size_t (k), obj);
+ scm_c_vector_set_x (vector, scm_to_size_t (k), obj);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
void
scm_c_vector_set_x (SCM v, size_t k, SCM obj)
+#define FUNC_NAME s_scm_vector_set_x
{
- if (SCM_I_IS_NONWEAK_VECTOR (v))
- {
- if (k >= SCM_I_VECTOR_LENGTH (v))
- scm_out_of_range (NULL, scm_from_size_t (k));
- (SCM_I_VECTOR_WELTS(v))[k] = obj;
- }
- else if (SCM_I_WVECTP (v))
- {
- scm_c_issue_deprecation_warning
- ("Using vector-set! on weak vectors is deprecated. "
- "Instead, use weak-vector-set! from (ice-9 weak-vectors).");
- scm_c_weak_vector_set_x (v, k, obj);
- }
- else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
- {
- scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
- SCM vv = SCM_I_ARRAY_V (v);
- if (SCM_I_IS_VECTOR (vv))
- {
- scm_c_issue_deprecation_warning
- ("Using vector-set! on arrays is deprecated. "
- "Use array-set! instead, but note the change in argument order.");
-
- 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;
- (SCM_I_VECTOR_WELTS (vv))[k] = obj;
-
- if (SCM_I_WVECTP (vv))
- {
- /* Make it a weak pointer. */
- SCM *link = & SCM_I_VECTOR_WELTS (vv)[k];
- SCM_I_REGISTER_DISAPPEARING_LINK ((void **) link, SCM2PTR (obj));
- scm_c_issue_deprecation_warning
- ("Weak arrays are deprecated. Use weak vectors instead.");
- }
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
- }
- else if (SCM_UNPACK (g_vector_set_x))
- {
- scm_c_issue_deprecation_warning
- ("Using vector-set! as a primitive-generic is deprecated.");
- scm_call_3 (g_vector_set_x, v, scm_from_size_t (k), obj);
- }
- else
- scm_wrong_type_arg_msg ("vector-set!", 1, v, "vector");
+ SCM_VALIDATE_VECTOR (1, v);
+
+ if (k >= SCM_I_VECTOR_LENGTH (v))
+ scm_out_of_range (NULL, scm_from_size_t (k));
+
+ SCM_SIMPLE_VECTOR_SET (v, k, obj);
}
+#undef FUNC_NAME
SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
(SCM k, SCM fill),
scm_c_make_vector (size_t k, SCM fill)
#define FUNC_NAME s_scm_make_vector
{
- SCM *vector;
-
- vector = (SCM *)
- scm_gc_malloc ((k + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM),
- "vector");
-
- if (k > 0)
- {
- SCM *base;
- unsigned long int j;
+ SCM vector;
+ unsigned long int j;
- SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH);
+ SCM_ASSERT_RANGE (1, scm_from_size_t (k), k <= VECTOR_MAX_LENGTH);
- base = vector + SCM_I_VECTOR_HEADER_SIZE;
- for (j = 0; j != k; ++j)
- base[j] = fill;
- }
+ vector = scm_words ((k << 8) | scm_tc7_vector, k + 1);
- ((scm_t_bits *) vector)[0] = (k << 8) | scm_tc7_vector;
- ((scm_t_bits *) vector)[1] = 0;
+ for (j = 0; j < k; ++j)
+ SCM_SIMPLE_VECTOR_SET (vector, j, fill);
- return PTR2SCM (vector);
+ return vector;
}
#undef FUNC_NAME
#undef FUNC_NAME
\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 *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);
-}
-
-/* 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_make_weak_vector (scm_t_bits type, SCM size, SCM fill)
-{
- 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;
-
- 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++)
- {
- *elt = SCM_CAR (lst);
- }
-
- 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"
#undef FUNC_NAME
\f
-static SCM
-vector_handle_ref (scm_t_array_handle *h, size_t idx)
-{
- if (idx > h->dims[0].ubnd)
- scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
- return ((SCM*)h->elements)[idx];
-}
-
-static void
-vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
-{
- if (idx > h->dims[0].ubnd)
- scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
- ((SCM*)h->writable_elements)[idx] = val;
-}
-
-static void
-vector_get_handle (SCM v, scm_t_array_handle *h)
-{
- h->array = v;
- h->ndims = 1;
- h->dims = &h->dim0;
- h->dim0.lbnd = 0;
- h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM;
- h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v);
-}
-
-/* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change
- tags.h. */
-SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2,
- vector_handle_ref, vector_handle_set,
- vector_get_handle)
SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector)
#ifndef SCM_VECTORS_H
#define SCM_VECTORS_H
-/* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006, 2008, 2009, 2011, 2014 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
/* 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_IS_NONWEAK_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7(x)==scm_tc7_vector))
+#define SCM_I_IS_VECTOR(x) (SCM_HAS_TYP7 (x, scm_tc7_vector))
#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_WELTS(x) (SCM_CELL_OBJECT_LOC (x, 1))
#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
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. */
-
-#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_1 (x))
-#define SCM_I_SET_WVECT_EXTRA(x, t) (SCM_SET_CELL_WORD_1 ((x),(t)))
-
-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);
--- /dev/null
+/* Copyright (C) 2013 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_VM_BUILTINS_H_
+#define _SCM_VM_BUILTINS_H_
+
+#ifdef BUILDING_LIBGUILE
+
+#define FOR_EACH_VM_BUILTIN(M) \
+ M(apply, APPLY, 2, 0, 1) \
+ M(values, VALUES, 0, 0, 1) \
+ M(abort_to_prompt, ABORT_TO_PROMPT, 1, 0, 1) \
+ M(call_with_values, CALL_WITH_VALUES, 2, 0, 0) \
+ M(call_with_current_continuation, CALL_WITH_CURRENT_CONTINUATION, 1, 0, 0)
+
+/* These enumerated values are embedded in VM code, and as such are
+ part of Guile's ABI. */
+enum scm_vm_builtins
+{
+#define ENUM(builtin, BUILTIN, req, opt, rest) SCM_VM_BUILTIN_##BUILTIN,
+ FOR_EACH_VM_BUILTIN(ENUM)
+#undef ENUM
+ SCM_VM_BUILTIN_COUNT
+};
+
+SCM_INTERNAL SCM scm_vm_builtin_name_to_index (SCM name);
+SCM_INTERNAL SCM scm_vm_builtin_index_to_name (SCM idx);
+SCM_INTERNAL void scm_init_vm_builtin_properties (void);
+
+#endif /* BUILDING_LIBGUILE */
+
+#endif /* _SCM_VM_BUILTINS_H_ */
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * 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
- */
-
-/* This file is included in vm.c multiple times */
-
-#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
-#define VM_USE_HOOKS 0 /* Various hooks */
-#define VM_CHECK_OBJECT 0 /* Check object table */
-#define VM_CHECK_FREE_VARIABLES 0 /* Check free variable access */
-#define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */
-#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
-#define VM_USE_HOOKS 1
-#define VM_CHECK_OBJECT 0
-#define VM_CHECK_FREE_VARIABLES 0
-#define VM_CHECK_UNDERFLOW 0 /* Check underflow when popping values */
-#else
-#error unknown debug engine VM_ENGINE
-#endif
-
-#include "vm-engine.h"
-
-
-static SCM
-VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
-{
- /* VM registers */
- register scm_t_uint8 *ip IP_REG; /* instruction pointer */
- register SCM *sp SP_REG; /* stack pointer */
- register SCM *fp FP_REG; /* frame pointer */
- struct scm_vm *vp = SCM_VM_DATA (vm);
-
- /* Cache variables */
- struct scm_objcode *bp = NULL; /* program base pointer */
- SCM *objects = NULL; /* constant objects */
-#if VM_CHECK_OBJECT
- size_t object_count = 0; /* length of OBJECTS */
-#endif
- SCM *stack_limit = vp->stack_limit; /* stack limit address */
-
- scm_i_thread *current_thread = SCM_I_CURRENT_THREAD;
- scm_t_int64 vm_cookie = vp->cookie++;
-
- /* Internal variables */
- int nvalues = 0;
-
-#ifdef HAVE_LABELS_AS_VALUES
- static const void **jump_table_pointer = NULL;
-#endif
-
-#ifdef HAVE_LABELS_AS_VALUES
- register const void **jump_table JT_REG;
-
- if (SCM_UNLIKELY (!jump_table_pointer))
- {
- int i;
- jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*));
- for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
- jump_table_pointer[i] = &&vm_error_bad_instruction;
-#define VM_INSTRUCTION_TO_LABEL 1
-#define jump_table jump_table_pointer
-#include <libguile/vm-expand.h>
-#include <libguile/vm-i-system.i>
-#include <libguile/vm-i-scheme.i>
-#include <libguile/vm-i-loader.i>
-#undef jump_table
-#undef VM_INSTRUCTION_TO_LABEL
- }
-
- /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
- load instruction at each instruction dispatch. */
- jump_table = jump_table_pointer;
-#endif
-
- /* Initial frame */
- CACHE_REGISTER ();
- PUSH (SCM_PACK (fp)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (ip)); /* ra */
- PUSH (boot_continuation);
- fp = sp + 1;
- ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));
-
- /* MV-call frame, function & arguments */
- PUSH (SCM_PACK (fp)); /* dynamic link */
- PUSH (SCM_PACK (ip + 1)); /* mvra */
- PUSH (SCM_PACK (ip)); /* ra */
- PUSH (program);
- fp = sp + 1;
- VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
- while (nargs--)
- PUSH (*argv++);
-
- PUSH_CONTINUATION_HOOK ();
-
- apply:
- program = fp[-1];
- if (!SCM_PROGRAM_P (program))
- {
- if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
- fp[-1] = SCM_STRUCT_PROCEDURE (program);
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
- && SCM_SMOB_APPLICABLE_P (program))
- {
- /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
- int i;
- PUSH (SCM_BOOL_F);
- for (i = sp - fp; i >= 0; i--)
- fp[i] = fp[i - 1];
- fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline_objcode;
- }
- else
- {
- SYNC_ALL();
- vm_error_wrong_type_apply (program);
- }
- goto apply;
- }
-
- CACHE_PROGRAM ();
- ip = SCM_C_OBJCODE_BASE (bp);
-
- APPLY_HOOK ();
-
- /* Let's go! */
- NEXT;
-
-#ifndef HAVE_LABELS_AS_VALUES
- vm_start:
- switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
-#endif
-
-#include "vm-expand.h"
-#include "vm-i-system.c"
-#include "vm-i-scheme.c"
-#include "vm-i-loader.c"
-
-#ifndef HAVE_LABELS_AS_VALUES
- default:
- goto vm_error_bad_instruction;
- }
-#endif
-
- abort (); /* never reached */
-
- vm_error_bad_instruction:
- vm_error_bad_instruction (ip[-1]);
- abort (); /* never reached */
-
- handle_overflow:
- SYNC_ALL ();
- vm_error_stack_overflow (vp);
- abort (); /* never reached */
-}
-
-#undef VM_USE_HOOKS
-#undef VM_CHECK_OBJECT
-#undef VM_CHECK_FREE_VARIABLE
-#undef VM_CHECK_UNDERFLOW
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013,
+ * 2014, 2015 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
+ */
+
+/* This file is included in vm.c multiple times. */
+
+
+#define UNPACK_8_8_8(op,a,b,c) \
+ do \
+ { \
+ a = (op >> 8) & 0xff; \
+ b = (op >> 16) & 0xff; \
+ c = op >> 24; \
+ } \
+ while (0)
+
+#define UNPACK_8_16(op,a,b) \
+ do \
+ { \
+ a = (op >> 8) & 0xff; \
+ b = op >> 16; \
+ } \
+ while (0)
+
+#define UNPACK_16_8(op,a,b) \
+ do \
+ { \
+ a = (op >> 8) & 0xffff; \
+ b = op >> 24; \
+ } \
+ while (0)
+
+#define UNPACK_12_12(op,a,b) \
+ do \
+ { \
+ a = (op >> 8) & 0xfff; \
+ b = op >> 20; \
+ } \
+ while (0)
+
+#define UNPACK_24(op,a) \
+ do \
+ { \
+ a = op >> 8; \
+ } \
+ while (0)
+
+
+/* Assign some registers by hand. There used to be a bigger list here,
+ but it was never tested, and in the case of x86-32, was a source of
+ compilation failures. It can be revived if it's useful, but my naive
+ hope is that simply annotating the locals with "register" will be a
+ sufficient hint to the compiler. */
+#ifdef __GNUC__
+# if defined __x86_64__
+/* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
+ well. Tell it to keep the jump table in a r12, which is
+ callee-saved. */
+# define JT_REG asm ("r12")
+# endif
+#endif
+
+#ifndef IP_REG
+# define IP_REG
+#endif
+#ifndef FP_REG
+# define FP_REG
+#endif
+#ifndef JT_REG
+# define JT_REG
+#endif
+
+#define VM_ASSERT(condition, handler) \
+ do { \
+ if (SCM_UNLIKELY (!(condition))) \
+ { \
+ SYNC_IP(); \
+ handler; \
+ } \
+ } while (0)
+
+#ifdef VM_ENABLE_ASSERTIONS
+# define ASSERT(condition) VM_ASSERT (condition, abort())
+#else
+# define ASSERT(condition)
+#endif
+
+#if VM_USE_HOOKS
+#define RUN_HOOK(exp) \
+ do { \
+ if (SCM_UNLIKELY (vp->trace_level > 0)) \
+ { \
+ SYNC_IP (); \
+ exp; \
+ CACHE_FP (); \
+ } \
+ } while (0)
+#else
+#define RUN_HOOK(exp)
+#endif
+#define RUN_HOOK0(h) RUN_HOOK (vm_dispatch_##h##_hook (vp))
+#define RUN_HOOK1(h, arg) RUN_HOOK (vm_dispatch_##h##_hook (vp, arg))
+
+#define APPLY_HOOK() \
+ RUN_HOOK0 (apply)
+#define PUSH_CONTINUATION_HOOK() \
+ RUN_HOOK0 (push_continuation)
+#define POP_CONTINUATION_HOOK(old_fp) \
+ RUN_HOOK1 (pop_continuation, old_fp)
+#define NEXT_HOOK() \
+ RUN_HOOK0 (next)
+#define ABORT_CONTINUATION_HOOK() \
+ RUN_HOOK0 (abort)
+
+#define VM_HANDLE_INTERRUPTS \
+ SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, SYNC_IP (), CACHE_FP ())
+
+
+/* Virtual Machine
+
+ The VM has three state bits: the instruction pointer (IP), the frame
+ pointer (FP), and the top-of-stack pointer (SP). We cache the first
+ two of these in machine registers, local to the VM, because they are
+ used extensively by the VM. As the SP is used more by code outside
+ the VM than by the VM itself, we don't bother caching it locally.
+
+ Since the FP changes infrequently, relative to the IP, we keep vp->fp
+ in sync with the local FP. This would be a big lose for the IP,
+ though, so instead of updating vp->ip all the time, we call SYNC_IP
+ whenever we would need to know the IP of the top frame. In practice,
+ we need to SYNC_IP whenever we call out of the VM to a function that
+ would like to walk the stack, perhaps as the result of an
+ exception.
+
+ One more thing. We allow the stack to move, when it expands.
+ Therefore if you call out to a C procedure that could call Scheme
+ code, or otherwise push anything on the stack, you will need to
+ CACHE_FP afterwards to restore the possibly-changed FP. */
+
+#define SYNC_IP() vp->ip = (ip)
+
+#define CACHE_FP() fp = (vp->fp)
+#define CACHE_REGISTER() \
+ do { \
+ ip = vp->ip; \
+ fp = vp->fp; \
+ } while (0)
+
+
+/* Reserve stack space for a frame. Will check that there is sufficient
+ stack space for N locals, including the procedure. Invoke after
+ preparing the new frame and setting the fp and ip.
+
+ If there is not enough space for this frame, we try to expand the
+ stack, possibly relocating it somewhere else in the address space.
+ Because of the possible relocation, no pointer into the stack besides
+ FP is valid across an ALLOC_FRAME call. Be careful! */
+#define ALLOC_FRAME(n) \
+ do { \
+ SCM *new_sp = LOCAL_ADDRESS (n - 1); \
+ if (new_sp > vp->sp_max_since_gc) \
+ { \
+ if (SCM_UNLIKELY (new_sp >= vp->stack_limit)) \
+ { \
+ SYNC_IP (); \
+ vm_expand_stack (vp, new_sp); \
+ CACHE_FP (); \
+ } \
+ else \
+ vp->sp_max_since_gc = vp->sp = new_sp; \
+ } \
+ else \
+ vp->sp = new_sp; \
+ } while (0)
+
+/* Reset the current frame to hold N locals. Used when we know that no
+ stack expansion is needed. */
+#define RESET_FRAME(n) \
+ do { \
+ vp->sp = LOCAL_ADDRESS (n - 1); \
+ if (vp->sp > vp->sp_max_since_gc) \
+ vp->sp_max_since_gc = vp->sp; \
+ } while (0)
+
+/* Compute the number of locals in the frame. At a call, this is equal
+ to the number of actual arguments when a function is first called,
+ plus one for the function. */
+#define FRAME_LOCALS_COUNT_FROM(slot) \
+ (vp->sp + 1 - LOCAL_ADDRESS (slot))
+#define FRAME_LOCALS_COUNT() \
+ FRAME_LOCALS_COUNT_FROM (0)
+
+/* Restore registers after returning from a frame. */
+#define RESTORE_FRAME() \
+ do { \
+ } while (0)
+
+
+#ifdef HAVE_LABELS_AS_VALUES
+# define BEGIN_DISPATCH_SWITCH /* */
+# define END_DISPATCH_SWITCH /* */
+# define NEXT(n) \
+ do \
+ { \
+ ip += n; \
+ NEXT_HOOK (); \
+ op = *ip; \
+ goto *jump_table[op & 0xff]; \
+ } \
+ while (0)
+# define VM_DEFINE_OP(opcode, tag, name, meta) \
+ op_##tag:
+#else
+# define BEGIN_DISPATCH_SWITCH \
+ vm_start: \
+ NEXT_HOOK (); \
+ op = *ip; \
+ switch (op & 0xff) \
+ {
+# define END_DISPATCH_SWITCH \
+ }
+# define NEXT(n) \
+ do \
+ { \
+ ip += n; \
+ goto vm_start; \
+ } \
+ while (0)
+# define VM_DEFINE_OP(opcode, tag, name, meta) \
+ op_##tag: \
+ case opcode:
+#endif
+
+#define LOCAL_ADDRESS(i) (&SCM_FRAME_LOCAL (fp, i))
+#define LOCAL_REF(i) SCM_FRAME_LOCAL (fp, i)
+#define LOCAL_SET(i,o) SCM_FRAME_LOCAL (fp, i) = o
+
+#define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
+#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
+#define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
+
+#define RETURN_ONE_VALUE(ret) \
+ do { \
+ SCM val = ret; \
+ SCM *old_fp; \
+ VM_HANDLE_INTERRUPTS; \
+ old_fp = fp; \
+ ip = SCM_FRAME_RETURN_ADDRESS (fp); \
+ fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \
+ /* Clear frame. */ \
+ old_fp[-1] = SCM_BOOL_F; \
+ old_fp[-2] = SCM_BOOL_F; \
+ /* Leave proc. */ \
+ SCM_FRAME_LOCAL (old_fp, 1) = val; \
+ vp->sp = &SCM_FRAME_LOCAL (old_fp, 1); \
+ POP_CONTINUATION_HOOK (old_fp); \
+ NEXT (0); \
+ } while (0)
+
+/* While we could generate the list-unrolling code here, it's fine for
+ now to just tail-call (apply values vals). */
+#define RETURN_VALUE_LIST(vals_) \
+ do { \
+ SCM vals = vals_; \
+ VM_HANDLE_INTERRUPTS; \
+ fp[0] = vm_builtin_apply; \
+ fp[1] = vm_builtin_values; \
+ fp[2] = vals; \
+ RESET_FRAME (3); \
+ ip = (scm_t_uint32 *) vm_builtin_apply_code; \
+ goto op_tail_apply; \
+ } while (0)
+
+#define BR_NARGS(rel) \
+ scm_t_uint32 expected; \
+ UNPACK_24 (op, expected); \
+ if (FRAME_LOCALS_COUNT() rel expected) \
+ { \
+ scm_t_int32 offset = ip[1]; \
+ offset >>= 8; /* Sign-extending shift. */ \
+ NEXT (offset); \
+ } \
+ NEXT (2)
+
+#define BR_UNARY(x, exp) \
+ scm_t_uint32 test; \
+ SCM x; \
+ UNPACK_24 (op, test); \
+ x = LOCAL_REF (test); \
+ if ((ip[1] & 0x1) ? !(exp) : (exp)) \
+ { \
+ scm_t_int32 offset = ip[1]; \
+ offset >>= 8; /* Sign-extending shift. */ \
+ if (offset <= 0) \
+ VM_HANDLE_INTERRUPTS; \
+ NEXT (offset); \
+ } \
+ NEXT (2)
+
+#define BR_BINARY(x, y, exp) \
+ scm_t_uint16 a, b; \
+ SCM x, y; \
+ UNPACK_12_12 (op, a, b); \
+ x = LOCAL_REF (a); \
+ y = LOCAL_REF (b); \
+ if ((ip[1] & 0x1) ? !(exp) : (exp)) \
+ { \
+ scm_t_int32 offset = ip[1]; \
+ offset >>= 8; /* Sign-extending shift. */ \
+ if (offset <= 0) \
+ VM_HANDLE_INTERRUPTS; \
+ NEXT (offset); \
+ } \
+ NEXT (2)
+
+#define BR_ARITHMETIC(crel,srel) \
+ { \
+ scm_t_uint16 a, b; \
+ SCM x, y; \
+ UNPACK_12_12 (op, a, b); \
+ x = LOCAL_REF (a); \
+ y = LOCAL_REF (b); \
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
+ { \
+ scm_t_signed_bits x_bits = SCM_UNPACK (x); \
+ scm_t_signed_bits y_bits = SCM_UNPACK (y); \
+ if ((ip[1] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \
+ { \
+ scm_t_int32 offset = ip[1]; \
+ offset >>= 8; /* Sign-extending shift. */ \
+ if (offset <= 0) \
+ VM_HANDLE_INTERRUPTS; \
+ NEXT (offset); \
+ } \
+ NEXT (2); \
+ } \
+ else \
+ { \
+ SCM res; \
+ SYNC_IP (); \
+ res = srel (x, y); \
+ CACHE_FP (); \
+ if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \
+ { \
+ scm_t_int32 offset = ip[1]; \
+ offset >>= 8; /* Sign-extending shift. */ \
+ if (offset <= 0) \
+ VM_HANDLE_INTERRUPTS; \
+ NEXT (offset); \
+ } \
+ NEXT (2); \
+ } \
+ }
+
+#define ARGS1(a1) \
+ scm_t_uint16 dst, src; \
+ SCM a1; \
+ UNPACK_12_12 (op, dst, src); \
+ a1 = LOCAL_REF (src)
+#define ARGS2(a1, a2) \
+ scm_t_uint8 dst, src1, src2; \
+ SCM a1, a2; \
+ UNPACK_8_8_8 (op, dst, src1, src2); \
+ a1 = LOCAL_REF (src1); \
+ a2 = LOCAL_REF (src2)
+#define RETURN(x) \
+ do { LOCAL_SET (dst, x); NEXT (1); } while (0)
+#define RETURN_EXP(exp) \
+ do { SCM __x; SYNC_IP (); __x = exp; CACHE_FP (); RETURN (__x); } while (0)
+
+/* The maximum/minimum tagged integers. */
+#define INUM_MAX \
+ ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
+#define INUM_MIN \
+ ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
+#define INUM_STEP \
+ ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
+ - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
+
+#define BINARY_INTEGER_OP(CFUNC,SFUNC) \
+ { \
+ ARGS2 (x, y); \
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
+ { \
+ scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
+ if (SCM_FIXABLE (n)) \
+ RETURN (SCM_I_MAKINUM (n)); \
+ } \
+ RETURN_EXP (SFUNC (x, y)); \
+ }
+
+#define VM_VALIDATE_PAIR(x, proc) \
+ VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
+
+#define VM_VALIDATE_STRUCT(obj, proc) \
+ VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj))
+
+#define VM_VALIDATE_BYTEVECTOR(x, proc) \
+ VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
+
+/* Return true (non-zero) if PTR has suitable alignment for TYPE. */
+#define ALIGNED_P(ptr, type) \
+ ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
+
+static SCM
+VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
+ scm_i_jmp_buf *registers, int resume)
+{
+ /* Instruction pointer: A pointer to the opcode that is currently
+ running. */
+ register scm_t_uint32 *ip IP_REG;
+
+ /* Frame pointer: A pointer into the stack, off of which we index
+ arguments and local variables. Pushed at function calls, popped on
+ returns. */
+ register SCM *fp FP_REG;
+
+ /* Current opcode: A cache of *ip. */
+ register scm_t_uint32 op;
+
+#ifdef HAVE_LABELS_AS_VALUES
+ static const void *jump_table_[256] = {
+#define LABEL_ADDR(opcode, tag, name, meta) &&op_##tag,
+ FOR_EACH_VM_OPERATION(LABEL_ADDR)
+#undef LABEL_ADDR
+ };
+ register const void **jump_table JT_REG;
+ /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one
+ load instruction at each instruction dispatch. */
+ jump_table = jump_table_;
+#endif
+
+ /* Load VM registers. */
+ CACHE_REGISTER ();
+
+ VM_HANDLE_INTERRUPTS;
+
+ /* Usually a call to the VM happens on application, with the boot
+ continuation on the next frame. Sometimes it happens after a
+ non-local exit however; in that case the VM state is all set up,
+ and we have but to jump to the next opcode. */
+ if (SCM_UNLIKELY (resume))
+ NEXT (0);
+
+ apply:
+ while (!SCM_PROGRAM_P (LOCAL_REF (0)))
+ {
+ SCM proc = LOCAL_REF (0);
+
+ if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ {
+ LOCAL_SET (0, SCM_STRUCT_PROCEDURE (proc));
+ continue;
+ }
+ if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
+ {
+ scm_t_uint32 n = FRAME_LOCALS_COUNT();
+
+ /* Shuffle args up. */
+ RESET_FRAME (n + 1);
+ while (n--)
+ LOCAL_SET (n + 1, LOCAL_REF (n));
+
+ LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc).apply_trampoline);
+ continue;
+ }
+
+ SYNC_IP();
+ vm_error_wrong_type_apply (proc);
+ }
+
+ /* Let's go! */
+ ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+ APPLY_HOOK ();
+
+ NEXT (0);
+
+ BEGIN_DISPATCH_SWITCH;
+
+
+ \f
+
+ /*
+ * Call and return
+ */
+
+ /* halt _:24
+ *
+ * Bring the VM to a halt, returning all the values from the stack.
+ */
+ VM_DEFINE_OP (0, halt, "halt", OP1 (U8_X24))
+ {
+ /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */
+
+ scm_t_uint32 nvals = FRAME_LOCALS_COUNT_FROM (4);
+ SCM ret;
+
+ if (nvals == 1)
+ ret = LOCAL_REF (4);
+ else
+ {
+ scm_t_uint32 n;
+ ret = SCM_EOL;
+ for (n = nvals; n > 0; n--)
+ ret = scm_inline_cons (thread, LOCAL_REF (4 + n - 1), ret);
+ ret = scm_values (ret);
+ }
+
+ vp->ip = SCM_FRAME_RETURN_ADDRESS (fp);
+ vp->sp = SCM_FRAME_PREVIOUS_SP (fp);
+ vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
+
+ return ret;
+ }
+
+ /* call proc:24 _:8 nlocals:24
+ *
+ * Call a procedure. PROC is the local corresponding to a procedure.
+ * The two values below PROC will be overwritten by the saved call
+ * frame data. The new frame will have space for NLOCALS locals: one
+ * for the procedure, and the rest for the arguments which should
+ * already have been pushed on.
+ *
+ * When the call returns, execution proceeds with the next
+ * instruction. There may be any number of values on the return
+ * stack; the precise number can be had by subtracting the address of
+ * PROC from the post-call SP.
+ */
+ VM_DEFINE_OP (1, call, "call", OP2 (U8_U24, X8_U24))
+ {
+ scm_t_uint32 proc, nlocals;
+ SCM *old_fp;
+
+ UNPACK_24 (op, proc);
+ UNPACK_24 (ip[1], nlocals);
+
+ VM_HANDLE_INTERRUPTS;
+
+ PUSH_CONTINUATION_HOOK ();
+
+ old_fp = fp;
+ fp = vp->fp = old_fp + proc;
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
+ SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 2);
+
+ RESET_FRAME (nlocals);
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
+ goto apply;
+
+ ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+ APPLY_HOOK ();
+
+ NEXT (0);
+ }
+
+ /* call-label proc:24 _:8 nlocals:24 label:32
+ *
+ * Call a procedure in the same compilation unit.
+ *
+ * This instruction is just like "call", except that instead of
+ * dereferencing PROC to find the call target, the call target is
+ * known to be at LABEL, a signed 32-bit offset in 32-bit units from
+ * the current IP. Since PROC is not dereferenced, it may be some
+ * other representation of the closure.
+ */
+ VM_DEFINE_OP (2, call_label, "call-label", OP3 (U8_U24, X8_U24, L32))
+ {
+ scm_t_uint32 proc, nlocals;
+ scm_t_int32 label;
+ SCM *old_fp;
+
+ UNPACK_24 (op, proc);
+ UNPACK_24 (ip[1], nlocals);
+ label = ip[2];
+
+ VM_HANDLE_INTERRUPTS;
+
+ PUSH_CONTINUATION_HOOK ();
+
+ old_fp = fp;
+ fp = vp->fp = old_fp + proc;
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
+ SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 3);
+
+ RESET_FRAME (nlocals);
+
+ ip += label;
+
+ APPLY_HOOK ();
+
+ NEXT (0);
+ }
+
+ /* tail-call nlocals:24
+ *
+ * Tail-call a procedure. Requires that the procedure and all of the
+ * arguments have already been shuffled into position. Will reset the
+ * frame to NLOCALS.
+ */
+ VM_DEFINE_OP (3, tail_call, "tail-call", OP1 (U8_U24))
+ {
+ scm_t_uint32 nlocals;
+
+ UNPACK_24 (op, nlocals);
+
+ VM_HANDLE_INTERRUPTS;
+
+ RESET_FRAME (nlocals);
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
+ goto apply;
+
+ ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+ APPLY_HOOK ();
+
+ NEXT (0);
+ }
+
+ /* tail-call-label nlocals:24 label:32
+ *
+ * Tail-call a known procedure. As call is to call-label, tail-call
+ * is to tail-call-label.
+ */
+ VM_DEFINE_OP (4, tail_call_label, "tail-call-label", OP2 (U8_U24, L32))
+ {
+ scm_t_uint32 nlocals;
+ scm_t_int32 label;
+
+ UNPACK_24 (op, nlocals);
+ label = ip[1];
+
+ VM_HANDLE_INTERRUPTS;
+
+ RESET_FRAME (nlocals);
+
+ ip += label;
+
+ APPLY_HOOK ();
+
+ NEXT (0);
+ }
+
+ /* tail-call/shuffle from:24
+ *
+ * Tail-call a procedure. The procedure should already be set to slot
+ * 0. The rest of the args are taken from the frame, starting at
+ * FROM, shuffled down to start at slot 0. This is part of the
+ * implementation of the call-with-values builtin.
+ */
+ VM_DEFINE_OP (5, tail_call_shuffle, "tail-call/shuffle", OP1 (U8_U24))
+ {
+ scm_t_uint32 n, from, nlocals;
+
+ UNPACK_24 (op, from);
+
+ VM_HANDLE_INTERRUPTS;
+
+ VM_ASSERT (from > 0, abort ());
+ nlocals = FRAME_LOCALS_COUNT ();
+
+ for (n = 0; from + n < nlocals; n++)
+ LOCAL_SET (n + 1, LOCAL_REF (from + n));
+
+ RESET_FRAME (n + 1);
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
+ goto apply;
+
+ ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+ APPLY_HOOK ();
+
+ NEXT (0);
+ }
+
+ /* receive dst:12 proc:12 _:8 nlocals:24
+ *
+ * Receive a single return value from a call whose procedure was in
+ * PROC, asserting that the call actually returned at least one
+ * value. Afterwards, resets the frame to NLOCALS locals.
+ */
+ VM_DEFINE_OP (6, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST)
+ {
+ scm_t_uint16 dst, proc;
+ scm_t_uint32 nlocals;
+ UNPACK_12_12 (op, dst, proc);
+ UNPACK_24 (ip[1], nlocals);
+ VM_ASSERT (FRAME_LOCALS_COUNT () > proc + 1, vm_error_no_values ());
+ LOCAL_SET (dst, LOCAL_REF (proc + 1));
+ RESET_FRAME (nlocals);
+ NEXT (2);
+ }
+
+ /* receive-values proc:24 allow-extra?:1 _:7 nvalues:24
+ *
+ * Receive a return of multiple values from a call whose procedure was
+ * in PROC. If fewer than NVALUES values were returned, signal an
+ * error. Unless ALLOW-EXTRA? is true, require that the number of
+ * return values equals NVALUES exactly. After receive-values has
+ * run, the values can be copied down via `mov'.
+ */
+ VM_DEFINE_OP (7, receive_values, "receive-values", OP2 (U8_U24, B1_X7_U24))
+ {
+ scm_t_uint32 proc, nvalues;
+ UNPACK_24 (op, proc);
+ UNPACK_24 (ip[1], nvalues);
+ if (ip[1] & 0x1)
+ VM_ASSERT (FRAME_LOCALS_COUNT () > proc + nvalues,
+ vm_error_not_enough_values ());
+ else
+ VM_ASSERT (FRAME_LOCALS_COUNT () == proc + 1 + nvalues,
+ vm_error_wrong_number_of_values (nvalues));
+ NEXT (2);
+ }
+
+ /* return src:24
+ *
+ * Return a value.
+ */
+ VM_DEFINE_OP (8, return, "return", OP1 (U8_U24))
+ {
+ scm_t_uint32 src;
+ UNPACK_24 (op, src);
+ RETURN_ONE_VALUE (LOCAL_REF (src));
+ }
+
+ /* return-values _:24
+ *
+ * Return a number of values from a call frame. This opcode
+ * corresponds to an application of `values' in tail position. As
+ * with tail calls, we expect that the values have already been
+ * shuffled down to a contiguous array starting at slot 1.
+ * We also expect the frame has already been reset.
+ */
+ VM_DEFINE_OP (9, return_values, "return-values", OP1 (U8_X24))
+ {
+ SCM *old_fp;
+
+ VM_HANDLE_INTERRUPTS;
+
+ old_fp = fp;
+ ip = SCM_FRAME_RETURN_ADDRESS (fp);
+ fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp);
+
+ /* Clear stack frame. */
+ old_fp[-1] = SCM_BOOL_F;
+ old_fp[-2] = SCM_BOOL_F;
+
+ POP_CONTINUATION_HOOK (old_fp);
+
+ NEXT (0);
+ }
+
+
+ \f
+
+ /*
+ * Specialized call stubs
+ */
+
+ /* subr-call ptr-idx:24
+ *
+ * Call a subr, passing all locals in this frame as arguments. Fetch
+ * the foreign pointer from PTR-IDX, a free variable. Return from the
+ * calling frame. This instruction is part of the trampolines
+ * created in gsubr.c, and is not generated by the compiler.
+ */
+ VM_DEFINE_OP (10, subr_call, "subr-call", OP1 (U8_U24))
+ {
+ scm_t_uint32 ptr_idx;
+ SCM pointer, ret;
+ SCM (*subr)();
+
+ UNPACK_24 (op, ptr_idx);
+
+ pointer = SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx);
+ subr = SCM_POINTER_VALUE (pointer);
+
+ SYNC_IP ();
+
+ switch (FRAME_LOCALS_COUNT_FROM (1))
+ {
+ case 0:
+ ret = subr ();
+ break;
+ case 1:
+ ret = subr (fp[1]);
+ break;
+ case 2:
+ ret = subr (fp[1], fp[2]);
+ break;
+ case 3:
+ ret = subr (fp[1], fp[2], fp[3]);
+ break;
+ case 4:
+ ret = subr (fp[1], fp[2], fp[3], fp[4]);
+ break;
+ case 5:
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5]);
+ break;
+ case 6:
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6]);
+ break;
+ case 7:
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7]);
+ break;
+ case 8:
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8]);
+ break;
+ case 9:
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9]);
+ break;
+ case 10:
+ ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9], fp[10]);
+ break;
+ default:
+ abort ();
+ }
+
+ CACHE_FP ();
+
+ if (SCM_UNLIKELY (SCM_VALUESP (ret)))
+ /* multiple values returned to continuation */
+ RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
+ else
+ RETURN_ONE_VALUE (ret);
+ }
+
+ /* foreign-call cif-idx:12 ptr-idx:12
+ *
+ * Call a foreign function. Fetch the CIF and foreign pointer from
+ * CIF-IDX and PTR-IDX, both free variables. Return from the calling
+ * frame. Arguments are taken from the stack. This instruction is
+ * part of the trampolines created by the FFI, and is not generated by
+ * the compiler.
+ */
+ VM_DEFINE_OP (11, foreign_call, "foreign-call", OP1 (U8_U12_U12))
+ {
+ scm_t_uint16 cif_idx, ptr_idx;
+ SCM closure, cif, pointer, ret;
+
+ UNPACK_12_12 (op, cif_idx, ptr_idx);
+
+ closure = LOCAL_REF (0);
+ cif = SCM_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx);
+ pointer = SCM_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx);
+
+ SYNC_IP ();
+
+ // FIXME: separate args
+ ret = scm_i_foreign_call (scm_inline_cons (thread, cif, pointer),
+ LOCAL_ADDRESS (1));
+
+ CACHE_FP ();
+
+ if (SCM_UNLIKELY (SCM_VALUESP (ret)))
+ /* multiple values returned to continuation */
+ RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0));
+ else
+ RETURN_ONE_VALUE (ret);
+ }
+
+ /* continuation-call contregs:24
+ *
+ * Return to a continuation, nonlocally. The arguments to the
+ * continuation are taken from the stack. CONTREGS is a free variable
+ * containing the reified continuation. This instruction is part of
+ * the implementation of undelimited continuations, and is not
+ * generated by the compiler.
+ */
+ VM_DEFINE_OP (12, continuation_call, "continuation-call", OP1 (U8_U24))
+ {
+ SCM contregs;
+ scm_t_uint32 contregs_idx;
+
+ UNPACK_24 (op, contregs_idx);
+
+ contregs =
+ SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx);
+
+ SYNC_IP ();
+ scm_i_check_continuation (contregs);
+ vm_return_to_continuation (scm_i_contregs_vp (contregs),
+ scm_i_contregs_vm_cont (contregs),
+ FRAME_LOCALS_COUNT_FROM (1),
+ LOCAL_ADDRESS (1));
+ scm_i_reinstate_continuation (contregs);
+
+ /* no NEXT */
+ abort ();
+ }
+
+ /* compose-continuation cont:24
+ *
+ * Compose a partial continution with the current continuation. The
+ * arguments to the continuation are taken from the stack. CONT is a
+ * free variable containing the reified continuation. This
+ * instruction is part of the implementation of partial continuations,
+ * and is not generated by the compiler.
+ */
+ VM_DEFINE_OP (13, compose_continuation, "compose-continuation", OP1 (U8_U24))
+ {
+ SCM vmcont;
+ scm_t_uint32 cont_idx;
+
+ UNPACK_24 (op, cont_idx);
+ vmcont = SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx);
+
+ SYNC_IP ();
+ VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
+ vm_error_continuation_not_rewindable (vmcont));
+ vm_reinstate_partial_continuation (vp, vmcont, FRAME_LOCALS_COUNT_FROM (1),
+ LOCAL_ADDRESS (1),
+ &thread->dynstack,
+ registers);
+ CACHE_REGISTER ();
+ NEXT (0);
+ }
+
+ /* tail-apply _:24
+ *
+ * Tail-apply the procedure in local slot 0 to the rest of the
+ * arguments. This instruction is part of the implementation of
+ * `apply', and is not generated by the compiler.
+ */
+ VM_DEFINE_OP (14, tail_apply, "tail-apply", OP1 (U8_X24))
+ {
+ int i, list_idx, list_len, nlocals;
+ SCM list;
+
+ VM_HANDLE_INTERRUPTS;
+
+ nlocals = FRAME_LOCALS_COUNT ();
+ // At a minimum, there should be apply, f, and the list.
+ VM_ASSERT (nlocals >= 3, abort ());
+ list_idx = nlocals - 1;
+ list = LOCAL_REF (list_idx);
+ list_len = scm_ilength (list);
+
+ VM_ASSERT (list_len >= 0, vm_error_apply_to_non_list (list));
+
+ nlocals = nlocals - 2 + list_len;
+ ALLOC_FRAME (nlocals);
+
+ for (i = 1; i < list_idx; i++)
+ LOCAL_SET (i - 1, LOCAL_REF (i));
+
+ /* Null out these slots, just in case there are less than 2 elements
+ in the list. */
+ LOCAL_SET (list_idx - 1, SCM_UNDEFINED);
+ LOCAL_SET (list_idx, SCM_UNDEFINED);
+
+ for (i = 0; i < list_len; i++, list = SCM_CDR (list))
+ LOCAL_SET (list_idx - 1 + i, SCM_CAR (list));
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
+ goto apply;
+
+ ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+ APPLY_HOOK ();
+
+ NEXT (0);
+ }
+
+ /* call/cc _:24
+ *
+ * Capture the current continuation, and tail-apply the procedure in
+ * local slot 1 to it. This instruction is part of the implementation
+ * of `call/cc', and is not generated by the compiler.
+ */
+ VM_DEFINE_OP (15, call_cc, "call/cc", OP1 (U8_X24))
+ {
+ SCM vm_cont, cont;
+ scm_t_dynstack *dynstack;
+ int first;
+
+ VM_HANDLE_INTERRUPTS;
+
+ SYNC_IP ();
+ dynstack = scm_dynstack_capture_all (&thread->dynstack);
+ vm_cont = scm_i_vm_capture_stack (vp->stack_base,
+ SCM_FRAME_DYNAMIC_LINK (fp),
+ SCM_FRAME_PREVIOUS_SP (fp),
+ SCM_FRAME_RETURN_ADDRESS (fp),
+ dynstack,
+ 0);
+ /* FIXME: Seems silly to capture the registers here, when they are
+ already captured in the registers local, which here we are
+ copying out to the heap; and likewise, the setjmp(®isters)
+ code already has the non-local return handler. But oh
+ well! */
+ cont = scm_i_make_continuation (&first, vp, vm_cont);
+
+ if (first)
+ {
+ LOCAL_SET (0, LOCAL_REF (1));
+ LOCAL_SET (1, cont);
+ RESET_FRAME (2);
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0))))
+ goto apply;
+
+ ip = SCM_PROGRAM_CODE (LOCAL_REF (0));
+
+ APPLY_HOOK ();
+
+ NEXT (0);
+ }
+ else
+ {
+ CACHE_REGISTER ();
+ ABORT_CONTINUATION_HOOK ();
+ NEXT (0);
+ }
+ }
+
+ /* abort _:24
+ *
+ * Abort to a prompt handler. The tag is expected in r1, and the rest
+ * of the values in the frame are returned to the prompt handler.
+ * This corresponds to a tail application of abort-to-prompt.
+ */
+ VM_DEFINE_OP (16, abort, "abort", OP1 (U8_X24))
+ {
+ scm_t_uint32 nlocals = FRAME_LOCALS_COUNT ();
+
+ ASSERT (nlocals >= 2);
+ /* FIXME: Really we should capture the caller's registers. Until
+ then, manually advance the IP so that when the prompt resumes,
+ it continues with the next instruction. */
+ ip++;
+ SYNC_IP ();
+ vm_abort (vp, LOCAL_REF (1), nlocals - 2, LOCAL_ADDRESS (2),
+ SCM_EOL, LOCAL_ADDRESS (0), registers);
+
+ /* vm_abort should not return */
+ abort ();
+ }
+
+ /* builtin-ref dst:12 idx:12
+ *
+ * Load a builtin stub by index into DST.
+ */
+ VM_DEFINE_OP (17, builtin_ref, "builtin-ref", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, idx;
+
+ UNPACK_12_12 (op, dst, idx);
+ LOCAL_SET (dst, scm_vm_builtin_ref (idx));
+
+ NEXT (1);
+ }
+
+
+ \f
+
+ /*
+ * Function prologues
+ */
+
+ /* br-if-nargs-ne expected:24 _:8 offset:24
+ * br-if-nargs-lt expected:24 _:8 offset:24
+ * br-if-nargs-gt expected:24 _:8 offset:24
+ *
+ * If the number of actual arguments is not equal, less than, or greater
+ * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to
+ * the current instruction pointer.
+ */
+ VM_DEFINE_OP (18, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
+ {
+ BR_NARGS (!=);
+ }
+ VM_DEFINE_OP (19, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
+ {
+ BR_NARGS (<);
+ }
+ VM_DEFINE_OP (20, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24))
+ {
+ BR_NARGS (>);
+ }
+
+ /* assert-nargs-ee expected:24
+ * assert-nargs-ge expected:24
+ * assert-nargs-le expected:24
+ *
+ * If the number of actual arguments is not ==, >=, or <= EXPECTED,
+ * respectively, signal an error.
+ */
+ VM_DEFINE_OP (21, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24))
+ {
+ scm_t_uint32 expected;
+ UNPACK_24 (op, expected);
+ VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
+ vm_error_wrong_num_args (LOCAL_REF (0)));
+ NEXT (1);
+ }
+ VM_DEFINE_OP (22, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24))
+ {
+ scm_t_uint32 expected;
+ UNPACK_24 (op, expected);
+ VM_ASSERT (FRAME_LOCALS_COUNT () >= expected,
+ vm_error_wrong_num_args (LOCAL_REF (0)));
+ NEXT (1);
+ }
+ VM_DEFINE_OP (23, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24))
+ {
+ scm_t_uint32 expected;
+ UNPACK_24 (op, expected);
+ VM_ASSERT (FRAME_LOCALS_COUNT () <= expected,
+ vm_error_wrong_num_args (LOCAL_REF (0)));
+ NEXT (1);
+ }
+
+ /* alloc-frame nlocals:24
+ *
+ * Ensure that there is space on the stack for NLOCALS local variables,
+ * setting them all to SCM_UNDEFINED, except those nargs values that
+ * were passed as arguments and procedure.
+ */
+ VM_DEFINE_OP (24, alloc_frame, "alloc-frame", OP1 (U8_U24))
+ {
+ scm_t_uint32 nlocals, nargs;
+ UNPACK_24 (op, nlocals);
+
+ nargs = FRAME_LOCALS_COUNT ();
+ ALLOC_FRAME (nlocals);
+ while (nlocals-- > nargs)
+ LOCAL_SET (nlocals, SCM_UNDEFINED);
+
+ NEXT (1);
+ }
+
+ /* reset-frame nlocals:24
+ *
+ * Like alloc-frame, but doesn't check that the stack is big enough.
+ * Used to reset the frame size to something less than the size that
+ * was previously set via alloc-frame.
+ */
+ VM_DEFINE_OP (25, reset_frame, "reset-frame", OP1 (U8_U24))
+ {
+ scm_t_uint32 nlocals;
+ UNPACK_24 (op, nlocals);
+ RESET_FRAME (nlocals);
+ NEXT (1);
+ }
+
+ /* assert-nargs-ee/locals expected:12 nlocals:12
+ *
+ * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The
+ * number of locals reserved is EXPECTED + NLOCALS.
+ */
+ VM_DEFINE_OP (26, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12))
+ {
+ scm_t_uint16 expected, nlocals;
+ UNPACK_12_12 (op, expected, nlocals);
+ VM_ASSERT (FRAME_LOCALS_COUNT () == expected,
+ vm_error_wrong_num_args (LOCAL_REF (0)));
+ ALLOC_FRAME (expected + nlocals);
+ while (nlocals--)
+ LOCAL_SET (expected + nlocals, SCM_UNDEFINED);
+
+ NEXT (1);
+ }
+
+ /* br-if-npos-gt nreq:24 _:8 npos:24 _:8 offset:24
+ *
+ * Find the first positional argument after NREQ. If it is greater
+ * than NPOS, jump to OFFSET.
+ *
+ * This instruction is only emitted for functions with multiple
+ * clauses, and an earlier clause has keywords and no rest arguments.
+ * See "Case-lambda" in the manual, for more on how case-lambda
+ * chooses the clause to apply.
+ */
+ VM_DEFINE_OP (27, br_if_npos_gt, "br-if-npos-gt", OP3 (U8_U24, X8_U24, X8_L24))
+ {
+ scm_t_uint32 nreq, npos;
+
+ UNPACK_24 (op, nreq);
+ UNPACK_24 (ip[1], npos);
+
+ /* We can only have too many positionals if there are more
+ arguments than NPOS. */
+ if (FRAME_LOCALS_COUNT() > npos)
+ {
+ scm_t_uint32 n;
+ for (n = nreq; n < npos; n++)
+ if (scm_is_keyword (LOCAL_REF (n)))
+ break;
+ if (n == npos && !scm_is_keyword (LOCAL_REF (n)))
+ {
+ scm_t_int32 offset = ip[2];
+ offset >>= 8; /* Sign-extending shift. */
+ NEXT (offset);
+ }
+ }
+ NEXT (3);
+ }
+
+ /* bind-kwargs nreq:24 flags:8 nreq-and-opt:24 _:8 ntotal:24 kw-offset:32
+ *
+ * flags := allow-other-keys:1 has-rest:1 _:6
+ *
+ * Find the last positional argument, and shuffle all the rest above
+ * NTOTAL. Initialize the intervening locals to SCM_UNDEFINED. Then
+ * load the constant at KW-OFFSET words from the current IP, and use it
+ * to bind keyword arguments. If HAS-REST, collect all shuffled
+ * arguments into a list, and store it in NREQ-AND-OPT. Finally, clear
+ * the arguments that we shuffled up.
+ *
+ * A macro-mega-instruction.
+ */
+ VM_DEFINE_OP (28, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32))
+ {
+ scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs;
+ scm_t_int32 kw_offset;
+ scm_t_bits kw_bits;
+ SCM kw;
+ char allow_other_keys, has_rest;
+
+ UNPACK_24 (op, nreq);
+ allow_other_keys = ip[1] & 0x1;
+ has_rest = ip[1] & 0x2;
+ UNPACK_24 (ip[1], nreq_and_opt);
+ UNPACK_24 (ip[2], ntotal);
+ kw_offset = ip[3];
+ kw_bits = (scm_t_bits) (ip + kw_offset);
+ VM_ASSERT (!(kw_bits & 0x7), abort());
+ kw = SCM_PACK (kw_bits);
+
+ nargs = FRAME_LOCALS_COUNT ();
+
+ /* look in optionals for first keyword or last positional */
+ /* starting after the last required positional arg */
+ npositional = nreq;
+ while (/* while we have args */
+ npositional < nargs
+ /* and we still have positionals to fill */
+ && npositional < nreq_and_opt
+ /* and we haven't reached a keyword yet */
+ && !scm_is_keyword (LOCAL_REF (npositional)))
+ /* bind this optional arg (by leaving it in place) */
+ npositional++;
+ nkw = nargs - npositional;
+ /* shuffle non-positional arguments above ntotal */
+ ALLOC_FRAME (ntotal + nkw);
+ n = nkw;
+ while (n--)
+ LOCAL_SET (ntotal + n, LOCAL_REF (npositional + n));
+ /* and fill optionals & keyword args with SCM_UNDEFINED */
+ n = npositional;
+ while (n < ntotal)
+ LOCAL_SET (n++, SCM_UNDEFINED);
+
+ VM_ASSERT (has_rest || (nkw % 2) == 0,
+ vm_error_kwargs_length_not_even (LOCAL_REF (0)));
+
+ /* Now bind keywords, in the order given. */
+ for (n = 0; n < nkw; n++)
+ if (scm_is_keyword (LOCAL_REF (ntotal + n)))
+ {
+ SCM walk;
+ for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk))
+ if (scm_is_eq (SCM_CAAR (walk), LOCAL_REF (ntotal + n)))
+ {
+ SCM si = SCM_CDAR (walk);
+ LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_uint32 (si),
+ LOCAL_REF (ntotal + n + 1));
+ break;
+ }
+ VM_ASSERT (scm_is_pair (walk) || allow_other_keys,
+ vm_error_kwargs_unrecognized_keyword (LOCAL_REF (0),
+ LOCAL_REF (ntotal + n)));
+ n++;
+ }
+ else
+ VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (LOCAL_REF (0),
+ LOCAL_REF (ntotal + n)));
+
+ if (has_rest)
+ {
+ SCM rest = SCM_EOL;
+ n = nkw;
+ while (n--)
+ rest = scm_inline_cons (thread, LOCAL_REF (ntotal + n), rest);
+ LOCAL_SET (nreq_and_opt, rest);
+ }
+
+ RESET_FRAME (ntotal);
+
+ NEXT (4);
+ }
+
+ /* bind-rest dst:24
+ *
+ * Collect any arguments at or above DST into a list, and store that
+ * list at DST.
+ */
+ VM_DEFINE_OP (29, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST)
+ {
+ scm_t_uint32 dst, nargs;
+ SCM rest = SCM_EOL;
+
+ UNPACK_24 (op, dst);
+ nargs = FRAME_LOCALS_COUNT ();
+
+ if (nargs <= dst)
+ {
+ ALLOC_FRAME (dst + 1);
+ while (nargs < dst)
+ LOCAL_SET (nargs++, SCM_UNDEFINED);
+ }
+ else
+ {
+ while (nargs-- > dst)
+ {
+ rest = scm_inline_cons (thread, LOCAL_REF (nargs), rest);
+ LOCAL_SET (nargs, SCM_UNDEFINED);
+ }
+
+ RESET_FRAME (dst + 1);
+ }
+
+ LOCAL_SET (dst, rest);
+
+ NEXT (1);
+ }
+
+
+ \f
+
+ /*
+ * Branching instructions
+ */
+
+ /* br offset:24
+ *
+ * Add OFFSET, a signed 24-bit number, to the current instruction
+ * pointer.
+ */
+ VM_DEFINE_OP (30, br, "br", OP1 (U8_L24))
+ {
+ scm_t_int32 offset = op;
+ offset >>= 8; /* Sign-extending shift. */
+ if (offset <= 0)
+ VM_HANDLE_INTERRUPTS;
+ NEXT (offset);
+ }
+
+ /* br-if-true test:24 invert:1 _:7 offset:24
+ *
+ * If the value in TEST is true for the purposes of Scheme, add
+ * OFFSET, a signed 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (31, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24))
+ {
+ BR_UNARY (x, scm_is_true (x));
+ }
+
+ /* br-if-null test:24 invert:1 _:7 offset:24
+ *
+ * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a
+ * signed 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (32, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24))
+ {
+ BR_UNARY (x, scm_is_null (x));
+ }
+
+ /* br-if-nil test:24 invert:1 _:7 offset:24
+ *
+ * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit
+ * number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (33, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24))
+ {
+ BR_UNARY (x, scm_is_lisp_false (x));
+ }
+
+ /* br-if-pair test:24 invert:1 _:7 offset:24
+ *
+ * If the value in TEST is a pair, add OFFSET, a signed 24-bit number,
+ * to the current instruction pointer.
+ */
+ VM_DEFINE_OP (34, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24))
+ {
+ BR_UNARY (x, scm_is_pair (x));
+ }
+
+ /* br-if-struct test:24 invert:1 _:7 offset:24
+ *
+ * If the value in TEST is a struct, add OFFSET, a signed 24-bit
+ * number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (35, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24))
+ {
+ BR_UNARY (x, SCM_STRUCTP (x));
+ }
+
+ /* br-if-char test:24 invert:1 _:7 offset:24
+ *
+ * If the value in TEST is a char, add OFFSET, a signed 24-bit number,
+ * to the current instruction pointer.
+ */
+ VM_DEFINE_OP (36, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24))
+ {
+ BR_UNARY (x, SCM_CHARP (x));
+ }
+
+ /* br-if-tc7 test:24 invert:1 tc7:7 offset:24
+ *
+ * If the value in TEST has the TC7 given in the second word, add
+ * OFFSET, a signed 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (37, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24))
+ {
+ BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f));
+ }
+
+ /* br-if-eq a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the value in A is eq? to the value in B, add OFFSET, a signed
+ * 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (38, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24))
+ {
+ BR_BINARY (x, y, scm_is_eq (x, y));
+ }
+
+ /* br-if-eqv a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the value in A is eqv? to the value in B, add OFFSET, a signed
+ * 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (39, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24))
+ {
+ BR_BINARY (x, y,
+ scm_is_eq (x, y)
+ || (SCM_NIMP (x) && SCM_NIMP (y)
+ && scm_is_true (scm_eqv_p (x, y))));
+ }
+
+ // FIXME: remove, have compiler inline eqv test instead
+ /* br-if-equal a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the value in A is equal? to the value in B, add OFFSET, a signed
+ * 24-bit number, to the current instruction pointer.
+ */
+ // FIXME: Should sync_ip before calling out and cache_fp before coming
+ // back! Another reason to remove this opcode!
+ VM_DEFINE_OP (40, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24))
+ {
+ BR_BINARY (x, y,
+ scm_is_eq (x, y)
+ || (SCM_NIMP (x) && SCM_NIMP (y)
+ && scm_is_true (scm_equal_p (x, y))));
+ }
+
+ /* br-if-= a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the value in A is = to the value in B, add OFFSET, a signed
+ * 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (41, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
+ {
+ BR_ARITHMETIC (==, scm_num_eq_p);
+ }
+
+ /* br-if-< a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the value in A is < to the value in B, add OFFSET, a signed
+ * 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (42, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
+ {
+ BR_ARITHMETIC (<, scm_less_p);
+ }
+
+ /* br-if-<= a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the value in A is <= to the value in B, add OFFSET, a signed
+ * 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (43, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24))
+ {
+ BR_ARITHMETIC (<=, scm_leq_p);
+ }
+
+
+ \f
+
+ /*
+ * Lexical binding instructions
+ */
+
+ /* mov dst:12 src:12
+ *
+ * Copy a value from one local slot to another.
+ */
+ VM_DEFINE_OP (44, mov, "mov", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst;
+ scm_t_uint16 src;
+
+ UNPACK_12_12 (op, dst, src);
+ LOCAL_SET (dst, LOCAL_REF (src));
+
+ NEXT (1);
+ }
+
+ /* long-mov dst:24 _:8 src:24
+ *
+ * Copy a value from one local slot to another.
+ */
+ VM_DEFINE_OP (45, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST)
+ {
+ scm_t_uint32 dst;
+ scm_t_uint32 src;
+
+ UNPACK_24 (op, dst);
+ UNPACK_24 (ip[1], src);
+ LOCAL_SET (dst, LOCAL_REF (src));
+
+ NEXT (2);
+ }
+
+ /* box dst:12 src:12
+ *
+ * Create a new variable holding SRC, and place it in DST.
+ */
+ VM_DEFINE_OP (46, box, "box", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, src;
+ UNPACK_12_12 (op, dst, src);
+ LOCAL_SET (dst, scm_inline_cell (thread, scm_tc7_variable,
+ SCM_UNPACK (LOCAL_REF (src))));
+ NEXT (1);
+ }
+
+ /* box-ref dst:12 src:12
+ *
+ * Unpack the variable at SRC into DST, asserting that the variable is
+ * actually bound.
+ */
+ VM_DEFINE_OP (47, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, src;
+ SCM var;
+ UNPACK_12_12 (op, dst, src);
+ var = LOCAL_REF (src);
+ VM_ASSERT (SCM_VARIABLEP (var),
+ vm_error_not_a_variable ("variable-ref", var));
+ VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (var));
+ LOCAL_SET (dst, VARIABLE_REF (var));
+ NEXT (1);
+ }
+
+ /* box-set! dst:12 src:12
+ *
+ * Set the contents of the variable at DST to SET.
+ */
+ VM_DEFINE_OP (48, box_set, "box-set!", OP1 (U8_U12_U12))
+ {
+ scm_t_uint16 dst, src;
+ SCM var;
+ UNPACK_12_12 (op, dst, src);
+ var = LOCAL_REF (dst);
+ VM_ASSERT (SCM_VARIABLEP (var),
+ vm_error_not_a_variable ("variable-set!", var));
+ VARIABLE_SET (var, LOCAL_REF (src));
+ NEXT (1);
+ }
+
+ /* make-closure dst:24 offset:32 _:8 nfree:24
+ *
+ * Make a new closure, and write it to DST. The code for the closure
+ * will be found at OFFSET words from the current IP. OFFSET is a
+ * signed 32-bit integer. Space for NFREE free variables will be
+ * allocated.
+ */
+ VM_DEFINE_OP (49, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST)
+ {
+ scm_t_uint32 dst, nfree, n;
+ scm_t_int32 offset;
+ SCM closure;
+
+ UNPACK_24 (op, dst);
+ offset = ip[1];
+ UNPACK_24 (ip[2], nfree);
+
+ // FIXME: Assert range of nfree?
+ closure = scm_inline_words (thread, scm_tc7_program | (nfree << 16),
+ nfree + 2);
+ SCM_SET_CELL_WORD_1 (closure, ip + offset);
+ // FIXME: Elide these initializations?
+ for (n = 0; n < nfree; n++)
+ SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F);
+ LOCAL_SET (dst, closure);
+ NEXT (3);
+ }
+
+ /* free-ref dst:12 src:12 _:8 idx:24
+ *
+ * Load free variable IDX from the closure SRC into local slot DST.
+ */
+ VM_DEFINE_OP (50, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST)
+ {
+ scm_t_uint16 dst, src;
+ scm_t_uint32 idx;
+ UNPACK_12_12 (op, dst, src);
+ UNPACK_24 (ip[1], idx);
+ /* CHECK_FREE_VARIABLE (src); */
+ LOCAL_SET (dst, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src), idx));
+ NEXT (2);
+ }
+
+ /* free-set! dst:12 src:12 _:8 idx:24
+ *
+ * Set free variable IDX from the closure DST to SRC.
+ */
+ VM_DEFINE_OP (51, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24))
+ {
+ scm_t_uint16 dst, src;
+ scm_t_uint32 idx;
+ UNPACK_12_12 (op, dst, src);
+ UNPACK_24 (ip[1], idx);
+ /* CHECK_FREE_VARIABLE (src); */
+ SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF (src));
+ NEXT (2);
+ }
+
+
+ \f
+
+ /*
+ * Immediates and statically allocated non-immediates
+ */
+
+ /* make-short-immediate dst:8 low-bits:16
+ *
+ * Make an immediate whose low bits are LOW-BITS, and whose top bits are
+ * 0.
+ */
+ VM_DEFINE_OP (52, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST)
+ {
+ scm_t_uint8 dst;
+ scm_t_bits val;
+
+ UNPACK_8_16 (op, dst, val);
+ LOCAL_SET (dst, SCM_PACK (val));
+ NEXT (1);
+ }
+
+ /* make-long-immediate dst:24 low-bits:32
+ *
+ * Make an immediate whose low bits are LOW-BITS, and whose top bits are
+ * 0.
+ */
+ VM_DEFINE_OP (53, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32) | OP_DST)
+ {
+ scm_t_uint32 dst;
+ scm_t_bits val;
+
+ UNPACK_24 (op, dst);
+ val = ip[1];
+ LOCAL_SET (dst, SCM_PACK (val));
+ NEXT (2);
+ }
+
+ /* make-long-long-immediate dst:24 high-bits:32 low-bits:32
+ *
+ * Make an immediate with HIGH-BITS and LOW-BITS.
+ */
+ VM_DEFINE_OP (54, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST)
+ {
+ scm_t_uint32 dst;
+ scm_t_bits val;
+
+ UNPACK_24 (op, dst);
+#if SIZEOF_SCM_T_BITS > 4
+ val = ip[1];
+ val <<= 32;
+ val |= ip[2];
+#else
+ ASSERT (ip[1] == 0);
+ val = ip[2];
+#endif
+ LOCAL_SET (dst, SCM_PACK (val));
+ NEXT (3);
+ }
+
+ /* make-non-immediate dst:24 offset:32
+ *
+ * Load a pointer to statically allocated memory into DST. The
+ * object's memory is will be found OFFSET 32-bit words away from the
+ * current instruction pointer. OFFSET is a signed value. The
+ * intention here is that the compiler would produce an object file
+ * containing the words of a non-immediate object, and this
+ * instruction creates a pointer to that memory, effectively
+ * resurrecting that object.
+ *
+ * Whether the object is mutable or immutable depends on where it was
+ * allocated by the compiler, and loaded by the loader.
+ */
+ VM_DEFINE_OP (55, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST)
+ {
+ scm_t_uint32 dst;
+ scm_t_int32 offset;
+ scm_t_uint32* loc;
+ scm_t_bits unpacked;
+
+ UNPACK_24 (op, dst);
+ offset = ip[1];
+ loc = ip + offset;
+ unpacked = (scm_t_bits) loc;
+
+ VM_ASSERT (!(unpacked & 0x7), abort());
+
+ LOCAL_SET (dst, SCM_PACK (unpacked));
+
+ NEXT (2);
+ }
+
+ /* static-ref dst:24 offset:32
+ *
+ * Load a SCM value into DST. The SCM value will be fetched from
+ * memory, OFFSET 32-bit words away from the current instruction
+ * pointer. OFFSET is a signed value.
+ *
+ * The intention is for this instruction to be used to load constants
+ * that the compiler is unable to statically allocate, like symbols.
+ * These values would be initialized when the object file loads.
+ */
+ VM_DEFINE_OP (56, static_ref, "static-ref", OP2 (U8_U24, S32) | OP_DST)
+ {
+ scm_t_uint32 dst;
+ scm_t_int32 offset;
+ scm_t_uint32* loc;
+ scm_t_uintptr loc_bits;
+
+ UNPACK_24 (op, dst);
+ offset = ip[1];
+ loc = ip + offset;
+ loc_bits = (scm_t_uintptr) loc;
+ VM_ASSERT (ALIGNED_P (loc, SCM), abort());
+
+ LOCAL_SET (dst, *((SCM *) loc_bits));
+
+ NEXT (2);
+ }
+
+ /* static-set! src:24 offset:32
+ *
+ * Store a SCM value into memory, OFFSET 32-bit words away from the
+ * current instruction pointer. OFFSET is a signed value.
+ */
+ VM_DEFINE_OP (57, static_set, "static-set!", OP2 (U8_U24, LO32))
+ {
+ scm_t_uint32 src;
+ scm_t_int32 offset;
+ scm_t_uint32* loc;
+
+ UNPACK_24 (op, src);
+ offset = ip[1];
+ loc = ip + offset;
+ VM_ASSERT (ALIGNED_P (loc, SCM), abort());
+
+ *((SCM *) loc) = LOCAL_REF (src);
+
+ NEXT (2);
+ }
+
+ /* static-patch! _:24 dst-offset:32 src-offset:32
+ *
+ * Patch a pointer at DST-OFFSET to point to SRC-OFFSET. Both offsets
+ * are signed 32-bit values, indicating a memory address as a number
+ * of 32-bit words away from the current instruction pointer.
+ */
+ VM_DEFINE_OP (58, static_patch, "static-patch!", OP3 (U8_X24, LO32, L32))
+ {
+ scm_t_int32 dst_offset, src_offset;
+ void *src;
+ void** dst_loc;
+
+ dst_offset = ip[1];
+ src_offset = ip[2];
+
+ dst_loc = (void **) (ip + dst_offset);
+ src = ip + src_offset;
+ VM_ASSERT (ALIGNED_P (dst_loc, void*), abort());
+
+ *dst_loc = src;
+
+ NEXT (3);
+ }
+
+ \f
+
+ /*
+ * Mutable top-level bindings
+ */
+
+ /* There are three slightly different ways to resolve toplevel
+ variables.
+
+ 1. A toplevel reference outside of a function. These need to be
+ looked up when the expression is evaluated -- no later, and no
+ before. They are looked up relative to the module that is
+ current when the expression is evaluated. For example:
+
+ (if (foo) a b)
+
+ The "resolve" instruction resolves the variable (box), and then
+ access is via box-ref or box-set!.
+
+ 2. A toplevel reference inside a function. These are looked up
+ relative to the module that was current when the function was
+ defined. Unlike code at the toplevel, which is usually run only
+ once, these bindings benefit from memoized lookup, in which the
+ variable resulting from the lookup is cached in the function.
+
+ (lambda () (if (foo) a b))
+
+ The toplevel-box instruction is equivalent to "resolve", but
+ caches the resulting variable in statically allocated memory.
+
+ 3. A reference to an identifier with respect to a particular
+ module. This can happen for primitive references, and
+ references residualized by macro expansions. These can always
+ be cached. Use module-box for these.
+ */
+
+ /* current-module dst:24
+ *
+ * Store the current module in DST.
+ */
+ VM_DEFINE_OP (59, current_module, "current-module", OP1 (U8_U24) | OP_DST)
+ {
+ scm_t_uint32 dst;
+
+ UNPACK_24 (op, dst);
+
+ SYNC_IP ();
+ LOCAL_SET (dst, scm_current_module ());
+
+ NEXT (1);
+ }
+
+ /* resolve dst:24 bound?:1 _:7 sym:24
+ *
+ * Resolve SYM in the current module, and place the resulting variable
+ * in DST.
+ */
+ VM_DEFINE_OP (60, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST)
+ {
+ scm_t_uint32 dst;
+ scm_t_uint32 sym;
+ SCM var;
+
+ UNPACK_24 (op, dst);
+ UNPACK_24 (ip[1], sym);
+
+ SYNC_IP ();
+ var = scm_lookup (LOCAL_REF (sym));
+ CACHE_FP ();
+ if (ip[1] & 0x1)
+ VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (LOCAL_REF (sym)));
+ LOCAL_SET (dst, var);
+
+ NEXT (2);
+ }
+
+ /* define! sym:12 val:12
+ *
+ * Look up a binding for SYM in the current module, creating it if
+ * necessary. Set its value to VAL.
+ */
+ VM_DEFINE_OP (61, define, "define!", OP1 (U8_U12_U12))
+ {
+ scm_t_uint16 sym, val;
+ UNPACK_12_12 (op, sym, val);
+ SYNC_IP ();
+ scm_define (LOCAL_REF (sym), LOCAL_REF (val));
+ CACHE_FP ();
+ NEXT (1);
+ }
+
+ /* toplevel-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
+ *
+ * Load a SCM value. The SCM value will be fetched from memory,
+ * VAR-OFFSET 32-bit words away from the current instruction pointer.
+ * VAR-OFFSET is a signed value. Up to here, toplevel-box is like
+ * static-ref.
+ *
+ * Then, if the loaded value is a variable, it is placed in DST, and control
+ * flow continues.
+ *
+ * Otherwise, we have to resolve the variable. In that case we load
+ * the module from MOD-OFFSET, just as we loaded the variable.
+ * Usually the module gets set when the closure is created. The name
+ * is an offset to a symbol.
+ *
+ * We use the module and the symbol to resolve the variable, placing it in
+ * DST, and caching the resolved variable so that we will hit the cache next
+ * time.
+ */
+ VM_DEFINE_OP (62, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST)
+ {
+ scm_t_uint32 dst;
+ scm_t_int32 var_offset;
+ scm_t_uint32* var_loc_u32;
+ SCM *var_loc;
+ SCM var;
+
+ UNPACK_24 (op, dst);
+ var_offset = ip[1];
+ var_loc_u32 = ip + var_offset;
+ VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
+ var_loc = (SCM *) var_loc_u32;
+ var = *var_loc;
+
+ if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
+ {
+ SCM mod, sym;
+ scm_t_int32 mod_offset = ip[2]; /* signed */
+ scm_t_int32 sym_offset = ip[3]; /* signed */
+ scm_t_uint32 *mod_loc = ip + mod_offset;
+ scm_t_uint32 *sym_loc = ip + sym_offset;
+
+ SYNC_IP ();
+
+ VM_ASSERT (ALIGNED_P (mod_loc, SCM), abort());
+ VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
+
+ mod = *((SCM *) mod_loc);
+ sym = *((SCM *) sym_loc);
+
+ /* If the toplevel scope was captured before modules were
+ booted, use the root module. */
+ if (scm_is_false (mod))
+ mod = scm_the_root_module ();
+
+ var = scm_module_lookup (mod, sym);
+ CACHE_FP ();
+ if (ip[4] & 0x1)
+ VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (sym));
+
+ *var_loc = var;
+ }
+
+ LOCAL_SET (dst, var);
+ NEXT (5);
+ }
+
+ /* module-box dst:24 var-offset:32 mod-offset:32 sym-offset:32 bound?:1 _:31
+ *
+ * Like toplevel-box, except MOD-OFFSET points at the name of a module
+ * instead of the module itself.
+ */
+ VM_DEFINE_OP (63, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST)
+ {
+ scm_t_uint32 dst;
+ scm_t_int32 var_offset;
+ scm_t_uint32* var_loc_u32;
+ SCM *var_loc;
+ SCM var;
+
+ UNPACK_24 (op, dst);
+ var_offset = ip[1];
+ var_loc_u32 = ip + var_offset;
+ VM_ASSERT (ALIGNED_P (var_loc_u32, SCM), abort());
+ var_loc = (SCM *) var_loc_u32;
+ var = *var_loc;
+
+ if (SCM_UNLIKELY (!SCM_VARIABLEP (var)))
+ {
+ SCM modname, sym;
+ scm_t_int32 modname_offset = ip[2]; /* signed */
+ scm_t_int32 sym_offset = ip[3]; /* signed */
+ scm_t_uint32 *modname_words = ip + modname_offset;
+ scm_t_uint32 *sym_loc = ip + sym_offset;
+
+ SYNC_IP ();
+
+ VM_ASSERT (!(((scm_t_uintptr) modname_words) & 0x7), abort());
+ VM_ASSERT (ALIGNED_P (sym_loc, SCM), abort());
+
+ modname = SCM_PACK ((scm_t_bits) modname_words);
+ sym = *((SCM *) sym_loc);
+
+ if (!scm_module_system_booted_p)
+ {
+ ASSERT (scm_is_true
+ scm_equal_p (modname,
+ scm_list_2
+ (SCM_BOOL_T,
+ scm_from_utf8_symbol ("guile"))));
+ var = scm_lookup (sym);
+ }
+ else if (scm_is_true (SCM_CAR (modname)))
+ var = scm_public_lookup (SCM_CDR (modname), sym);
+ else
+ var = scm_private_lookup (SCM_CDR (modname), sym);
+
+ CACHE_FP ();
+
+ if (ip[4] & 0x1)
+ VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (sym));
+
+ *var_loc = var;
+ }
+
+ LOCAL_SET (dst, var);
+ NEXT (5);
+ }
+
+ \f
+
+ /*
+ * The dynamic environment
+ */
+
+ /* prompt tag:24 escape-only?:1 _:7 proc-slot:24 _:8 handler-offset:24
+ *
+ * Push a new prompt on the dynamic stack, with a tag from TAG and a
+ * handler at HANDLER-OFFSET words from the current IP. The handler
+ * will expect a multiple-value return as if from a call with the
+ * procedure at PROC-SLOT.
+ */
+ VM_DEFINE_OP (64, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24))
+ {
+ scm_t_uint32 tag, proc_slot;
+ scm_t_int32 offset;
+ scm_t_uint8 escape_only_p;
+ scm_t_dynstack_prompt_flags flags;
+
+ UNPACK_24 (op, tag);
+ escape_only_p = ip[1] & 0x1;
+ UNPACK_24 (ip[1], proc_slot);
+ offset = ip[2];
+ offset >>= 8; /* Sign extension */
+
+ /* Push the prompt onto the dynamic stack. */
+ flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
+ scm_dynstack_push_prompt (&thread->dynstack, flags,
+ LOCAL_REF (tag),
+ fp - vp->stack_base,
+ LOCAL_ADDRESS (proc_slot) - vp->stack_base,
+ ip + offset,
+ registers);
+ NEXT (3);
+ }
+
+ /* wind winder:12 unwinder:12
+ *
+ * Push wind and unwind procedures onto the dynamic stack. Note that
+ * neither are actually called; the compiler should emit calls to wind
+ * and unwind for the normal dynamic-wind control flow. Also note that
+ * the compiler should have inserted checks that they wind and unwind
+ * procs are thunks, if it could not prove that to be the case.
+ */
+ VM_DEFINE_OP (65, wind, "wind", OP1 (U8_U12_U12))
+ {
+ scm_t_uint16 winder, unwinder;
+ UNPACK_12_12 (op, winder, unwinder);
+ scm_dynstack_push_dynwind (&thread->dynstack,
+ LOCAL_REF (winder), LOCAL_REF (unwinder));
+ NEXT (1);
+ }
+
+ /* unwind _:24
+ *
+ * A normal exit from the dynamic extent of an expression. Pop the top
+ * entry off of the dynamic stack.
+ */
+ VM_DEFINE_OP (66, unwind, "unwind", OP1 (U8_X24))
+ {
+ scm_dynstack_pop (&thread->dynstack);
+ NEXT (1);
+ }
+
+ /* push-fluid fluid:12 value:12
+ *
+ * Dynamically bind VALUE to FLUID.
+ */
+ VM_DEFINE_OP (67, push_fluid, "push-fluid", OP1 (U8_U12_U12))
+ {
+ scm_t_uint32 fluid, value;
+
+ UNPACK_12_12 (op, fluid, value);
+
+ scm_dynstack_push_fluid (&thread->dynstack,
+ LOCAL_REF (fluid), LOCAL_REF (value),
+ thread->dynamic_state);
+ NEXT (1);
+ }
+
+ /* pop-fluid _:24
+ *
+ * Leave the dynamic extent of a with-fluid* expression, restoring the
+ * fluid to its previous value.
+ */
+ VM_DEFINE_OP (68, pop_fluid, "pop-fluid", OP1 (U8_X24))
+ {
+ /* This function must not allocate. */
+ scm_dynstack_unwind_fluid (&thread->dynstack,
+ thread->dynamic_state);
+ NEXT (1);
+ }
+
+ /* fluid-ref dst:12 src:12
+ *
+ * Reference the fluid in SRC, and place the value in DST.
+ */
+ VM_DEFINE_OP (69, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, src;
+ size_t num;
+ SCM fluid, fluids;
+
+ UNPACK_12_12 (op, dst, src);
+ fluid = LOCAL_REF (src);
+ fluids = SCM_I_DYNAMIC_STATE_FLUIDS (thread->dynamic_state);
+ if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
+ || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+ {
+ /* Punt dynstate expansion and error handling to the C proc. */
+ SYNC_IP ();
+ LOCAL_SET (dst, scm_fluid_ref (fluid));
+ }
+ else
+ {
+ SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
+ if (scm_is_eq (val, SCM_UNDEFINED))
+ val = SCM_I_FLUID_DEFAULT (fluid);
+ VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
+ vm_error_unbound_fluid (fluid));
+ LOCAL_SET (dst, val);
+ }
+
+ NEXT (1);
+ }
+
+ /* fluid-set fluid:12 val:12
+ *
+ * Set the value of the fluid in DST to the value in SRC.
+ */
+ VM_DEFINE_OP (70, fluid_set, "fluid-set", OP1 (U8_U12_U12))
+ {
+ scm_t_uint16 a, b;
+ size_t num;
+ SCM fluid, fluids;
+
+ UNPACK_12_12 (op, a, b);
+ fluid = LOCAL_REF (a);
+ fluids = SCM_I_DYNAMIC_STATE_FLUIDS (thread->dynamic_state);
+ if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
+ || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
+ {
+ /* Punt dynstate expansion and error handling to the C proc. */
+ SYNC_IP ();
+ scm_fluid_set_x (fluid, LOCAL_REF (b));
+ }
+ else
+ SCM_SIMPLE_VECTOR_SET (fluids, num, LOCAL_REF (b));
+
+ NEXT (1);
+ }
+
+
+ \f
+
+ /*
+ * Strings, symbols, and keywords
+ */
+
+ /* string-length dst:12 src:12
+ *
+ * Store the length of the string in SRC in DST.
+ */
+ VM_DEFINE_OP (71, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST)
+ {
+ ARGS1 (str);
+ if (SCM_LIKELY (scm_is_string (str)))
+ RETURN (SCM_I_MAKINUM (scm_i_string_length (str)));
+ else
+ {
+ SYNC_IP ();
+ RETURN (scm_string_length (str));
+ }
+ }
+
+ /* string-ref dst:8 src:8 idx:8
+ *
+ * Fetch the character at position IDX in the string in SRC, and store
+ * it in DST.
+ */
+ VM_DEFINE_OP (72, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_signed_bits i = 0;
+ ARGS2 (str, idx);
+ if (SCM_LIKELY (scm_is_string (str)
+ && SCM_I_INUMP (idx)
+ && ((i = SCM_I_INUM (idx)) >= 0)
+ && i < scm_i_string_length (str)))
+ RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i)));
+ else
+ {
+ SYNC_IP ();
+ RETURN (scm_string_ref (str, idx));
+ }
+ }
+
+ /* No string-set! instruction, as there is no good fast path there. */
+
+ /* string->number dst:12 src:12
+ *
+ * Parse a string in SRC to a number, and store in DST.
+ */
+ VM_DEFINE_OP (73, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, src;
+
+ UNPACK_12_12 (op, dst, src);
+ SYNC_IP ();
+ LOCAL_SET (dst,
+ scm_string_to_number (LOCAL_REF (src),
+ SCM_UNDEFINED /* radix = 10 */));
+ NEXT (1);
+ }
+
+ /* string->symbol dst:12 src:12
+ *
+ * Parse a string in SRC to a symbol, and store in DST.
+ */
+ VM_DEFINE_OP (74, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, src;
+
+ UNPACK_12_12 (op, dst, src);
+ SYNC_IP ();
+ LOCAL_SET (dst, scm_string_to_symbol (LOCAL_REF (src)));
+ NEXT (1);
+ }
+
+ /* symbol->keyword dst:12 src:12
+ *
+ * Make a keyword from the symbol in SRC, and store it in DST.
+ */
+ VM_DEFINE_OP (75, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, src;
+ UNPACK_12_12 (op, dst, src);
+ SYNC_IP ();
+ LOCAL_SET (dst, scm_symbol_to_keyword (LOCAL_REF (src)));
+ NEXT (1);
+ }
+
+ \f
+
+ /*
+ * Pairs
+ */
+
+ /* cons dst:8 car:8 cdr:8
+ *
+ * Cons CAR and CDR, and store the result in DST.
+ */
+ VM_DEFINE_OP (76, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ ARGS2 (x, y);
+ RETURN (scm_inline_cons (thread, x, y));
+ }
+
+ /* car dst:12 src:12
+ *
+ * Place the car of SRC in DST.
+ */
+ VM_DEFINE_OP (77, car, "car", OP1 (U8_U12_U12) | OP_DST)
+ {
+ ARGS1 (x);
+ VM_VALIDATE_PAIR (x, "car");
+ RETURN (SCM_CAR (x));
+ }
+
+ /* cdr dst:12 src:12
+ *
+ * Place the cdr of SRC in DST.
+ */
+ VM_DEFINE_OP (78, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST)
+ {
+ ARGS1 (x);
+ VM_VALIDATE_PAIR (x, "cdr");
+ RETURN (SCM_CDR (x));
+ }
+
+ /* set-car! pair:12 car:12
+ *
+ * Set the car of DST to SRC.
+ */
+ VM_DEFINE_OP (79, set_car, "set-car!", OP1 (U8_U12_U12))
+ {
+ scm_t_uint16 a, b;
+ SCM x, y;
+ UNPACK_12_12 (op, a, b);
+ x = LOCAL_REF (a);
+ y = LOCAL_REF (b);
+ VM_VALIDATE_PAIR (x, "set-car!");
+ SCM_SETCAR (x, y);
+ NEXT (1);
+ }
+
+ /* set-cdr! pair:12 cdr:12
+ *
+ * Set the cdr of DST to SRC.
+ */
+ VM_DEFINE_OP (80, set_cdr, "set-cdr!", OP1 (U8_U12_U12))
+ {
+ scm_t_uint16 a, b;
+ SCM x, y;
+ UNPACK_12_12 (op, a, b);
+ x = LOCAL_REF (a);
+ y = LOCAL_REF (b);
+ VM_VALIDATE_PAIR (x, "set-car!");
+ SCM_SETCDR (x, y);
+ NEXT (1);
+ }
+
+
+ \f
+
+ /*
+ * Numeric operations
+ */
+
+ /* add dst:8 a:8 b:8
+ *
+ * Add A to B, and place the result in DST.
+ */
+ VM_DEFINE_OP (81, add, "add", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ BINARY_INTEGER_OP (+, scm_sum);
+ }
+
+ /* add1 dst:12 src:12
+ *
+ * Add 1 to the value in SRC, and place the result in DST.
+ */
+ VM_DEFINE_OP (82, add1, "add1", OP1 (U8_U12_U12) | OP_DST)
+ {
+ ARGS1 (x);
+
+ /* Check for overflow. We must avoid overflow in the signed
+ addition below, even if X is not an inum. */
+ if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP))
+ {
+ SCM result;
+
+ /* Add 1 to the integer without untagging. */
+ result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP);
+
+ if (SCM_LIKELY (SCM_I_INUMP (result)))
+ RETURN (result);
+ }
+
+ RETURN_EXP (scm_sum (x, SCM_I_MAKINUM (1)));
+ }
+
+ /* sub dst:8 a:8 b:8
+ *
+ * Subtract B from A, and place the result in DST.
+ */
+ VM_DEFINE_OP (83, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ BINARY_INTEGER_OP (-, scm_difference);
+ }
+
+ /* sub1 dst:12 src:12
+ *
+ * Subtract 1 from SRC, and place the result in DST.
+ */
+ VM_DEFINE_OP (84, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST)
+ {
+ ARGS1 (x);
+
+ /* Check for overflow. We must avoid overflow in the signed
+ subtraction below, even if X is not an inum. */
+ if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP))
+ {
+ SCM result;
+
+ /* Substract 1 from the integer without untagging. */
+ result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP);
+
+ if (SCM_LIKELY (SCM_I_INUMP (result)))
+ RETURN (result);
+ }
+
+ RETURN_EXP (scm_difference (x, SCM_I_MAKINUM (1)));
+ }
+
+ /* mul dst:8 a:8 b:8
+ *
+ * Multiply A and B, and place the result in DST.
+ */
+ VM_DEFINE_OP (85, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ ARGS2 (x, y);
+ RETURN_EXP (scm_product (x, y));
+ }
+
+ /* div dst:8 a:8 b:8
+ *
+ * Divide A by B, and place the result in DST.
+ */
+ VM_DEFINE_OP (86, div, "div", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ ARGS2 (x, y);
+ RETURN_EXP (scm_divide (x, y));
+ }
+
+ /* quo dst:8 a:8 b:8
+ *
+ * Divide A by B, and place the quotient in DST.
+ */
+ VM_DEFINE_OP (87, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ ARGS2 (x, y);
+ RETURN_EXP (scm_quotient (x, y));
+ }
+
+ /* rem dst:8 a:8 b:8
+ *
+ * Divide A by B, and place the remainder in DST.
+ */
+ VM_DEFINE_OP (88, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ ARGS2 (x, y);
+ RETURN_EXP (scm_remainder (x, y));
+ }
+
+ /* mod dst:8 a:8 b:8
+ *
+ * Place the modulo of A by B in DST.
+ */
+ VM_DEFINE_OP (89, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ ARGS2 (x, y);
+ RETURN_EXP (scm_modulo (x, y));
+ }
+
+ /* ash dst:8 a:8 b:8
+ *
+ * Shift A arithmetically by B bits, and place the result in DST.
+ */
+ VM_DEFINE_OP (90, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ ARGS2 (x, y);
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
+ {
+ if (SCM_I_INUM (y) < 0)
+ /* Right shift, will be a fixnum. */
+ RETURN (SCM_I_MAKINUM
+ (SCM_SRS (SCM_I_INUM (x),
+ (-SCM_I_INUM (y) <= SCM_I_FIXNUM_BIT-1)
+ ? -SCM_I_INUM (y) : SCM_I_FIXNUM_BIT-1)));
+ else
+ /* Left shift. See comments in scm_ash. */
+ {
+ scm_t_signed_bits nn, bits_to_shift;
+
+ nn = SCM_I_INUM (x);
+ bits_to_shift = SCM_I_INUM (y);
+
+ if (bits_to_shift < SCM_I_FIXNUM_BIT-1
+ && ((scm_t_bits)
+ (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
+ <= 1))
+ RETURN (SCM_I_MAKINUM (nn < 0
+ ? -(-nn << bits_to_shift)
+ : (nn << bits_to_shift)));
+ /* fall through */
+ }
+ /* fall through */
+ }
+ RETURN_EXP (scm_ash (x, y));
+ }
+
+ /* logand dst:8 a:8 b:8
+ *
+ * Place the bitwise AND of A and B into DST.
+ */
+ VM_DEFINE_OP (91, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ ARGS2 (x, y);
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
+ /* Compute bitwise AND without untagging */
+ RETURN (SCM_PACK (SCM_UNPACK (x) & SCM_UNPACK (y)));
+ RETURN_EXP (scm_logand (x, y));
+ }
+
+ /* logior dst:8 a:8 b:8
+ *
+ * Place the bitwise inclusive OR of A with B in DST.
+ */
+ VM_DEFINE_OP (92, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ ARGS2 (x, y);
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
+ /* Compute bitwise OR without untagging */
+ RETURN (SCM_PACK (SCM_UNPACK (x) | SCM_UNPACK (y)));
+ RETURN_EXP (scm_logior (x, y));
+ }
+
+ /* logxor dst:8 a:8 b:8
+ *
+ * Place the bitwise exclusive OR of A with B in DST.
+ */
+ VM_DEFINE_OP (93, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ ARGS2 (x, y);
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
+ RETURN (SCM_I_MAKINUM (SCM_I_INUM (x) ^ SCM_I_INUM (y)));
+ RETURN_EXP (scm_logxor (x, y));
+ }
+
+ /* make-vector dst:8 length:8 init:8
+ *
+ * Make a vector and write it to DST. The vector will have space for
+ * LENGTH slots. They will be filled with the value in slot INIT.
+ */
+ VM_DEFINE_OP (94, make_vector, "make-vector", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_uint8 dst, init, length;
+
+ UNPACK_8_8_8 (op, dst, length, init);
+
+ LOCAL_SET (dst, scm_make_vector (LOCAL_REF (length), LOCAL_REF (init)));
+
+ NEXT (1);
+ }
+
+ /* make-vector/immediate dst:8 length:8 init:8
+ *
+ * Make a short vector of known size and write it to DST. The vector
+ * will have space for LENGTH slots, an immediate value. They will be
+ * filled with the value in slot INIT.
+ */
+ VM_DEFINE_OP (95, make_vector_immediate, "make-vector/immediate", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_uint8 dst, init;
+ scm_t_int32 length, n;
+ SCM val, vector;
+
+ UNPACK_8_8_8 (op, dst, length, init);
+
+ val = LOCAL_REF (init);
+ vector = scm_inline_words (thread, scm_tc7_vector | (length << 8),
+ length + 1);
+ for (n = 0; n < length; n++)
+ SCM_SIMPLE_VECTOR_SET (vector, n, val);
+ LOCAL_SET (dst, vector);
+ NEXT (1);
+ }
+
+ /* vector-length dst:12 src:12
+ *
+ * Store the length of the vector in SRC in DST.
+ */
+ VM_DEFINE_OP (96, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
+ {
+ ARGS1 (vect);
+ VM_ASSERT (SCM_I_IS_VECTOR (vect),
+ vm_error_not_a_vector ("vector-ref", vect));
+ RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
+ }
+
+ /* vector-ref dst:8 src:8 idx:8
+ *
+ * Fetch the item at position IDX in the vector in SRC, and store it
+ * in DST.
+ */
+ VM_DEFINE_OP (97, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_signed_bits i = 0;
+ ARGS2 (vect, idx);
+ VM_ASSERT (SCM_I_IS_VECTOR (vect),
+ vm_error_not_a_vector ("vector-ref", vect));
+ VM_ASSERT ((SCM_I_INUMP (idx)
+ && ((i = SCM_I_INUM (idx)) >= 0)
+ && i < SCM_I_VECTOR_LENGTH (vect)),
+ vm_error_out_of_range ("vector-ref", idx));
+ RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
+ }
+
+ /* vector-ref/immediate dst:8 src:8 idx:8
+ *
+ * Fill DST with the item IDX elements into the vector at SRC. Useful
+ * for building data types using vectors.
+ */
+ VM_DEFINE_OP (98, vector_ref_immediate, "vector-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_uint8 dst, src, idx;
+ SCM v;
+
+ UNPACK_8_8_8 (op, dst, src, idx);
+ v = LOCAL_REF (src);
+ VM_ASSERT (SCM_I_IS_VECTOR (v),
+ vm_error_not_a_vector ("vector-ref", v));
+ VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (v),
+ vm_error_out_of_range ("vector-ref", scm_from_size_t (idx)));
+ LOCAL_SET (dst, SCM_I_VECTOR_ELTS (LOCAL_REF (src))[idx]);
+ NEXT (1);
+ }
+
+ /* vector-set! dst:8 idx:8 src:8
+ *
+ * Store SRC into the vector DST at index IDX.
+ */
+ VM_DEFINE_OP (99, vector_set, "vector-set!", OP1 (U8_U8_U8_U8))
+ {
+ scm_t_uint8 dst, idx_var, src;
+ SCM vect, idx, val;
+ scm_t_signed_bits i = 0;
+
+ UNPACK_8_8_8 (op, dst, idx_var, src);
+ vect = LOCAL_REF (dst);
+ idx = LOCAL_REF (idx_var);
+ val = LOCAL_REF (src);
+
+ VM_ASSERT (SCM_I_IS_VECTOR (vect),
+ vm_error_not_a_vector ("vector-ref", vect));
+ VM_ASSERT ((SCM_I_INUMP (idx)
+ && ((i = SCM_I_INUM (idx)) >= 0)
+ && i < SCM_I_VECTOR_LENGTH (vect)),
+ vm_error_out_of_range ("vector-ref", idx));
+ SCM_I_VECTOR_WELTS (vect)[i] = val;
+ NEXT (1);
+ }
+
+ /* vector-set!/immediate dst:8 idx:8 src:8
+ *
+ * Store SRC into the vector DST at index IDX. Here IDX is an
+ * immediate value.
+ */
+ VM_DEFINE_OP (100, vector_set_immediate, "vector-set!/immediate", OP1 (U8_U8_U8_U8))
+ {
+ scm_t_uint8 dst, idx, src;
+ SCM vect, val;
+
+ UNPACK_8_8_8 (op, dst, idx, src);
+ vect = LOCAL_REF (dst);
+ val = LOCAL_REF (src);
+
+ VM_ASSERT (SCM_I_IS_VECTOR (vect),
+ vm_error_not_a_vector ("vector-ref", vect));
+ VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (vect),
+ vm_error_out_of_range ("vector-ref", scm_from_size_t (idx)));
+ SCM_I_VECTOR_WELTS (vect)[idx] = val;
+ NEXT (1);
+ }
+
+
+ \f
+
+ /*
+ * Structs and GOOPS
+ */
+
+ /* struct-vtable dst:12 src:12
+ *
+ * Store the vtable of SRC into DST.
+ */
+ VM_DEFINE_OP (101, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST)
+ {
+ ARGS1 (obj);
+ VM_VALIDATE_STRUCT (obj, "struct_vtable");
+ RETURN (SCM_STRUCT_VTABLE (obj));
+ }
+
+ /* allocate-struct/immediate dst:8 vtable:8 nfields:8
+ *
+ * Allocate a new struct with VTABLE, and place it in DST. The struct
+ * will be constructed with space for NFIELDS fields, which should
+ * correspond to the field count of the VTABLE.
+ */
+ VM_DEFINE_OP (102, allocate_struct_immediate, "allocate-struct/immediate", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_uint8 dst, vtable, nfields;
+ SCM ret;
+
+ UNPACK_8_8_8 (op, dst, vtable, nfields);
+
+ SYNC_IP ();
+ ret = scm_allocate_struct (LOCAL_REF (vtable), SCM_I_MAKINUM (nfields));
+ LOCAL_SET (dst, ret);
+
+ NEXT (1);
+ }
+
+ /* struct-ref/immediate dst:8 src:8 idx:8
+ *
+ * Fetch the item at slot IDX in the struct in SRC, and store it
+ * in DST. IDX is an immediate unsigned 8-bit value.
+ */
+ VM_DEFINE_OP (103, struct_ref_immediate, "struct-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_uint8 dst, src, idx;
+ SCM obj;
+
+ UNPACK_8_8_8 (op, dst, src, idx);
+
+ obj = LOCAL_REF (src);
+
+ if (SCM_LIKELY (SCM_STRUCTP (obj)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE)
+ && idx < SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj),
+ scm_vtable_index_size)))
+ RETURN (SCM_STRUCT_SLOT_REF (obj, idx));
+
+ SYNC_IP ();
+ RETURN (scm_struct_ref (obj, SCM_I_MAKINUM (idx)));
+ }
+
+ /* struct-set!/immediate dst:8 idx:8 src:8
+ *
+ * Store SRC into the struct DST at slot IDX. IDX is an immediate
+ * unsigned 8-bit value.
+ */
+ VM_DEFINE_OP (104, struct_set_immediate, "struct-set!/immediate", OP1 (U8_U8_U8_U8))
+ {
+ scm_t_uint8 dst, idx, src;
+ SCM obj, val;
+
+ UNPACK_8_8_8 (op, dst, idx, src);
+
+ obj = LOCAL_REF (dst);
+ val = LOCAL_REF (src);
+
+ if (SCM_LIKELY (SCM_STRUCTP (obj)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE_RW)
+ && idx < SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj),
+ scm_vtable_index_size)))
+ {
+ SCM_STRUCT_SLOT_SET (obj, idx, val);
+ NEXT (1);
+ }
+
+ SYNC_IP ();
+ scm_struct_set_x (obj, SCM_I_MAKINUM (idx), val);
+ NEXT (1);
+ }
+
+ /* class-of dst:12 type:12
+ *
+ * Store the vtable of SRC into DST.
+ */
+ VM_DEFINE_OP (105, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST)
+ {
+ ARGS1 (obj);
+ if (SCM_INSTANCEP (obj))
+ RETURN (SCM_CLASS_OF (obj));
+ SYNC_IP ();
+ RETURN (scm_class_of (obj));
+ }
+
+ \f
+
+ /*
+ * Arrays, packed uniform arrays, and bytevectors.
+ */
+
+ /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32
+ *
+ * Load the contiguous typed array located at OFFSET 32-bit words away
+ * from the instruction pointer, and store into DST. LEN is a byte
+ * length. OFFSET is signed.
+ */
+ VM_DEFINE_OP (106, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST)
+ {
+ scm_t_uint8 dst, type, shape;
+ scm_t_int32 offset;
+ scm_t_uint32 len;
+
+ UNPACK_8_8_8 (op, dst, type, shape);
+ offset = ip[1];
+ len = ip[2];
+ SYNC_IP ();
+ LOCAL_SET (dst, scm_from_contiguous_typed_array (LOCAL_REF (type),
+ LOCAL_REF (shape),
+ ip + offset, len));
+ NEXT (3);
+ }
+
+ /* make-array dst:8 type:8 fill:8 _:8 bounds:24
+ *
+ * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
+ */
+ VM_DEFINE_OP (107, make_array, "make-array", OP2 (U8_U8_U8_U8, X8_U24) | OP_DST)
+ {
+ scm_t_uint8 dst, type, fill, bounds;
+ UNPACK_8_8_8 (op, dst, type, fill);
+ UNPACK_24 (ip[1], bounds);
+ SYNC_IP ();
+ LOCAL_SET (dst, scm_make_typed_array (LOCAL_REF (type), LOCAL_REF (fill),
+ LOCAL_REF (bounds)));
+ NEXT (2);
+ }
+
+ /* bv-u8-ref dst:8 src:8 idx:8
+ * bv-s8-ref dst:8 src:8 idx:8
+ * bv-u16-ref dst:8 src:8 idx:8
+ * bv-s16-ref dst:8 src:8 idx:8
+ * bv-u32-ref dst:8 src:8 idx:8
+ * bv-s32-ref dst:8 src:8 idx:8
+ * bv-u64-ref dst:8 src:8 idx:8
+ * bv-s64-ref dst:8 src:8 idx:8
+ * bv-f32-ref dst:8 src:8 idx:8
+ * bv-f64-ref dst:8 src:8 idx:8
+ *
+ * Fetch the item at byte offset IDX in the bytevector SRC, and store
+ * it in DST. All accesses use native endianness.
+ */
+#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
+ do { \
+ scm_t_signed_bits i; \
+ const scm_t_ ## type *int_ptr; \
+ ARGS2 (bv, idx); \
+ \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
+ i = SCM_I_INUM (idx); \
+ int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
+ \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && (i >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
+ RETURN (SCM_I_MAKINUM (*int_ptr)); \
+ else \
+ { \
+ SYNC_IP (); \
+ RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
+ } \
+ } while (0)
+
+#define BV_INT_REF(stem, type, size) \
+ do { \
+ scm_t_signed_bits i; \
+ const scm_t_ ## type *int_ptr; \
+ ARGS2 (bv, idx); \
+ \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
+ i = SCM_I_INUM (idx); \
+ int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
+ \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && (i >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
+ { \
+ scm_t_ ## type x = *int_ptr; \
+ if (SCM_FIXABLE (x)) \
+ RETURN (SCM_I_MAKINUM (x)); \
+ else \
+ { \
+ SYNC_IP (); \
+ RETURN (scm_from_ ## type (x)); \
+ } \
+ } \
+ else \
+ { \
+ SYNC_IP (); \
+ RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
+ } \
+ } while (0)
+
+#define BV_FLOAT_REF(stem, fn_stem, type, size) \
+ do { \
+ scm_t_signed_bits i; \
+ const type *float_ptr; \
+ ARGS2 (bv, idx); \
+ \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
+ i = SCM_I_INUM (idx); \
+ float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
+ \
+ SYNC_IP (); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && (i >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (ALIGNED_P (float_ptr, type)))) \
+ RETURN (scm_from_double (*float_ptr)); \
+ else \
+ RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
+ } while (0)
+
+ VM_DEFINE_OP (108, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
+
+ VM_DEFINE_OP (109, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_FIXABLE_INT_REF (s8, s8, int8, 1);
+
+ VM_DEFINE_OP (110, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2);
+
+ VM_DEFINE_OP (111, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_FIXABLE_INT_REF (s16, s16_native, int16, 2);
+
+ VM_DEFINE_OP (112, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+#if SIZEOF_VOID_P > 4
+ BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4);
+#else
+ BV_INT_REF (u32, uint32, 4);
+#endif
+
+ VM_DEFINE_OP (113, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+#if SIZEOF_VOID_P > 4
+ BV_FIXABLE_INT_REF (s32, s32_native, int32, 4);
+#else
+ BV_INT_REF (s32, int32, 4);
+#endif
+
+ VM_DEFINE_OP (114, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_INT_REF (u64, uint64, 8);
+
+ VM_DEFINE_OP (115, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_INT_REF (s64, int64, 8);
+
+ VM_DEFINE_OP (116, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_FLOAT_REF (f32, ieee_single, float, 4);
+
+ VM_DEFINE_OP (117, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_FLOAT_REF (f64, ieee_double, double, 8);
+
+ /* bv-u8-set! dst:8 idx:8 src:8
+ * bv-s8-set! dst:8 idx:8 src:8
+ * bv-u16-set! dst:8 idx:8 src:8
+ * bv-s16-set! dst:8 idx:8 src:8
+ * bv-u32-set! dst:8 idx:8 src:8
+ * bv-s32-set! dst:8 idx:8 src:8
+ * bv-u64-set! dst:8 idx:8 src:8
+ * bv-s64-set! dst:8 idx:8 src:8
+ * bv-f32-set! dst:8 idx:8 src:8
+ * bv-f64-set! dst:8 idx:8 src:8
+ *
+ * Store SRC into the bytevector DST at byte offset IDX. Multibyte
+ * values are written using native endianness.
+ */
+#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
+ do { \
+ scm_t_uint8 dst, idx, src; \
+ scm_t_signed_bits i, j = 0; \
+ SCM bv, scm_idx, val; \
+ scm_t_ ## type *int_ptr; \
+ \
+ UNPACK_8_8_8 (op, dst, idx, src); \
+ bv = LOCAL_REF (dst); \
+ scm_idx = LOCAL_REF (idx); \
+ val = LOCAL_REF (src); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
+ i = SCM_I_INUM (scm_idx); \
+ int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
+ \
+ if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
+ && (i >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
+ && (SCM_I_INUMP (val)) \
+ && ((j = SCM_I_INUM (val)) >= min) \
+ && (j <= max))) \
+ *int_ptr = (scm_t_ ## type) j; \
+ else \
+ { \
+ SYNC_IP (); \
+ scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \
+ } \
+ NEXT (1); \
+ } while (0)
+
+#define BV_INT_SET(stem, type, size) \
+ do { \
+ scm_t_uint8 dst, idx, src; \
+ scm_t_signed_bits i; \
+ SCM bv, scm_idx, val; \
+ scm_t_ ## type *int_ptr; \
+ \
+ UNPACK_8_8_8 (op, dst, idx, src); \
+ bv = LOCAL_REF (dst); \
+ scm_idx = LOCAL_REF (idx); \
+ val = LOCAL_REF (src); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
+ i = SCM_I_INUM (scm_idx); \
+ int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
+ \
+ if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
+ && (i >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
+ *int_ptr = scm_to_ ## type (val); \
+ else \
+ { \
+ SYNC_IP (); \
+ scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \
+ } \
+ NEXT (1); \
+ } while (0)
+
+#define BV_FLOAT_SET(stem, fn_stem, type, size) \
+ do { \
+ scm_t_uint8 dst, idx, src; \
+ scm_t_signed_bits i; \
+ SCM bv, scm_idx, val; \
+ type *float_ptr; \
+ \
+ UNPACK_8_8_8 (op, dst, idx, src); \
+ bv = LOCAL_REF (dst); \
+ scm_idx = LOCAL_REF (idx); \
+ val = LOCAL_REF (src); \
+ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \
+ i = SCM_I_INUM (scm_idx); \
+ float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
+ \
+ if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \
+ && (i >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (ALIGNED_P (float_ptr, type)))) \
+ *float_ptr = scm_to_double (val); \
+ else \
+ { \
+ SYNC_IP (); \
+ scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \
+ } \
+ NEXT (1); \
+ } while (0)
+
+ VM_DEFINE_OP (118, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8))
+ BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1);
+
+ VM_DEFINE_OP (119, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8))
+ BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1);
+
+ VM_DEFINE_OP (120, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8))
+ BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2);
+
+ VM_DEFINE_OP (121, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8))
+ BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2);
+
+ VM_DEFINE_OP (122, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8))
+#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_OP (123, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8))
+#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_OP (124, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
+ BV_INT_SET (u64, uint64, 8);
+
+ VM_DEFINE_OP (125, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
+ BV_INT_SET (s64, int64, 8);
+
+ VM_DEFINE_OP (126, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
+ BV_FLOAT_SET (f32, ieee_single, float, 4);
+
+ VM_DEFINE_OP (127, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
+ BV_FLOAT_SET (f64, ieee_double, double, 8);
+
+ /* br-if-logtest a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the exact integer in A has any bits in common with the exact
+ * integer in B, add OFFSET, a signed 24-bit number, to the current
+ * instruction pointer.
+ */
+ VM_DEFINE_OP (128, br_if_logtest, "br-if-logtest", OP2 (U8_U12_U12, B1_X7_L24))
+ {
+ BR_BINARY (x, y,
+ ((SCM_I_INUMP (x) && SCM_I_INUMP (y))
+ ? (SCM_UNPACK (x) & SCM_UNPACK (y) & ~scm_tc2_int)
+ : scm_is_true (scm_logtest (x, y))));
+ }
+
+ /* FIXME: Move above */
+
+ /* allocate-struct dst:8 vtable:8 nfields:8
+ *
+ * Allocate a new struct with VTABLE, and place it in DST. The struct
+ * will be constructed with space for NFIELDS fields, which should
+ * correspond to the field count of the VTABLE.
+ */
+ VM_DEFINE_OP (129, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_uint8 dst, vtable, nfields;
+ SCM ret;
+
+ UNPACK_8_8_8 (op, dst, vtable, nfields);
+
+ SYNC_IP ();
+ ret = scm_allocate_struct (LOCAL_REF (vtable), LOCAL_REF (nfields));
+ LOCAL_SET (dst, ret);
+
+ NEXT (1);
+ }
+
+ /* struct-ref dst:8 src:8 idx:8
+ *
+ * Fetch the item at slot IDX in the struct in SRC, and store it
+ * in DST.
+ */
+ VM_DEFINE_OP (130, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_uint8 dst, src, idx;
+ SCM obj;
+ SCM index;
+
+ UNPACK_8_8_8 (op, dst, src, idx);
+
+ obj = LOCAL_REF (src);
+ index = LOCAL_REF (idx);
+
+ if (SCM_LIKELY (SCM_STRUCTP (obj)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_I_INUMP (index)
+ && SCM_I_INUM (index) >= 0
+ && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF
+ (SCM_STRUCT_VTABLE (obj),
+ scm_vtable_index_size))))
+ RETURN (SCM_STRUCT_SLOT_REF (obj, SCM_I_INUM (index)));
+
+ SYNC_IP ();
+ RETURN (scm_struct_ref (obj, index));
+ }
+
+ /* struct-set! dst:8 idx:8 src:8
+ *
+ * Store SRC into the struct DST at slot IDX.
+ */
+ VM_DEFINE_OP (131, struct_set, "struct-set!", OP1 (U8_U8_U8_U8))
+ {
+ scm_t_uint8 dst, idx, src;
+ SCM obj, val, index;
+
+ UNPACK_8_8_8 (op, dst, idx, src);
+
+ obj = LOCAL_REF (dst);
+ val = LOCAL_REF (src);
+ index = LOCAL_REF (idx);
+
+ if (SCM_LIKELY (SCM_STRUCTP (obj)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE)
+ && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
+ SCM_VTABLE_FLAG_SIMPLE_RW)
+ && SCM_I_INUMP (index)
+ && SCM_I_INUM (index) >= 0
+ && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF
+ (SCM_STRUCT_VTABLE (obj),
+ scm_vtable_index_size))))
+ {
+ SCM_STRUCT_SLOT_SET (obj, SCM_I_INUM (index), val);
+ NEXT (1);
+ }
+
+ SYNC_IP ();
+ scm_struct_set_x (obj, index, val);
+ NEXT (1);
+ }
+
+ VM_DEFINE_OP (132, unused_132, NULL, NOP)
+ VM_DEFINE_OP (133, unused_133, NULL, NOP)
+ VM_DEFINE_OP (134, unused_134, NULL, NOP)
+ VM_DEFINE_OP (135, unused_135, NULL, NOP)
+ VM_DEFINE_OP (136, unused_136, NULL, NOP)
+ VM_DEFINE_OP (137, unused_137, NULL, NOP)
+ VM_DEFINE_OP (138, unused_138, NULL, NOP)
+ VM_DEFINE_OP (139, unused_139, NULL, NOP)
+ VM_DEFINE_OP (140, unused_140, NULL, NOP)
+ VM_DEFINE_OP (141, unused_141, NULL, NOP)
+ VM_DEFINE_OP (142, unused_142, NULL, NOP)
+ VM_DEFINE_OP (143, unused_143, NULL, NOP)
+ VM_DEFINE_OP (144, unused_144, NULL, NOP)
+ VM_DEFINE_OP (145, unused_145, NULL, NOP)
+ VM_DEFINE_OP (146, unused_146, NULL, NOP)
+ VM_DEFINE_OP (147, unused_147, NULL, NOP)
+ VM_DEFINE_OP (148, unused_148, NULL, NOP)
+ VM_DEFINE_OP (149, unused_149, NULL, NOP)
+ VM_DEFINE_OP (150, unused_150, NULL, NOP)
+ VM_DEFINE_OP (151, unused_151, NULL, NOP)
+ VM_DEFINE_OP (152, unused_152, NULL, NOP)
+ VM_DEFINE_OP (153, unused_153, NULL, NOP)
+ VM_DEFINE_OP (154, unused_154, NULL, NOP)
+ VM_DEFINE_OP (155, unused_155, NULL, NOP)
+ VM_DEFINE_OP (156, unused_156, NULL, NOP)
+ VM_DEFINE_OP (157, unused_157, NULL, NOP)
+ VM_DEFINE_OP (158, unused_158, NULL, NOP)
+ VM_DEFINE_OP (159, unused_159, NULL, NOP)
+ VM_DEFINE_OP (160, unused_160, NULL, NOP)
+ VM_DEFINE_OP (161, unused_161, NULL, NOP)
+ VM_DEFINE_OP (162, unused_162, NULL, NOP)
+ VM_DEFINE_OP (163, unused_163, NULL, NOP)
+ VM_DEFINE_OP (164, unused_164, NULL, NOP)
+ VM_DEFINE_OP (165, unused_165, NULL, NOP)
+ VM_DEFINE_OP (166, unused_166, NULL, NOP)
+ VM_DEFINE_OP (167, unused_167, NULL, NOP)
+ VM_DEFINE_OP (168, unused_168, NULL, NOP)
+ VM_DEFINE_OP (169, unused_169, NULL, NOP)
+ VM_DEFINE_OP (170, unused_170, NULL, NOP)
+ VM_DEFINE_OP (171, unused_171, NULL, NOP)
+ VM_DEFINE_OP (172, unused_172, NULL, NOP)
+ VM_DEFINE_OP (173, unused_173, NULL, NOP)
+ VM_DEFINE_OP (174, unused_174, NULL, NOP)
+ VM_DEFINE_OP (175, unused_175, NULL, NOP)
+ VM_DEFINE_OP (176, unused_176, NULL, NOP)
+ VM_DEFINE_OP (177, unused_177, NULL, NOP)
+ VM_DEFINE_OP (178, unused_178, NULL, NOP)
+ VM_DEFINE_OP (179, unused_179, NULL, NOP)
+ VM_DEFINE_OP (180, unused_180, NULL, NOP)
+ VM_DEFINE_OP (181, unused_181, NULL, NOP)
+ VM_DEFINE_OP (182, unused_182, NULL, NOP)
+ VM_DEFINE_OP (183, unused_183, NULL, NOP)
+ VM_DEFINE_OP (184, unused_184, NULL, NOP)
+ VM_DEFINE_OP (185, unused_185, NULL, NOP)
+ VM_DEFINE_OP (186, unused_186, NULL, NOP)
+ VM_DEFINE_OP (187, unused_187, NULL, NOP)
+ VM_DEFINE_OP (188, unused_188, NULL, NOP)
+ VM_DEFINE_OP (189, unused_189, NULL, NOP)
+ VM_DEFINE_OP (190, unused_190, NULL, NOP)
+ VM_DEFINE_OP (191, unused_191, NULL, NOP)
+ VM_DEFINE_OP (192, unused_192, NULL, NOP)
+ VM_DEFINE_OP (193, unused_193, NULL, NOP)
+ VM_DEFINE_OP (194, unused_194, NULL, NOP)
+ VM_DEFINE_OP (195, unused_195, NULL, NOP)
+ VM_DEFINE_OP (196, unused_196, NULL, NOP)
+ VM_DEFINE_OP (197, unused_197, NULL, NOP)
+ VM_DEFINE_OP (198, unused_198, NULL, NOP)
+ VM_DEFINE_OP (199, unused_199, NULL, NOP)
+ VM_DEFINE_OP (200, unused_200, NULL, NOP)
+ VM_DEFINE_OP (201, unused_201, NULL, NOP)
+ VM_DEFINE_OP (202, unused_202, NULL, NOP)
+ VM_DEFINE_OP (203, unused_203, NULL, NOP)
+ VM_DEFINE_OP (204, unused_204, NULL, NOP)
+ VM_DEFINE_OP (205, unused_205, NULL, NOP)
+ VM_DEFINE_OP (206, unused_206, NULL, NOP)
+ VM_DEFINE_OP (207, unused_207, NULL, NOP)
+ VM_DEFINE_OP (208, unused_208, NULL, NOP)
+ VM_DEFINE_OP (209, unused_209, NULL, NOP)
+ VM_DEFINE_OP (210, unused_210, NULL, NOP)
+ VM_DEFINE_OP (211, unused_211, NULL, NOP)
+ VM_DEFINE_OP (212, unused_212, NULL, NOP)
+ VM_DEFINE_OP (213, unused_213, NULL, NOP)
+ VM_DEFINE_OP (214, unused_214, NULL, NOP)
+ VM_DEFINE_OP (215, unused_215, NULL, NOP)
+ VM_DEFINE_OP (216, unused_216, NULL, NOP)
+ VM_DEFINE_OP (217, unused_217, NULL, NOP)
+ VM_DEFINE_OP (218, unused_218, NULL, NOP)
+ VM_DEFINE_OP (219, unused_219, NULL, NOP)
+ VM_DEFINE_OP (220, unused_220, NULL, NOP)
+ VM_DEFINE_OP (221, unused_221, NULL, NOP)
+ VM_DEFINE_OP (222, unused_222, NULL, NOP)
+ VM_DEFINE_OP (223, unused_223, NULL, NOP)
+ VM_DEFINE_OP (224, unused_224, NULL, NOP)
+ VM_DEFINE_OP (225, unused_225, NULL, NOP)
+ VM_DEFINE_OP (226, unused_226, NULL, NOP)
+ VM_DEFINE_OP (227, unused_227, NULL, NOP)
+ VM_DEFINE_OP (228, unused_228, NULL, NOP)
+ VM_DEFINE_OP (229, unused_229, NULL, NOP)
+ VM_DEFINE_OP (230, unused_230, NULL, NOP)
+ VM_DEFINE_OP (231, unused_231, NULL, NOP)
+ VM_DEFINE_OP (232, unused_232, NULL, NOP)
+ VM_DEFINE_OP (233, unused_233, NULL, NOP)
+ VM_DEFINE_OP (234, unused_234, NULL, NOP)
+ VM_DEFINE_OP (235, unused_235, NULL, NOP)
+ VM_DEFINE_OP (236, unused_236, NULL, NOP)
+ VM_DEFINE_OP (237, unused_237, NULL, NOP)
+ VM_DEFINE_OP (238, unused_238, NULL, NOP)
+ VM_DEFINE_OP (239, unused_239, NULL, NOP)
+ VM_DEFINE_OP (240, unused_240, NULL, NOP)
+ VM_DEFINE_OP (241, unused_241, NULL, NOP)
+ VM_DEFINE_OP (242, unused_242, NULL, NOP)
+ VM_DEFINE_OP (243, unused_243, NULL, NOP)
+ VM_DEFINE_OP (244, unused_244, NULL, NOP)
+ VM_DEFINE_OP (245, unused_245, NULL, NOP)
+ VM_DEFINE_OP (246, unused_246, NULL, NOP)
+ VM_DEFINE_OP (247, unused_247, NULL, NOP)
+ VM_DEFINE_OP (248, unused_248, NULL, NOP)
+ VM_DEFINE_OP (249, unused_249, NULL, NOP)
+ VM_DEFINE_OP (250, unused_250, NULL, NOP)
+ VM_DEFINE_OP (251, unused_251, NULL, NOP)
+ VM_DEFINE_OP (252, unused_252, NULL, NOP)
+ VM_DEFINE_OP (253, unused_253, NULL, NOP)
+ VM_DEFINE_OP (254, unused_254, NULL, NOP)
+ VM_DEFINE_OP (255, unused_255, NULL, NOP)
+ {
+ vm_error_bad_instruction (op);
+ abort (); /* never reached */
+ }
+
+ END_DISPATCH_SWITCH;
+}
+
+
+#undef ABORT_CONTINUATION_HOOK
+#undef ALIGNED_P
+#undef APPLY_HOOK
+#undef ARGS1
+#undef ARGS2
+#undef BEGIN_DISPATCH_SWITCH
+#undef BINARY_INTEGER_OP
+#undef BR_ARITHMETIC
+#undef BR_BINARY
+#undef BR_NARGS
+#undef BR_UNARY
+#undef BV_FIXABLE_INT_REF
+#undef BV_FIXABLE_INT_SET
+#undef BV_FLOAT_REF
+#undef BV_FLOAT_SET
+#undef BV_INT_REF
+#undef BV_INT_SET
+#undef CACHE_REGISTER
+#undef END_DISPATCH_SWITCH
+#undef FREE_VARIABLE_REF
+#undef INIT
+#undef INUM_MAX
+#undef INUM_MIN
+#undef LOCAL_REF
+#undef LOCAL_SET
+#undef NEXT
+#undef NEXT_HOOK
+#undef NEXT_JUMP
+#undef POP_CONTINUATION_HOOK
+#undef PUSH_CONTINUATION_HOOK
+#undef RETURN
+#undef RETURN_ONE_VALUE
+#undef RETURN_VALUE_LIST
+#undef RUN_HOOK
+#undef RUN_HOOK0
+#undef RUN_HOOK1
+#undef SYNC_IP
+#undef UNPACK_8_8_8
+#undef UNPACK_8_16
+#undef UNPACK_16_8
+#undef UNPACK_12_12
+#undef UNPACK_24
+#undef VARIABLE_BOUNDP
+#undef VARIABLE_REF
+#undef VARIABLE_SET
+#undef VM_CHECK_FREE_VARIABLE
+#undef VM_CHECK_OBJECT
+#undef VM_CHECK_UNDERFLOW
+#undef VM_DEFINE_OP
+#undef VM_INSTRUCTION_TO_LABEL
+#undef VM_USE_HOOKS
+#undef VM_VALIDATE_BYTEVECTOR
+#undef VM_VALIDATE_PAIR
+#undef VM_VALIDATE_STRUCT
+
+/*
+(defun renumber-ops ()
+ "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
+ (interactive "")
+ (save-excursion
+ (let ((counter -1)) (goto-char (point-min))
+ (while (re-search-forward "^ *VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
+ (replace-match
+ (number-to-string (setq counter (1+ counter)))
+ t t nil 1)))))
+(renumber-ops)
+*/
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
+++ /dev/null
-/* Copyright (C) 2001, 2009-2012, 2014 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
- */
-
-/* This file is included in vm_engine.c */
-
-\f
-/*
- * Registers
- */
-
-/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ]
-
- Some compilers underestimate the use of the local variables representing
- the abstract machine registers, and don't put them in hardware registers,
- which slows down the interpreter considerably.
- For GCC, I have hand-assigned hardware registers for several architectures.
-*/
-
-#ifdef __GNUC__
-#ifdef __mips__
-#define IP_REG asm("$16")
-#define SP_REG asm("$17")
-#define FP_REG asm("$18")
-#endif
-#ifdef __sparc__
-#define IP_REG asm("%l0")
-#define SP_REG asm("%l1")
-#define FP_REG asm("%l2")
-#endif
-#ifdef __alpha__
-#ifdef __CRAY__
-#define IP_REG asm("r9")
-#define SP_REG asm("r10")
-#define FP_REG asm("r11")
-#else
-#define IP_REG asm("$9")
-#define SP_REG asm("$10")
-#define FP_REG asm("$11")
-#endif
-#endif
-#ifdef __i386__
-/* too few registers! because of register allocation errors with various gcs,
- just punt on explicit assignments on i386, hoping that the "register"
- declaration will be sufficient. */
-#elif defined __x86_64__
-/* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works
- well. Tell it to keep the jump table in a r12, which is
- callee-saved. */
-#define JT_REG asm ("r12")
-#endif
-#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
-#define IP_REG asm("26")
-#define SP_REG asm("27")
-#define FP_REG asm("28")
-#endif
-#ifdef __hppa__
-#define IP_REG asm("%r18")
-#define SP_REG asm("%r17")
-#define FP_REG asm("%r16")
-#endif
-#ifdef __mc68000__
-#define IP_REG asm("a3")
-#define SP_REG asm("a4")
-#define FP_REG
-#endif
-#ifdef __arm__
-#define IP_REG asm("r9")
-#define SP_REG asm("r8")
-#define FP_REG
-#endif
-#endif
-
-#ifndef IP_REG
-#define IP_REG
-#endif
-#ifndef SP_REG
-#define SP_REG
-#endif
-#ifndef FP_REG
-#define FP_REG
-#endif
-#ifndef JT_REG
-#define JT_REG
-#endif
-
-\f
-/*
- * Cache/Sync
- */
-
-#define VM_ASSERT(condition, handler) \
- do { if (SCM_UNLIKELY (!(condition))) { SYNC_ALL(); handler; } } while (0)
-
-#ifdef VM_ENABLE_ASSERTIONS
-# define ASSERT(condition) VM_ASSERT (condition, abort())
-#else
-# define ASSERT(condition)
-#endif
-
-
-/* Cache the VM's instruction, stack, and frame pointer in local variables. */
-#define CACHE_REGISTER() \
-{ \
- ip = vp->ip; \
- sp = vp->sp; \
- fp = vp->fp; \
-}
-
-/* Update the registers in VP, a pointer to the current VM. This must be done
- at least before any GC invocation so that `vp->sp' is up-to-date and the
- whole stack gets marked. */
-#define SYNC_REGISTER() \
-{ \
- vp->ip = ip; \
- vp->sp = sp; \
- vp->fp = fp; \
-}
-
-/* FIXME */
-#define ASSERT_VARIABLE(x) \
- do { if (!SCM_VARIABLEP (x)) { SYNC_REGISTER (); abort(); } \
- } while (0)
-#define ASSERT_BOUND_VARIABLE(x) \
- do { ASSERT_VARIABLE (x); \
- if (scm_is_eq (SCM_VARIABLE_REF (x), SCM_UNDEFINED)) \
- { SYNC_REGISTER (); abort(); } \
- } while (0)
-
-#ifdef VM_ENABLE_PARANOID_ASSERTIONS
-#define CHECK_IP() \
- do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
-#define ASSERT_ALIGNED_PROCEDURE() \
- do { if ((scm_t_bits)bp % 8) abort (); } while (0)
-#define ASSERT_BOUND(x) \
- do { if (scm_is_eq ((x), SCM_UNDEFINED)) { SYNC_REGISTER (); abort(); } \
- } while (0)
-#else
-#define CHECK_IP()
-#define ASSERT_ALIGNED_PROCEDURE()
-#define ASSERT_BOUND(x)
-#endif
-
-#if VM_CHECK_OBJECT
-#define SET_OBJECT_COUNT(n) object_count = n
-#else
-#define SET_OBJECT_COUNT(n) /* nop */
-#endif
-
-/* Cache the object table and free variables. */
-#define CACHE_PROGRAM() \
-{ \
- if (bp != SCM_PROGRAM_DATA (program)) { \
- bp = SCM_PROGRAM_DATA (program); \
- ASSERT_ALIGNED_PROCEDURE (); \
- if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
- objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
- SET_OBJECT_COUNT (SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program))); \
- } else { \
- objects = NULL; \
- SET_OBJECT_COUNT (0); \
- } \
- } \
-}
-
-#define SYNC_BEFORE_GC() \
-{ \
- SYNC_REGISTER (); \
-}
-
-#define SYNC_ALL() \
-{ \
- SYNC_REGISTER (); \
-}
-
-\f
-/*
- * Error check
- */
-
-/* Accesses to a program's object table. */
-#if VM_CHECK_OBJECT
-#define CHECK_OBJECT(_num) \
- VM_ASSERT ((_num) < object_count, vm_error_object ())
-#else
-#define CHECK_OBJECT(_num)
-#endif
-
-#if VM_CHECK_FREE_VARIABLES
-#define CHECK_FREE_VARIABLE(_num) \
- VM_ASSERT ((_num) < SCM_PROGRAM_NUM_FREE_VARIABLES (program), \
- vm_error_free_variable ())
-#else
-#define CHECK_FREE_VARIABLE(_num)
-#endif
-
-\f
-/*
- * Hooks
- */
-
-#undef RUN_HOOK
-#undef RUN_HOOK1
-#if VM_USE_HOOKS
-#define RUN_HOOK(h) \
- { \
- if (SCM_UNLIKELY (vp->trace_level > 0)) \
- { \
- SYNC_REGISTER (); \
- vm_dispatch_hook (vm, h); \
- } \
- }
-#define RUN_HOOK1(h, x) \
- { \
- if (SCM_UNLIKELY (vp->trace_level > 0)) \
- { \
- PUSH (x); \
- SYNC_REGISTER (); \
- vm_dispatch_hook (vm, h); \
- DROP(); \
- } \
- }
-#else
-#define RUN_HOOK(h)
-#define RUN_HOOK1(h, x)
-#endif
-
-#define APPLY_HOOK() \
- RUN_HOOK (SCM_VM_APPLY_HOOK)
-#define PUSH_CONTINUATION_HOOK() \
- RUN_HOOK (SCM_VM_PUSH_CONTINUATION_HOOK)
-#define POP_CONTINUATION_HOOK(n) \
- RUN_HOOK1 (SCM_VM_POP_CONTINUATION_HOOK, SCM_I_MAKINUM (n))
-#define NEXT_HOOK() \
- RUN_HOOK (SCM_VM_NEXT_HOOK)
-#define ABORT_CONTINUATION_HOOK() \
- RUN_HOOK (SCM_VM_ABORT_CONTINUATION_HOOK)
-#define RESTORE_CONTINUATION_HOOK() \
- RUN_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK)
-
-#define VM_HANDLE_INTERRUPTS \
- SCM_ASYNC_TICK_WITH_CODE (current_thread, SYNC_REGISTER ())
-
-\f
-/*
- * Stack operation
- */
-
-#ifdef VM_ENABLE_STACK_NULLING
-# define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
-# define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
-# define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
-/* If you have a nonlocal exit in a pre-wind proc while invoking a continuation
- inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for
- that continuation doesn't have a chance to run. It's not important on a
- semantic level, but it does mess up our stack nulling -- so this macro is to
- fix that. */
-# define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
-#else
-# define CHECK_STACK_LEAKN(_n)
-# define CHECK_STACK_LEAK()
-# define NULLSTACK(_n)
-# define NULLSTACK_FOR_NONLOCAL_EXIT()
-#endif
-
-/* For this check, we don't use VM_ASSERT, because that leads to a
- per-site SYNC_ALL, which is too much code growth. The real problem
- of course is having to check for overflow all the time... */
-#define CHECK_OVERFLOW() \
- do { if (SCM_UNLIKELY (sp >= stack_limit)) goto handle_overflow; } while (0)
-
-
-#ifdef VM_CHECK_UNDERFLOW
-#define PRE_CHECK_UNDERFLOW(N) \
- VM_ASSERT (sp - (N) > SCM_FRAME_UPPER_ADDRESS (fp), vm_error_stack_underflow ())
-#define CHECK_UNDERFLOW() PRE_CHECK_UNDERFLOW (0)
-#else
-#define PRE_CHECK_UNDERFLOW(N) /* nop */
-#define CHECK_UNDERFLOW() /* nop */
-#endif
-
-
-#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
-#define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
-#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0)
-#define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while (0)
-#define POP2(x,y) do { PRE_CHECK_UNDERFLOW (2); x = *sp--; y = *sp--; NULLSTACK (2); } while (0)
-#define POP3(x,y,z) do { PRE_CHECK_UNDERFLOW (3); x = *sp--; y = *sp--; z = *sp--; NULLSTACK (3); } while (0)
-
-/* A fast CONS. This has to be fast since its used, for instance, by
- POP_LIST when fetching a function's argument list. Note: `scm_cell' is an
- inlined function in Guile 1.7. Unfortunately, it calls
- `scm_gc_for_newcell ()' which is _not_ inlined and allocated cells on the
- heap. XXX */
-#define CONS(x,y,z) \
-{ \
- SYNC_BEFORE_GC (); \
- x = scm_cell (SCM_UNPACK (y), SCM_UNPACK (z)); \
-}
-
-/* Pop the N objects on top of the stack and push a list that contains
- them. */
-#define POP_LIST(n) \
-do \
-{ \
- int i; \
- SCM l = SCM_EOL, x; \
- for (i = n; i; i--) \
- { \
- POP (x); \
- CONS (l, x, l); \
- } \
- PUSH (l); \
-} while (0)
-
-/* The opposite: push all of the elements in L onto the list. */
-#define PUSH_LIST(l, NILP) \
-do \
-{ \
- for (; scm_is_pair (l); l = SCM_CDR (l)) \
- PUSH (SCM_CAR (l)); \
- VM_ASSERT (NILP (l), vm_error_improper_list (l)); \
-} while (0)
-
-\f
-#define POP_LIST_MARK() \
-do { \
- SCM o; \
- SCM l = SCM_EOL; \
- POP (o); \
- while (!SCM_UNBNDP (o)) \
- { \
- CONS (l, o, l); \
- POP (o); \
- } \
- PUSH (l); \
-} while (0)
-
-#define POP_CONS_MARK() \
-do { \
- SCM o, l; \
- POP (l); \
- POP (o); \
- while (!SCM_UNBNDP (o)) \
- { \
- CONS (l, o, l); \
- POP (o); \
- } \
- PUSH (l); \
-} while (0)
-
-\f
-/*
- * Instruction operation
- */
-
-#define FETCH() (*ip++)
-#define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)
-
-#undef NEXT_JUMP
-#ifdef HAVE_LABELS_AS_VALUES
-#define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK]
-#else
-#define NEXT_JUMP() goto vm_start
-#endif
-
-#define NEXT \
-{ \
- NEXT_HOOK (); \
- CHECK_STACK_LEAK (); \
- NEXT_JUMP (); \
-}
-
-\f
-/* 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 DROP_FRAME() \
- { \
- sp -= 3; \
- NULLSTACK (3); \
- CHECK_UNDERFLOW (); \
- }
-
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+++ /dev/null
-/* Copyright (C) 2001,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * 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
- */
-
-/* FIXME! Need to check that the fetch is within the current program */
-
-/* This file is included in vm_engine.c */
-
-VM_DEFINE_LOADER (101, load_number, "load-number")
-{
- size_t len;
-
- FETCH_LENGTH (len);
- SYNC_REGISTER ();
- PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len),
- SCM_UNDEFINED /* radix = 10 */));
- /* Was: scm_istring2number (ip, len, 10)); */
- ip += len;
- NEXT;
-}
-
-VM_DEFINE_LOADER (102, load_string, "load-string")
-{
- size_t len;
- char *buf;
-
- FETCH_LENGTH (len);
- SYNC_REGISTER ();
- PUSH (scm_i_make_string (len, &buf, 1));
- memcpy (buf, (char *) ip, len);
- ip += len;
- NEXT;
-}
-
-VM_DEFINE_LOADER (103, load_symbol, "load-symbol")
-{
- size_t len;
- FETCH_LENGTH (len);
- SYNC_REGISTER ();
- /* FIXME: should be scm_from_latin1_symboln */
- PUSH (scm_from_latin1_symboln ((const char*)ip, len));
- ip += len;
- NEXT;
-}
-
-VM_DEFINE_LOADER (104, load_program, "load-program")
-{
- scm_t_uint32 len;
- SCM objs, objcode;
-
- POP (objs);
- SYNC_REGISTER ();
-
- if (scm_is_vector (objs) && scm_is_false (scm_c_vector_ref (objs, 0)))
- scm_c_vector_set_x (objs, 0, scm_current_module ());
-
- objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip);
- len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
-
- PUSH (scm_make_program (objcode, objs, SCM_BOOL_F));
-
- ip += len;
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (105, link_now, "link-now", 0, 1, 1)
-{
- SCM what;
- POP (what);
- SYNC_REGISTER ();
- PUSH (resolve_variable (what, scm_current_module ()));
- NEXT;
-}
-
-VM_DEFINE_LOADER (106, load_array, "load-array")
-{
- SCM type, shape;
- size_t len;
- FETCH_LENGTH (len);
- POP2 (shape, type);
- SYNC_REGISTER ();
- PUSH (scm_from_contiguous_typed_array (type, shape, ip, len));
- ip += len;
- NEXT;
-}
-
-VM_DEFINE_LOADER (107, load_wide_string, "load-wide-string")
-{
- size_t len;
- scm_t_wchar *wbuf;
-
- FETCH_LENGTH (len);
- VM_ASSERT ((len % 4) == 0,
- vm_error_bad_wide_string_length (len));
-
- SYNC_REGISTER ();
- PUSH (scm_i_make_wide_string (len / 4, &wbuf, 1));
- memcpy ((char *) wbuf, (char *) ip, len);
- ip += len;
- NEXT;
-}
-
-/*
-(defun renumber-ops ()
- "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
- (interactive "")
- (save-excursion
- (let ((counter 100)) (goto-char (point-min))
- (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
- (replace-match
- (number-to-string (setq counter (1+ counter)))
- t t nil 1)))))
-*/
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+++ /dev/null
-/* Copyright (C) 2001, 2009-2014 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
- */
-
-/* This file is included in vm_engine.c */
-
-\f
-/*
- * Predicates
- */
-
-#define ARGS1(a1) SCM a1 = sp[0];
-#define ARGS2(a1,a2) SCM a1 = sp[-1], a2 = sp[0]; sp--; NULLSTACK (1);
-#define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; NULLSTACK (2);
-
-#define RETURN(x) do { *sp = x; NEXT; } while (0)
-
-VM_DEFINE_FUNCTION (128, not, "not", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (scm_is_false (x)));
-}
-
-VM_DEFINE_FUNCTION (129, not_not, "not-not", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (!scm_is_false (x)));
-}
-
-VM_DEFINE_FUNCTION (130, eq, "eq?", 2)
-{
- ARGS2 (x, y);
- RETURN (scm_from_bool (scm_is_eq (x, y)));
-}
-
-VM_DEFINE_FUNCTION (131, not_eq, "not-eq?", 2)
-{
- ARGS2 (x, y);
- RETURN (scm_from_bool (!scm_is_eq (x, y)));
-}
-
-VM_DEFINE_FUNCTION (132, nullp, "null?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (scm_is_null (x)));
-}
-
-VM_DEFINE_FUNCTION (133, not_nullp, "not-null?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (!scm_is_null (x)));
-}
-
-VM_DEFINE_FUNCTION (134, eqv, "eqv?", 2)
-{
- ARGS2 (x, y);
- if (scm_is_eq (x, y))
- RETURN (SCM_BOOL_T);
- if (SCM_IMP (x) || SCM_IMP (y))
- RETURN (SCM_BOOL_F);
- SYNC_REGISTER ();
- RETURN (scm_eqv_p (x, y));
-}
-
-VM_DEFINE_FUNCTION (135, equal, "equal?", 2)
-{
- ARGS2 (x, y);
- if (scm_is_eq (x, y))
- RETURN (SCM_BOOL_T);
- if (SCM_IMP (x) || SCM_IMP (y))
- RETURN (SCM_BOOL_F);
- SYNC_REGISTER ();
- RETURN (scm_equal_p (x, y));
-}
-
-VM_DEFINE_FUNCTION (136, pairp, "pair?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (scm_is_pair (x)));
-}
-
-VM_DEFINE_FUNCTION (137, listp, "list?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (scm_ilength (x) >= 0));
-}
-
-VM_DEFINE_FUNCTION (138, symbolp, "symbol?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (scm_is_symbol (x)));
-}
-
-VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1)
-{
- ARGS1 (x);
- RETURN (scm_from_bool (SCM_I_IS_VECTOR (x)));
-}
-
-\f
-/*
- * Basic data
- */
-
-VM_DEFINE_FUNCTION (140, cons, "cons", 2)
-{
- ARGS2 (x, y);
- CONS (x, x, y);
- RETURN (x);
-}
-
-#define VM_VALIDATE_CONS(x, proc) \
- VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x))
-
-VM_DEFINE_FUNCTION (141, car, "car", 1)
-{
- ARGS1 (x);
- VM_VALIDATE_CONS (x, "car");
- RETURN (SCM_CAR (x));
-}
-
-VM_DEFINE_FUNCTION (142, cdr, "cdr", 1)
-{
- ARGS1 (x);
- VM_VALIDATE_CONS (x, "cdr");
- RETURN (SCM_CDR (x));
-}
-
-VM_DEFINE_INSTRUCTION (143, set_car, "set-car!", 0, 2, 0)
-{
- SCM x, y;
- POP2 (y, x);
- VM_VALIDATE_CONS (x, "set-car!");
- SCM_SETCAR (x, y);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (144, set_cdr, "set-cdr!", 0, 2, 0)
-{
- SCM x, y;
- POP2 (y, x);
- VM_VALIDATE_CONS (x, "set-cdr!");
- SCM_SETCDR (x, y);
- NEXT;
-}
-
-\f
-/*
- * Numeric relational tests
- */
-
-#undef REL
-#define REL(crel,srel) \
- { \
- ARGS2 (x, y); \
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
- RETURN (scm_from_bool (((scm_t_signed_bits) SCM_UNPACK (x)) \
- crel ((scm_t_signed_bits) SCM_UNPACK (y)))); \
- SYNC_REGISTER (); \
- RETURN (srel (x, y)); \
- }
-
-VM_DEFINE_FUNCTION (145, ee, "ee?", 2)
-{
- REL (==, scm_num_eq_p);
-}
-
-VM_DEFINE_FUNCTION (146, lt, "lt?", 2)
-{
- REL (<, scm_less_p);
-}
-
-VM_DEFINE_FUNCTION (147, le, "le?", 2)
-{
- REL (<=, scm_leq_p);
-}
-
-VM_DEFINE_FUNCTION (148, gt, "gt?", 2)
-{
- REL (>, scm_gr_p);
-}
-
-VM_DEFINE_FUNCTION (149, ge, "ge?", 2)
-{
- REL (>=, scm_geq_p);
-}
-
-\f
-/*
- * Numeric functions
- */
-
-/* The maximum/minimum tagged integers. */
-#undef INUM_MAX
-#undef INUM_MIN
-#undef INUM_STEP
-#define INUM_MAX \
- ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)))
-#define INUM_MIN \
- ((scm_t_signed_bits) SCM_UNPACK (SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)))
-#define INUM_STEP \
- ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \
- - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0))
-
-#undef FUNC2
-#define FUNC2(CFUNC,SFUNC) \
-{ \
- ARGS2 (x, y); \
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
- { \
- scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\
- if (SCM_FIXABLE (n)) \
- RETURN (SCM_I_MAKINUM (n)); \
- } \
- SYNC_REGISTER (); \
- RETURN (SFUNC (x, y)); \
-}
-
-/* Assembly tagged integer arithmetic routines. This code uses the
- `asm goto' feature introduced in GCC 4.5. */
-
-#if SCM_GNUC_PREREQ (4, 5) && (defined __x86_64__ || defined __i386__)
-
-# undef _CX
-# if SIZEOF_VOID_P == 8
-# define _CX "rcx"
-# elif SIZEOF_VOID_P == 4
-# define _CX "ecx"
-# else
-# error unsupported word size
-# endif
-
-/* The macros below check the CPU's overflow flag to improve fixnum
- arithmetic. The _CX register (%rcx or %ecx) is explicitly
- clobbered because `asm goto' can't have outputs, in which case the
- `r' constraint could be used to let the register allocator choose a
- register.
-
- TODO: Use `cold' label attribute in GCC 4.6.
- http://gcc.gnu.org/ml/gcc-patches/2010-10/msg01777.html */
-
-# define ASM_ADD(x, y) \
- { \
- asm volatile goto ("mov %1, %%"_CX"; " \
- "test %[tag], %%cl; je %l[slow_add]; " \
- "test %[tag], %0; je %l[slow_add]; " \
- "sub %[tag], %%"_CX"; " \
- "add %0, %%"_CX"; jo %l[slow_add]; " \
- "mov %%"_CX", (%[vsp])\n" \
- : /* no outputs */ \
- : "r" (x), "r" (y), \
- [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \
- : _CX, "memory", "cc" \
- : slow_add); \
- NEXT; \
- } \
- slow_add: \
- do { } while (0)
-
-# define ASM_SUB(x, y) \
- { \
- asm volatile goto ("mov %0, %%"_CX"; " \
- "test %[tag], %%cl; je %l[slow_sub]; " \
- "test %[tag], %1; je %l[slow_sub]; " \
- "sub %1, %%"_CX"; jo %l[slow_sub]; " \
- "add %[tag], %%"_CX"; " \
- "mov %%"_CX", (%[vsp])\n" \
- : /* no outputs */ \
- : "r" (x), "r" (y), \
- [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \
- : _CX, "memory", "cc" \
- : slow_sub); \
- NEXT; \
- } \
- slow_sub: \
- do { } while (0)
-
-# define ASM_MUL(x, y) \
- { \
- scm_t_signed_bits xx = SCM_I_INUM (x); \
- asm volatile goto ("mov %1, %%"_CX"; " \
- "test %[tag], %%cl; je %l[slow_mul]; " \
- "sub %[tag], %%"_CX"; " \
- "test %[tag], %0; je %l[slow_mul]; " \
- "imul %2, %%"_CX"; jo %l[slow_mul]; " \
- "add %[tag], %%"_CX"; " \
- "mov %%"_CX", (%[vsp])\n" \
- : /* no outputs */ \
- : "r" (x), "r" (y), "r" (xx), \
- [vsp] "r" (sp), [tag] "i" (scm_tc2_int) \
- : _CX, "memory", "cc" \
- : slow_mul); \
- NEXT; \
- } \
- slow_mul: \
- do { } while (0)
-
-#endif
-
-#if SCM_GNUC_PREREQ (4, 5) && defined __arm__
-
-# define ASM_ADD(x, y) \
- if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \
- { \
- asm volatile goto ("adds r0, %0, %1; bvs %l[slow_add]; " \
- "str r0, [%[vsp]]\n" \
- : /* no outputs */ \
- : "r" (x), "r" (y - scm_tc2_int), \
- [vsp] "r" (sp) \
- : "r0", "memory", "cc" \
- : slow_add); \
- NEXT; \
- } \
- slow_add: \
- do { } while (0)
-
-# define ASM_SUB(x, y) \
- if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \
- { \
- asm volatile goto ("subs r0, %0, %1; bvs %l[slow_sub]; " \
- "str r0, [%[vsp]]\n" \
- : /* no outputs */ \
- : "r" (x), "r" (y - scm_tc2_int), \
- [vsp] "r" (sp) \
- : "r0", "memory", "cc" \
- : slow_sub); \
- NEXT; \
- } \
- slow_sub: \
- do { } while (0)
-
-# if defined (__ARM_ARCH_3M__) || defined (__ARM_ARCH_4__) \
- || defined (__ARM_ARCH_4T__) || defined (__ARM_ARCH_5__) \
- || defined (__ARM_ARCH_5T__) || defined (__ARM_ARCH_5E__) \
- || defined (__ARM_ARCH_5TE__) || defined (__ARM_ARCH_5TEJ__) \
- || defined (__ARM_ARCH_6__) || defined (__ARM_ARCH_6J__) \
- || defined (__ARM_ARCH_6K__) || defined (__ARM_ARCH_6Z__) \
- || defined (__ARM_ARCH_6ZK__) || defined (__ARM_ARCH_6T2__) \
- || defined (__ARM_ARCH_6M__) || defined (__ARM_ARCH_7__) \
- || defined (__ARM_ARCH_7A__) || defined (__ARM_ARCH_7R__) \
- || defined (__ARM_ARCH_7M__) || defined (__ARM_ARCH_7EM__) \
- || defined (__ARM_ARCH_8A__)
-
-/* The ARM architectures listed above support the SMULL instruction */
-
-# define ASM_MUL(x, y) \
- if (SCM_LIKELY (SCM_I_INUMP (x) && SCM_I_INUMP (y))) \
- { \
- scm_t_signed_bits rlo, rhi; \
- asm ("smull %0, %1, %2, %3\n" \
- : "=&r" (rlo), "=&r" (rhi) \
- : "r" (SCM_UNPACK (x) - scm_tc2_int), \
- "r" (SCM_I_INUM (y))); \
- if (SCM_LIKELY (SCM_SRS (rlo, 31) == rhi)) \
- RETURN (SCM_PACK (rlo + scm_tc2_int)); \
- } \
- do { } while (0)
-
-# endif
-
-#endif
-
-VM_DEFINE_FUNCTION (150, add, "add", 2)
-{
-#ifndef ASM_ADD
- FUNC2 (+, scm_sum);
-#else
- ARGS2 (x, y);
- ASM_ADD (x, y);
- SYNC_REGISTER ();
- RETURN (scm_sum (x, y));
-#endif
-}
-
-VM_DEFINE_FUNCTION (151, add1, "add1", 1)
-{
- ARGS1 (x);
-
- /* Check for overflow. We must avoid overflow in the signed
- addition below, even if X is not an inum. */
- if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP))
- {
- SCM result;
-
- /* Add 1 to the integer without untagging. */
- result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP);
-
- if (SCM_LIKELY (SCM_I_INUMP (result)))
- RETURN (result);
- }
-
- SYNC_REGISTER ();
- RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
-}
-
-VM_DEFINE_FUNCTION (152, sub, "sub", 2)
-{
-#ifndef ASM_SUB
- FUNC2 (-, scm_difference);
-#else
- ARGS2 (x, y);
- ASM_SUB (x, y);
- SYNC_REGISTER ();
- RETURN (scm_difference (x, y));
-#endif
-}
-
-VM_DEFINE_FUNCTION (153, sub1, "sub1", 1)
-{
- ARGS1 (x);
-
- /* Check for overflow. We must avoid overflow in the signed
- subtraction below, even if X is not an inum. */
- if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP))
- {
- SCM result;
-
- /* Substract 1 from the integer without untagging. */
- result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP);
-
- if (SCM_LIKELY (SCM_I_INUMP (result)))
- RETURN (result);
- }
-
- SYNC_REGISTER ();
- RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
-}
-
-VM_DEFINE_FUNCTION (154, mul, "mul", 2)
-{
- ARGS2 (x, y);
-#ifdef ASM_MUL
- ASM_MUL (x, y);
-#endif
- SYNC_REGISTER ();
- RETURN (scm_product (x, y));
-}
-
-# undef ASM_ADD
-# undef ASM_SUB
-# undef ASM_MUL
-
-VM_DEFINE_FUNCTION (155, div, "div", 2)
-{
- ARGS2 (x, y);
- SYNC_REGISTER ();
- RETURN (scm_divide (x, y));
-}
-
-VM_DEFINE_FUNCTION (156, quo, "quo", 2)
-{
- ARGS2 (x, y);
- SYNC_REGISTER ();
- RETURN (scm_quotient (x, y));
-}
-
-VM_DEFINE_FUNCTION (157, rem, "rem", 2)
-{
- ARGS2 (x, y);
- SYNC_REGISTER ();
- RETURN (scm_remainder (x, y));
-}
-
-VM_DEFINE_FUNCTION (158, mod, "mod", 2)
-{
- ARGS2 (x, y);
- SYNC_REGISTER ();
- RETURN (scm_modulo (x, y));
-}
-
-VM_DEFINE_FUNCTION (159, ash, "ash", 2)
-{
- ARGS2 (x, y);
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
- {
- if (SCM_I_INUM (y) < 0)
- /* Right shift, will be a fixnum. */
- RETURN (SCM_I_MAKINUM
- (SCM_SRS (SCM_I_INUM (x),
- (-SCM_I_INUM (y) <= SCM_I_FIXNUM_BIT-1)
- ? -SCM_I_INUM (y) : SCM_I_FIXNUM_BIT-1)));
- else
- /* Left shift. See comments in scm_ash. */
- {
- scm_t_signed_bits nn, bits_to_shift;
-
- nn = SCM_I_INUM (x);
- bits_to_shift = SCM_I_INUM (y);
-
- if (bits_to_shift < SCM_I_FIXNUM_BIT-1
- && ((scm_t_bits)
- (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
- <= 1))
- RETURN (SCM_I_MAKINUM (nn < 0
- ? -(-nn << bits_to_shift)
- : (nn << bits_to_shift)));
- /* fall through */
- }
- /* fall through */
- }
- SYNC_REGISTER ();
- RETURN (scm_ash (x, y));
-}
-
-VM_DEFINE_FUNCTION (160, logand, "logand", 2)
-{
- ARGS2 (x, y);
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
- /* Compute bitwise AND without untagging */
- RETURN (SCM_PACK (SCM_UNPACK (x) & SCM_UNPACK (y)));
- SYNC_REGISTER ();
- RETURN (scm_logand (x, y));
-}
-
-VM_DEFINE_FUNCTION (161, logior, "logior", 2)
-{
- ARGS2 (x, y);
- if (SCM_I_INUMP (x) && SCM_I_INUMP (y))
- /* Compute bitwise OR without untagging */
- RETURN (SCM_PACK (SCM_UNPACK (x) | SCM_UNPACK (y)));
- SYNC_REGISTER ();
- RETURN (scm_logior (x, y));
-}
-
-VM_DEFINE_FUNCTION (162, 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
-/*
- * Vectors and arrays
- */
-
-VM_DEFINE_FUNCTION (163, vector_ref, "vector-ref", 2)
-{
- scm_t_signed_bits i = 0;
- ARGS2 (vect, idx);
- if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
- && SCM_I_INUMP (idx)
- && ((i = SCM_I_INUM (idx)) >= 0)
- && i < SCM_I_VECTOR_LENGTH (vect)))
- RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
- else
- {
- SYNC_REGISTER ();
- RETURN (scm_vector_ref (vect, idx));
- }
-}
-
-VM_DEFINE_INSTRUCTION (164, vector_set, "vector-set", 0, 3, 0)
-{
- scm_t_signed_bits i = 0;
- SCM vect, idx, val;
- POP3 (val, idx, vect);
- if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
- && SCM_I_INUMP (idx)
- && ((i = SCM_I_INUM (idx)) >= 0)
- && i < SCM_I_VECTOR_LENGTH (vect)))
- SCM_I_VECTOR_WELTS (vect)[i] = val;
- else
- {
- SYNC_REGISTER ();
- scm_vector_set_x (vect, idx, val);
- }
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (165, make_array, "make-array", 3, -1, 1)
-{
- scm_t_uint32 len;
- SCM shape, ret;
-
- len = FETCH ();
- len = (len << 8) + FETCH ();
- len = (len << 8) + FETCH ();
- POP (shape);
- SYNC_REGISTER ();
- PRE_CHECK_UNDERFLOW (len);
- ret = scm_from_contiguous_array (shape, sp - len + 1, len);
- DROPN (len);
- PUSH (ret);
- NEXT;
-}
-
-\f
-/*
- * Structs
- */
-#define VM_VALIDATE_STRUCT(obj, proc) \
- VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_struct (proc, obj))
-
-VM_DEFINE_FUNCTION (166, struct_p, "struct?", 1)
-{
- ARGS1 (obj);
- RETURN (scm_from_bool (SCM_STRUCTP (obj)));
-}
-
-VM_DEFINE_FUNCTION (167, struct_vtable, "struct-vtable", 1)
-{
- ARGS1 (obj);
- VM_VALIDATE_STRUCT (obj, "struct_vtable");
- RETURN (SCM_STRUCT_VTABLE (obj));
-}
-
-VM_DEFINE_INSTRUCTION (168, make_struct, "make-struct", 2, -1, 1)
-{
- unsigned h = FETCH ();
- unsigned l = FETCH ();
- scm_t_bits n = ((h << 8U) + l);
- SCM vtable = sp[-(n - 1)];
- const SCM *inits = sp - n + 2;
- SCM ret;
-
- SYNC_REGISTER ();
-
- if (SCM_LIKELY (SCM_STRUCTP (vtable)
- && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
- && (SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size) + 1
- == n)
- && !SCM_VTABLE_INSTANCE_FINALIZER (vtable)))
- {
- /* Verily, we are making a simple struct with the right number of
- initializers, and no finalizer. */
- ret = scm_words ((scm_t_bits)SCM_STRUCT_DATA (vtable) | scm_tc3_struct,
- n + 1);
- SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));
- memcpy (SCM_STRUCT_DATA (ret), inits, (n - 1) * sizeof (SCM));
- }
- else
- ret = scm_c_make_structv (vtable, 0, n - 1, (scm_t_bits *) inits);
-
- DROPN (n);
- PUSH (ret);
-
- NEXT;
-}
-
-VM_DEFINE_FUNCTION (169, struct_ref, "struct-ref", 2)
-{
- ARGS2 (obj, pos);
-
- if (SCM_LIKELY (SCM_STRUCTP (obj)
- && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
- SCM_VTABLE_FLAG_SIMPLE)
- && SCM_I_INUMP (pos)))
- {
- SCM vtable;
- scm_t_bits index, len;
-
- /* True, an inum is a signed value, but cast to unsigned it will
- certainly be more than the length, so we will fall through if
- index is negative. */
- index = SCM_I_INUM (pos);
- vtable = SCM_STRUCT_VTABLE (obj);
- len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
-
- if (SCM_LIKELY (index < len))
- {
- scm_t_bits *data = SCM_STRUCT_DATA (obj);
- RETURN (SCM_PACK (data[index]));
- }
- }
-
- SYNC_REGISTER ();
- RETURN (scm_struct_ref (obj, pos));
-}
-
-VM_DEFINE_FUNCTION (170, struct_set, "struct-set", 3)
-{
- ARGS3 (obj, pos, val);
-
- if (SCM_LIKELY (SCM_STRUCTP (obj)
- && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
- SCM_VTABLE_FLAG_SIMPLE)
- && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj,
- SCM_VTABLE_FLAG_SIMPLE_RW)
- && SCM_I_INUMP (pos)))
- {
- SCM vtable;
- scm_t_bits index, len;
-
- /* See above regarding index being >= 0. */
- index = SCM_I_INUM (pos);
- vtable = SCM_STRUCT_VTABLE (obj);
- len = SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size);
- if (SCM_LIKELY (index < len))
- {
- scm_t_bits *data = SCM_STRUCT_DATA (obj);
- data[index] = SCM_UNPACK (val);
- RETURN (val);
- }
- }
-
- SYNC_REGISTER ();
- RETURN (scm_struct_set_x (obj, pos, val));
-}
-
-\f
-/*
- * GOOPS support
- */
-VM_DEFINE_FUNCTION (171, class_of, "class-of", 1)
-{
- ARGS1 (obj);
- if (SCM_INSTANCEP (obj))
- RETURN (SCM_CLASS_OF (obj));
- SYNC_REGISTER ();
- RETURN (scm_class_of (obj));
-}
-
-/* FIXME: No checking whatsoever. */
-VM_DEFINE_FUNCTION (172, slot_ref, "slot-ref", 2)
-{
- size_t slot;
- ARGS2 (instance, idx);
- slot = SCM_I_INUM (idx);
- RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
-}
-
-/* FIXME: No checking whatsoever. */
-VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
-{
- SCM instance, idx, val;
- size_t slot;
- POP3 (val, idx, instance);
- slot = SCM_I_INUM (idx);
- SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
- NEXT;
-}
-
-\f
-/*
- * Bytevectors
- */
-#define VM_VALIDATE_BYTEVECTOR(x, proc) \
- VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x))
-
-#define BV_REF_WITH_ENDIANNESS(stem, fn_stem) \
-{ \
- SCM endianness; \
- POP (endianness); \
- if (scm_is_eq (endianness, scm_i_native_endianness)) \
- goto VM_LABEL (bv_##stem##_native_ref); \
- { \
- ARGS2 (bv, idx); \
- SYNC_REGISTER (); \
- RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness)); \
- } \
-}
-
-/* Return true (non-zero) if PTR has suitable alignment for TYPE. */
-#define ALIGNED_P(ptr, type) \
- ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
-
-VM_DEFINE_FUNCTION (174, bv_u16_ref, "bv-u16-ref", 3)
-BV_REF_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_FUNCTION (175, bv_s16_ref, "bv-s16-ref", 3)
-BV_REF_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_FUNCTION (176, bv_u32_ref, "bv-u32-ref", 3)
-BV_REF_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_FUNCTION (177, bv_s32_ref, "bv-s32-ref", 3)
-BV_REF_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_FUNCTION (178, bv_u64_ref, "bv-u64-ref", 3)
-BV_REF_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_FUNCTION (179, bv_s64_ref, "bv-s64-ref", 3)
-BV_REF_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_FUNCTION (180, bv_f32_ref, "bv-f32-ref", 3)
-BV_REF_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_FUNCTION (181, bv_f64_ref, "bv-f64-ref", 3)
-BV_REF_WITH_ENDIANNESS (f64, ieee_double)
-
-#undef BV_REF_WITH_ENDIANNESS
-
-#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
-{ \
- scm_t_signed_bits i; \
- const scm_t_ ## type *int_ptr; \
- ARGS2 (bv, idx); \
- \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
- i = SCM_I_INUM (idx); \
- int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
- RETURN (SCM_I_MAKINUM (*int_ptr)); \
- else \
- { \
- SYNC_REGISTER (); \
- RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \
- } \
-}
-
-#define BV_INT_REF(stem, type, size) \
-{ \
- scm_t_signed_bits i; \
- const scm_t_ ## type *int_ptr; \
- ARGS2 (bv, idx); \
- \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
- i = SCM_I_INUM (idx); \
- int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
- { \
- scm_t_ ## type x = *int_ptr; \
- if (SCM_FIXABLE (x)) \
- RETURN (SCM_I_MAKINUM (x)); \
- else \
- { \
- SYNC_REGISTER (); \
- RETURN (scm_from_ ## type (x)); \
- } \
- } \
- else \
- { \
- SYNC_REGISTER (); \
- RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \
- } \
-}
-
-#define BV_FLOAT_REF(stem, fn_stem, type, size) \
-{ \
- scm_t_signed_bits i; \
- const type *float_ptr; \
- ARGS2 (bv, idx); \
- \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \
- i = SCM_I_INUM (idx); \
- float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- SYNC_REGISTER (); \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (float_ptr, type)))) \
- RETURN (scm_from_double (*float_ptr)); \
- else \
- RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
-}
-
-VM_DEFINE_FUNCTION (182, bv_u8_ref, "bv-u8-ref", 2)
-BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
-VM_DEFINE_FUNCTION (183, bv_s8_ref, "bv-s8-ref", 2)
-BV_FIXABLE_INT_REF (s8, s8, int8, 1)
-VM_DEFINE_FUNCTION (184, bv_u16_native_ref, "bv-u16-native-ref", 2)
-BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
-VM_DEFINE_FUNCTION (185, bv_s16_native_ref, "bv-s16-native-ref", 2)
-BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
-VM_DEFINE_FUNCTION (186, bv_u32_native_ref, "bv-u32-native-ref", 2)
-#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 (187, 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 (188, bv_u64_native_ref, "bv-u64-native-ref", 2)
-BV_INT_REF (u64, uint64, 8)
-VM_DEFINE_FUNCTION (189, bv_s64_native_ref, "bv-s64-native-ref", 2)
-BV_INT_REF (s64, int64, 8)
-VM_DEFINE_FUNCTION (190, bv_f32_native_ref, "bv-f32-native-ref", 2)
-BV_FLOAT_REF (f32, ieee_single, float, 4)
-VM_DEFINE_FUNCTION (191, bv_f64_native_ref, "bv-f64-native-ref", 2)
-BV_FLOAT_REF (f64, ieee_double, double, 8)
-
-#undef BV_FIXABLE_INT_REF
-#undef BV_INT_REF
-#undef BV_FLOAT_REF
-
-
-
-#define BV_SET_WITH_ENDIANNESS(stem, fn_stem) \
-{ \
- SCM endianness; \
- POP (endianness); \
- if (scm_is_eq (endianness, scm_i_native_endianness)) \
- goto VM_LABEL (bv_##stem##_native_set); \
- { \
- SCM bv, idx, val; POP3 (val, idx, bv); \
- SYNC_REGISTER (); \
- scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \
- NEXT; \
- } \
-}
-
-VM_DEFINE_INSTRUCTION (192, bv_u16_set, "bv-u16-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_INSTRUCTION (193, bv_s16_set, "bv-s16-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_INSTRUCTION (194, bv_u32_set, "bv-u32-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_INSTRUCTION (195, bv_s32_set, "bv-s32-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_INSTRUCTION (196, bv_u64_set, "bv-u64-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_INSTRUCTION (197, bv_s64_set, "bv-s64-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_INSTRUCTION (198, bv_f32_set, "bv-f32-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_INSTRUCTION (199, bv_f64_set, "bv-f64-set", 0, 4, 0)
-BV_SET_WITH_ENDIANNESS (f64, ieee_double)
-
-#undef BV_SET_WITH_ENDIANNESS
-
-#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
-{ \
- scm_t_signed_bits i, j = 0; \
- SCM bv, idx, val; \
- scm_t_ ## type *int_ptr; \
- \
- POP3 (val, idx, bv); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
- i = SCM_I_INUM (idx); \
- int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (int_ptr, scm_t_ ## type)) \
- && (SCM_I_INUMP (val)) \
- && ((j = SCM_I_INUM (val)) >= min) \
- && (j <= max))) \
- *int_ptr = (scm_t_ ## type) j; \
- else \
- { \
- SYNC_REGISTER (); \
- scm_bytevector_ ## fn_stem ## _set_x (bv, idx, val); \
- } \
- NEXT; \
-}
-
-#define BV_INT_SET(stem, type, size) \
-{ \
- scm_t_signed_bits i = 0; \
- SCM bv, idx, val; \
- scm_t_ ## type *int_ptr; \
- \
- POP3 (val, idx, bv); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
- i = SCM_I_INUM (idx); \
- int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \
- *int_ptr = scm_to_ ## type (val); \
- else \
- { \
- SYNC_REGISTER (); \
- scm_bytevector_ ## stem ## _native_set_x (bv, idx, val); \
- } \
- NEXT; \
-}
-
-#define BV_FLOAT_SET(stem, fn_stem, type, size) \
-{ \
- scm_t_signed_bits i = 0; \
- SCM bv, idx, val; \
- type *float_ptr; \
- \
- POP3 (val, idx, bv); \
- VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set"); \
- i = SCM_I_INUM (idx); \
- float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \
- \
- if (SCM_LIKELY (SCM_I_INUMP (idx) \
- && (i >= 0) \
- && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
- && (ALIGNED_P (float_ptr, type)))) \
- *float_ptr = scm_to_double (val); \
- else \
- { \
- SYNC_REGISTER (); \
- scm_bytevector_ ## fn_stem ## _native_set_x (bv, idx, val); \
- } \
- NEXT; \
-}
-
-VM_DEFINE_INSTRUCTION (200, bv_u8_set, "bv-u8-set", 0, 3, 0)
-BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (201, bv_s8_set, "bv-s8-set", 0, 3, 0)
-BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (202, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
-BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
-VM_DEFINE_INSTRUCTION (203, 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 (204, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
-#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 (205, 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 (206, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
-BV_INT_SET (u64, uint64, 8)
-VM_DEFINE_INSTRUCTION (207, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
-BV_INT_SET (s64, int64, 8)
-VM_DEFINE_INSTRUCTION (208, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
-BV_FLOAT_SET (f32, ieee_single, float, 4)
-VM_DEFINE_INSTRUCTION (209, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
-BV_FLOAT_SET (f64, ieee_double, double, 8)
-
-#undef BV_FIXABLE_INT_SET
-#undef BV_INT_SET
-#undef BV_FLOAT_SET
-
-/*
-(defun renumber-ops ()
- "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
- (interactive "")
- (save-excursion
- (let ((counter 127)) (goto-char (point-min))
- (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
- (replace-match
- (number-to-string (setq counter (1+ counter)))
- t t nil 1)))))
-*/
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+++ /dev/null
-/* Copyright (C) 2001,2008,2009,2010,2011,2012,2013 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
- */
-
-
-/* This file is included in vm_engine.c */
-
-\f
-/*
- * Basic operations
- */
-
-VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0)
-{
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0)
-{
- SCM ret;
- SCM nvalues_scm;
-
- nvalues_scm = *sp--; /* SCM_I_INUM may evaluate its argument
- more than once. */
- nvalues = SCM_I_INUM (nvalues_scm);
- NULLSTACK (1);
-
- if (nvalues == 1)
- POP (ret);
- else
- {
- SYNC_REGISTER ();
- sp -= nvalues;
- CHECK_UNDERFLOW ();
- ret = scm_c_values (sp + 1, nvalues);
- NULLSTACK (nvalues);
- }
-
- {
-#ifdef VM_ENABLE_STACK_NULLING
- SCM *old_sp = sp;
-#endif
-
- /* Restore registers */
- sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- /* 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 (old_sp - sp);
- }
-
- SYNC_ALL ();
- return ret;
-}
-
-VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0)
-{
- DROP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (3, dup, "dup", 0, 0, 1)
-{
- SCM x = *sp;
- PUSH (x);
- NEXT;
-}
-
-\f
-/*
- * Object creation
- */
-
-VM_DEFINE_INSTRUCTION (4, void, "void", 0, 0, 1)
-{
- PUSH (SCM_UNSPECIFIED);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (5, make_true, "make-true", 0, 0, 1)
-{
- PUSH (SCM_BOOL_T);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (6, make_false, "make-false", 0, 0, 1)
-{
- PUSH (SCM_BOOL_F);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (7, make_nil, "make-nil", 0, 0, 1)
-{
- PUSH (SCM_ELISP_NIL);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1)
-{
- PUSH (SCM_EOL);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1)
-{
- PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1)
-{
- PUSH (SCM_INUM0);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1)
-{
- PUSH (SCM_I_MAKINUM (1));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1)
-{
- int h = FETCH ();
- int l = FETCH ();
- PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1)
-{
- scm_t_uint64 v = 0;
- v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- PUSH (scm_from_int64 ((scm_t_int64) v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1)
-{
- scm_t_uint64 v = 0;
- v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- PUSH (scm_from_uint64 (v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1)
-{
- scm_t_uint8 v = 0;
- v = FETCH ();
-
- PUSH (SCM_MAKE_CHAR (v));
- /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())). The
- contents of SCM_MAKE_CHAR may be evaluated more than once,
- resulting in a double fetch. */
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1)
-{
- scm_t_wchar v = 0;
- v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- v <<= 8; v += FETCH ();
- PUSH (SCM_MAKE_CHAR (v));
- NEXT;
-}
-
-
-
-VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
-{
- unsigned h = FETCH ();
- unsigned l = FETCH ();
- unsigned len = ((h << 8) + l);
- POP_LIST (len);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
-{
- unsigned h = FETCH ();
- unsigned l = FETCH ();
- unsigned len = ((h << 8) + l);
- SCM vect;
-
- SYNC_REGISTER ();
- sp++; sp -= len;
- CHECK_UNDERFLOW ();
- vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F);
- memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len);
- NULLSTACK (len);
- *sp = vect;
-
- NEXT;
-}
-
-\f
-/*
- * Variable access
- */
-
-#define OBJECT_REF(i) objects[i]
-#define OBJECT_SET(i,o) objects[i] = o
-
-#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
-#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o
-
-/* For the variable operations, we _must_ obviously avoid function calls to
- `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do
- nothing more than the corresponding macros. */
-#define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
-#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
-#define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
-
-#define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (program, i)
-
-/* ref */
-
-VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1)
-{
- register unsigned objnum = FETCH ();
- CHECK_OBJECT (objnum);
- PUSH (OBJECT_REF (objnum));
- NEXT;
-}
-
-/* FIXME: necessary? elt 255 of the vector could be a vector... */
-VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1)
-{
- unsigned int objnum = FETCH ();
- objnum <<= 8;
- objnum += FETCH ();
- CHECK_OBJECT (objnum);
- PUSH (OBJECT_REF (objnum));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (21, local_ref, "local-ref", 1, 0, 1)
-{
- PUSH (LOCAL_REF (FETCH ()));
- ASSERT_BOUND (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1)
-{
- unsigned int i = FETCH ();
- i <<= 8;
- i += FETCH ();
- PUSH (LOCAL_REF (i));
- ASSERT_BOUND (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1)
-{
- PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (FETCH ()), SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1)
-{
- unsigned int i = FETCH ();
- i <<= 8;
- i += FETCH ();
- PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (i), SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 1, 1)
-{
- SCM x = *sp;
-
- /* We don't use ASSERT_VARIABLE or ASSERT_BOUND_VARIABLE here because,
- unlike in top-variable-ref, it really isn't an internal assertion
- that can be optimized out -- the variable could be coming directly
- from the user. */
- VM_ASSERT (SCM_VARIABLEP (x),
- vm_error_not_a_variable ("variable-ref", x));
-
- if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x)))
- {
- SCM var_name;
-
- SYNC_ALL ();
- /* Attempt to provide the variable name in the error message. */
- var_name = scm_module_reverse_lookup (scm_current_module (), x);
- vm_error_unbound (program, scm_is_true (var_name) ? var_name : x);
- }
- else
- {
- SCM o = VARIABLE_REF (x);
- *sp = o;
- }
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 1, 1)
-{
- SCM x = *sp;
-
- VM_ASSERT (SCM_VARIABLEP (x),
- vm_error_not_a_variable ("variable-bound?", x));
-
- *sp = scm_from_bool (VARIABLE_BOUNDP (x));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1)
-{
- unsigned objnum = FETCH ();
- SCM what, resolved;
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_REGISTER ();
- resolved = resolve_variable (what, scm_program_module (program));
- VM_ASSERT (VARIABLE_BOUNDP (resolved), vm_error_unbound (program, what));
- what = resolved;
- OBJECT_SET (objnum, what);
- }
-
- PUSH (VARIABLE_REF (what));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
-{
- SCM what, resolved;
- unsigned int objnum = FETCH ();
- objnum <<= 8;
- objnum += FETCH ();
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_REGISTER ();
- resolved = resolve_variable (what, scm_program_module (program));
- VM_ASSERT (VARIABLE_BOUNDP (resolved),
- vm_error_unbound (program, what));
- what = resolved;
- OBJECT_SET (objnum, what);
- }
-
- PUSH (VARIABLE_REF (what));
- NEXT;
-}
-
-/* set */
-
-VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0)
-{
- SCM x;
- POP (x);
- LOCAL_SET (FETCH (), x);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0)
-{
- SCM x;
- unsigned int i = FETCH ();
- i <<= 8;
- i += FETCH ();
- POP (x);
- LOCAL_SET (i, x);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0)
-{
- VM_ASSERT (SCM_VARIABLEP (sp[0]),
- vm_error_not_a_variable ("variable-set!", sp[0]));
- VARIABLE_SET (sp[0], sp[-1]);
- DROPN (2);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0)
-{
- unsigned objnum = FETCH ();
- SCM what;
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_BEFORE_GC ();
- what = resolve_variable (what, scm_program_module (program));
- OBJECT_SET (objnum, what);
- }
-
- VARIABLE_SET (what, *sp);
- DROP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
-{
- SCM what;
- unsigned int objnum = FETCH ();
- objnum <<= 8;
- objnum += FETCH ();
- CHECK_OBJECT (objnum);
- what = OBJECT_REF (objnum);
-
- if (!SCM_VARIABLEP (what))
- {
- SYNC_BEFORE_GC ();
- what = resolve_variable (what, scm_program_module (program));
- OBJECT_SET (objnum, what);
- }
-
- VARIABLE_SET (what, *sp);
- DROP ();
- NEXT;
-}
-
-\f
-/*
- * branch and jump
- */
-
-/* offset must be at least 24 bits wide, and signed */
-#define FETCH_OFFSET(offset) \
-{ \
- offset = FETCH () << 16; \
- offset += FETCH () << 8; \
- offset += FETCH (); \
- offset -= (offset & (1<<23)) << 1; \
-}
-
-#define BR(p) \
-{ \
- scm_t_int32 offset; \
- FETCH_OFFSET (offset); \
- if (p) \
- ip += offset; \
- if (offset < 0) \
- VM_HANDLE_INTERRUPTS; \
- NEXT; \
-}
-
-VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0)
-{
- scm_t_int32 offset;
- FETCH_OFFSET (offset);
- ip += offset;
- if (offset < 0)
- VM_HANDLE_INTERRUPTS;
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (scm_is_true (x));
-}
-
-VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (scm_is_false (x));
-}
-
-VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0)
-{
- SCM x, y;
- POP2 (y, x);
- BR (scm_is_eq (x, y));
-}
-
-VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0)
-{
- SCM x, y;
- POP2 (y, x);
- BR (!scm_is_eq (x, y));
-}
-
-VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (scm_is_null (x));
-}
-
-VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0)
-{
- SCM x;
- POP (x);
- BR (!scm_is_null (x));
-}
-
-\f
-/*
- * Subprogram call
- */
-
-VM_DEFINE_INSTRUCTION (41, 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 (42, 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 (43, 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 (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
-{
- scm_t_ptrdiff n;
- n = FETCH () << 8;
- n += FETCH ();
- VM_ASSERT (sp - (fp - 1) == n,
- vm_error_wrong_num_args (program));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
-{
- scm_t_ptrdiff n;
- n = FETCH () << 8;
- n += FETCH ();
- VM_ASSERT (sp - (fp - 1) >= n,
- vm_error_wrong_num_args (program));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (46, 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 (47, 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;
-}
-
-/* See also bind-optionals/shuffle-or-br below. */
-
-/* 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 (48, 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 ();
-
- VM_ASSERT ((kw_and_rest_flags & F_REST)
- || ((sp - (fp - 1) - nkw) % 2) == 0,
- vm_error_kwargs_length_not_even (program))
-
- 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;
- }
- }
- VM_ASSERT (scm_is_pair (walk)
- || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS),
- vm_error_kwargs_unrecognized_keyword (program, sp[nkw]));
- nkw++;
- }
- else
- VM_ASSERT (kw_and_rest_flags & F_REST,
- vm_error_kwargs_invalid_keyword (program, sp[nkw]));
- }
-
- NEXT;
-}
-
-#undef F_ALLOW_OTHER_KEYS
-#undef F_REST
-
-
-VM_DEFINE_INSTRUCTION (49, 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 (50, 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 (51, 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 (52, 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 */
-
- /* We don't initialize the dynamic link here because we don't actually
- know that this frame will point to the current fp: it could be
- placed elsewhere on the stack if captured in a partial
- continuation, and invoked from some other context. */
- PUSH (SCM_PACK (0)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (0)); /* ra */
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
-{
- nargs = FETCH ();
-
- vm_call:
- VM_HANDLE_INTERRUPTS;
-
- {
- SCM *old_fp = fp;
-
- fp = sp - nargs + 1;
-
- ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
- ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
- ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
- SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
- SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
- }
-
- PUSH_CONTINUATION_HOOK ();
-
- program = fp[-1];
-
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- goto apply;
-
- CACHE_PROGRAM ();
- ip = SCM_C_OBJCODE_BASE (bp);
-
- APPLY_HOOK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1)
-{
- nargs = FETCH ();
-
- vm_tail_call:
- VM_HANDLE_INTERRUPTS;
-
- {
- int i;
-#ifdef VM_ENABLE_STACK_NULLING
- SCM *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];
-
- sp = fp + i - 1;
-
- NULLSTACK (old_sp - sp);
- }
-
- program = fp[-1];
-
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- goto apply;
-
- CACHE_PROGRAM ();
- ip = SCM_C_OBJCODE_BASE (bp);
-
- APPLY_HOOK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
-{
- SCM pointer, ret;
- SCM (*subr)();
-
- nargs = FETCH ();
- POP (pointer);
-
- subr = SCM_POINTER_VALUE (pointer);
-
- VM_HANDLE_INTERRUPTS;
- SYNC_REGISTER ();
-
- switch (nargs)
- {
- case 0:
- ret = subr ();
- break;
- case 1:
- ret = subr (sp[0]);
- break;
- case 2:
- ret = subr (sp[-1], sp[0]);
- break;
- case 3:
- ret = subr (sp[-2], sp[-1], sp[0]);
- break;
- case 4:
- ret = subr (sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 5:
- ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 6:
- ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 7:
- ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 8:
- ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 9:
- ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- case 10:
- ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
- break;
- default:
- abort ();
- }
-
- NULLSTACK_FOR_NONLOCAL_EXIT ();
-
- if (SCM_UNLIKELY (SCM_VALUESP (ret)))
- {
- /* multiple values returned to continuation */
- ret = scm_struct_ref (ret, SCM_INUM0);
- nvalues = scm_ilength (ret);
- PUSH_LIST (ret, scm_is_null);
- goto vm_return_values;
- }
- else
- {
- PUSH (ret);
- goto vm_return;
- }
-}
-
-VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1)
-{
- SCM smob, ret;
- SCM (*subr)();
- nargs = FETCH ();
- POP (smob);
-
- subr = SCM_SMOB_DESCRIPTOR (smob).apply;
-
- VM_HANDLE_INTERRUPTS;
- SYNC_REGISTER ();
-
- switch (nargs)
- {
- case 0:
- ret = subr (smob);
- break;
- case 1:
- ret = subr (smob, sp[0]);
- break;
- case 2:
- ret = subr (smob, sp[-1], sp[0]);
- break;
- case 3:
- ret = subr (smob, sp[-2], sp[-1], sp[0]);
- break;
- default:
- abort ();
- }
-
- NULLSTACK_FOR_NONLOCAL_EXIT ();
-
- if (SCM_UNLIKELY (SCM_VALUESP (ret)))
- {
- /* multiple values returned to continuation */
- ret = scm_struct_ref (ret, SCM_INUM0);
- nvalues = scm_ilength (ret);
- PUSH_LIST (ret, scm_is_null);
- goto vm_return_values;
- }
- else
- {
- PUSH (ret);
- goto vm_return;
- }
-}
-
-VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1)
-{
- SCM foreign, ret;
- nargs = FETCH ();
- POP (foreign);
-
- VM_HANDLE_INTERRUPTS;
- SYNC_REGISTER ();
-
- ret = scm_i_foreign_call (foreign, sp - nargs + 1);
-
- NULLSTACK_FOR_NONLOCAL_EXIT ();
-
- if (SCM_UNLIKELY (SCM_VALUESP (ret)))
- {
- /* multiple values returned to continuation */
- ret = scm_struct_ref (ret, SCM_INUM0);
- nvalues = scm_ilength (ret);
- PUSH_LIST (ret, scm_is_null);
- goto vm_return_values;
- }
- else
- {
- PUSH (ret);
- goto vm_return;
- }
-}
-
-VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0)
-{
- SCM contregs;
- POP (contregs);
-
- SYNC_ALL ();
- scm_i_check_continuation (contregs);
- vm_return_to_continuation (scm_i_contregs_vm (contregs),
- scm_i_contregs_vm_cont (contregs),
- sp - (fp - 1), fp);
- scm_i_reinstate_continuation (contregs);
-
- /* no NEXT */
- abort ();
-}
-
-VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0)
-{
- SCM vmcont, intwinds, prevwinds;
- POP2 (intwinds, vmcont);
- SYNC_REGISTER ();
- VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont),
- vm_error_continuation_not_rewindable (vmcont));
- prevwinds = scm_i_dynwinds ();
- vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp,
- vm_cookie);
-
- /* Rewind prompt jmpbuffers, if any. */
- {
- SCM winds = scm_i_dynwinds ();
- for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds))
- if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds)))
- break;
- }
-
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
-{
- SCM x;
- POP (x);
- nargs = scm_to_int (x);
- /* FIXME: should truncate values? */
- goto vm_tail_call;
-}
-
-VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1)
-{
- SCM x;
- POP (x);
- nargs = scm_to_int (x);
- /* FIXME: should truncate values? */
- goto vm_call;
-}
-
-VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
-{
- scm_t_int32 offset;
- scm_t_uint8 *mvra;
- SCM *old_fp = fp;
-
- nargs = FETCH ();
- FETCH_OFFSET (offset);
- mvra = ip + offset;
-
- VM_HANDLE_INTERRUPTS;
-
- fp = sp - nargs + 1;
-
- ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
- ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
- ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
- SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
- SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
- SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
-
- PUSH_CONTINUATION_HOOK ();
-
- program = fp[-1];
-
- if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
- goto apply;
-
- CACHE_PROGRAM ();
- ip = SCM_C_OBJCODE_BASE (bp);
-
- APPLY_HOOK ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1)
-{
- int len;
- SCM ls;
- POP (ls);
-
- nargs = FETCH ();
- ASSERT (nargs >= 2);
-
- len = scm_ilength (ls);
- VM_ASSERT (len >= 0,
- vm_error_apply_to_non_list (ls));
- PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
-
- nargs += len - 2;
- goto vm_call;
-}
-
-VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1)
-{
- int len;
- SCM ls;
- POP (ls);
-
- nargs = FETCH ();
- ASSERT (nargs >= 2);
-
- len = scm_ilength (ls);
- VM_ASSERT (len >= 0,
- vm_error_apply_to_non_list (ls));
- PUSH_LIST (ls, SCM_NULL_OR_NIL_P);
-
- nargs += len - 2;
- goto vm_tail_call;
-}
-
-VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1)
-{
- int first;
- SCM proc, vm_cont, cont;
- POP (proc);
- SYNC_ALL ();
- vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0);
- cont = scm_i_make_continuation (&first, vm, vm_cont);
- if (first)
- {
- PUSH (SCM_PACK (0)); /* dynamic link */
- PUSH (SCM_PACK (0)); /* mvra */
- PUSH (SCM_PACK (0)); /* ra */
- PUSH (proc);
- PUSH (cont);
- nargs = 1;
- goto vm_call;
- }
- else
- {
- /* Otherwise, the vm continuation was reinstated, and
- vm_return_to_continuation pushed on one value. We know only one
- value was returned because we are in value context -- the
- previous block jumped to vm_call, not vm_mv_call, after all.
-
- So, pull our regs back down from the vp, and march on to the
- next instruction. */
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- RESTORE_CONTINUATION_HOOK ();
- NEXT;
- }
-}
-
-VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1)
-{
- int first;
- SCM proc, vm_cont, cont;
- POP (proc);
- SYNC_ALL ();
- /* In contrast to call/cc, tail-call/cc captures the continuation without the
- stack frame. */
- vm_cont = scm_i_vm_capture_stack (vp->stack_base,
- SCM_FRAME_DYNAMIC_LINK (fp),
- SCM_FRAME_LOWER_ADDRESS (fp) - 1,
- SCM_FRAME_RETURN_ADDRESS (fp),
- SCM_FRAME_MV_RETURN_ADDRESS (fp),
- 0);
- cont = scm_i_make_continuation (&first, vm, vm_cont);
- if (first)
- {
- PUSH (proc);
- PUSH (cont);
- nargs = 1;
- goto vm_tail_call;
- }
- else
- {
- /* Otherwise, cache regs and NEXT, as above. Invoking the continuation
- does a return from the frame, either to the RA or
- MVRA. */
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- /* Unfortunately we don't know whether we are at the RA, and thus
- have one value without an nvalues marker, or we are at the
- MVRA and thus have multiple values and the nvalues
- marker. Instead of adding heuristics here, we will let hook
- client code do that. */
- RESTORE_CONTINUATION_HOOK ();
- NEXT;
- }
-}
-
-VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1)
-{
- vm_return:
- POP_CONTINUATION_HOOK (1);
-
- VM_HANDLE_INTERRUPTS;
-
- {
- SCM ret;
-
- POP (ret);
-
-#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
- NULLSTACK (old_sp - sp);
-#endif
-
- /* Set return value (sp is already pushed) */
- *sp = ret;
- }
-
- /* Restore the last program */
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- CHECK_IP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (68, 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. */
- nvalues = FETCH ();
- vm_return_values:
- POP_CONTINUATION_HOOK (nvalues);
-
- VM_HANDLE_INTERRUPTS;
-
- 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;
- ip = SCM_FRAME_MV_RETURN_ADDRESS (fp);
- fp = SCM_FRAME_DYNAMIC_LINK (fp);
-
- /* Push return values, and the number of values */
- for (i = 0; i < nvalues; i++)
- *++sp = vals[i+1];
- *++sp = SCM_I_MAKINUM (nvalues);
-
- /* Finally null the end of the stack */
- NULLSTACK (vals + nvalues - sp);
- }
- else if (nvalues >= 1)
- {
- /* Multiple values for a single-valued continuation -- here's where I
- 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 = vals[1];
-
- /* Finally null the end of the stack */
- NULLSTACK (vals + nvalues - sp);
- }
- else
- {
- SYNC_ALL ();
- vm_error_no_values ();
- }
-
- /* Restore the last program */
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- CHECK_IP ();
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1)
-{
- SCM l;
-
- nvalues = FETCH ();
- ASSERT (nvalues >= 1);
-
- nvalues--;
- POP (l);
- while (scm_is_pair (l))
- {
- PUSH (SCM_CAR (l));
- l = SCM_CDR (l);
- nvalues++;
- }
- VM_ASSERT (SCM_NULL_OR_NIL_P (l), vm_error_improper_list (l));
-
- goto vm_return_values;
-}
-
-VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1)
-{
- SCM n;
- POP (n);
- nvalues = scm_to_int (n);
- ASSERT (nvalues >= 0);
- goto vm_return_values;
-}
-
-VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1)
-{
- SCM x;
- int nbinds, rest;
- POP (x);
- nvalues = scm_to_int (x);
- nbinds = FETCH ();
- rest = FETCH ();
-
- if (rest)
- nbinds--;
-
- VM_ASSERT (nvalues >= nbinds, vm_error_not_enough_values ());
-
- if (rest)
- POP_LIST (nvalues - nbinds);
- else
- DROPN (nvalues - nbinds);
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0)
-{
- SCM val;
- POP (val);
- SYNC_BEFORE_GC ();
- LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
- NEXT;
-}
-
-/* for letrec:
- (let ((a *undef*) (b *undef*) ...)
- (set! a (lambda () (b ...)))
- ...)
- */
-VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0)
-{
- SYNC_BEFORE_GC ();
- LOCAL_SET (FETCH (),
- scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
-{
- SCM v = LOCAL_REF (FETCH ());
- ASSERT_BOUND_VARIABLE (v);
- PUSH (VARIABLE_REF (v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0)
-{
- SCM v, val;
- v = LOCAL_REF (FETCH ());
- POP (val);
- ASSERT_VARIABLE (v);
- VARIABLE_SET (v, val);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1)
-{
- scm_t_uint8 idx = FETCH ();
-
- CHECK_FREE_VARIABLE (idx);
- PUSH (FREE_VARIABLE_REF (idx));
- NEXT;
-}
-
-/* no free-set -- if a var is assigned, it should be in a box */
-
-VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
-{
- SCM v;
- scm_t_uint8 idx = FETCH ();
- CHECK_FREE_VARIABLE (idx);
- v = FREE_VARIABLE_REF (idx);
- ASSERT_BOUND_VARIABLE (v);
- PUSH (VARIABLE_REF (v));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0)
-{
- SCM v, val;
- scm_t_uint8 idx = FETCH ();
- POP (val);
- CHECK_FREE_VARIABLE (idx);
- v = FREE_VARIABLE_REF (idx);
- ASSERT_BOUND_VARIABLE (v);
- VARIABLE_SET (v, val);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1)
-{
- size_t n, len;
- SCM closure;
-
- len = FETCH ();
- len <<= 8;
- len += FETCH ();
- SYNC_BEFORE_GC ();
- closure = scm_words (scm_tc7_program | (len<<16), len + 3);
- SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len]));
- SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len]));
- sp[-len] = closure;
- for (n = 0; n < len; n++)
- SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]);
- DROPN (len);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1)
-{
- SYNC_BEFORE_GC ();
- /* fixme underflow */
- PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0)
-{
- SCM x;
- unsigned int i = FETCH ();
- size_t n, len;
- i <<= 8;
- i += FETCH ();
- /* FIXME CHECK_LOCAL (i) */
- x = LOCAL_REF (i);
- /* FIXME ASSERT_PROGRAM (x); */
- len = SCM_PROGRAM_NUM_FREE_VARIABLES (x);
- for (n = 0; n < len; n++)
- SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]);
- DROPN (len);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2)
-{
- SCM sym, val;
- POP2 (sym, val);
- SYNC_REGISTER ();
- scm_define (sym, val);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1)
-{
- CHECK_UNDERFLOW ();
- SYNC_REGISTER ();
- *sp = scm_symbol_to_keyword (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1)
-{
- CHECK_UNDERFLOW ();
- SYNC_REGISTER ();
- *sp = scm_string_to_symbol (*sp);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0)
-{
- scm_t_int32 offset;
- scm_t_uint8 escape_only_p;
- SCM k, prompt;
-
- escape_only_p = FETCH ();
- FETCH_OFFSET (offset);
- POP (k);
-
- SYNC_REGISTER ();
- /* Push the prompt onto the dynamic stack. */
- prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie,
- scm_i_dynwinds ());
- scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
- if (SCM_PROMPT_SETJMP (prompt))
- {
- /* The prompt exited nonlocally. Cache the regs back from the vp, and go
- to the handler.
-
- Note, at this point, we must assume that any variable local to
- vm_engine that can be assigned *has* been assigned. So we need to pull
- all our state back from the ip/fp/sp.
- */
- CACHE_REGISTER ();
- program = SCM_FRAME_PROGRAM (fp);
- CACHE_PROGRAM ();
- /* The stack contains the values returned to this prompt, along
- with a number-of-values marker -- like an MV return. */
- ABORT_CONTINUATION_HOOK ();
- NEXT;
- }
-
- /* Otherwise setjmp returned for the first time, so we go to execute the
- prompt's body. */
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0)
-{
- SCM wind, unwind;
- POP2 (unwind, wind);
- SYNC_REGISTER ();
- /* Push wind and unwind procedures onto the dynamic stack. Note that neither
- are actually called; the compiler should emit calls to wind and unwind for
- the normal dynamic-wind control flow. */
- VM_ASSERT (scm_to_bool (scm_thunk_p (wind)),
- vm_error_not_a_thunk ("dynamic-wind", wind));
- VM_ASSERT (scm_to_bool (scm_thunk_p (unwind)),
- vm_error_not_a_thunk ("dynamic-wind", unwind));
- scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ()));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1)
-{
- unsigned n = FETCH ();
- SYNC_REGISTER ();
- PRE_CHECK_UNDERFLOW (n + 2);
- vm_abort (vm, n, vm_cookie);
- /* vm_abort should not return */
- abort ();
-}
-
-VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0)
-{
- /* A normal exit from the dynamic extent of an expression. Pop the top entry
- off of the dynamic stack. */
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0)
-{
- unsigned n = FETCH ();
- SCM wf;
-
- SYNC_REGISTER ();
- sp -= 2 * n;
- CHECK_UNDERFLOW ();
- wf = scm_i_make_with_fluids (n, sp + 1, sp + 1 + n);
- NULLSTACK (2 * n);
-
- scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0)
-{
- SCM wf;
- wf = scm_car (scm_i_dynwinds ());
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
- scm_i_swap_with_fluids (wf, current_thread->dynamic_state);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1)
-{
- size_t num;
- SCM fluids;
-
- CHECK_UNDERFLOW ();
- fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
- if (SCM_UNLIKELY (!SCM_FLUID_P (*sp))
- || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
- {
- /* Punt dynstate expansion and error handling to the C proc. */
- SYNC_REGISTER ();
- *sp = scm_fluid_ref (*sp);
- }
- else
- {
- SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num);
- if (scm_is_eq (val, SCM_UNDEFINED))
- val = SCM_I_FLUID_DEFAULT (*sp);
- VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED),
- vm_error_unbound_fluid (program, *sp));
- *sp = val;
- }
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0)
-{
- size_t num;
- SCM val, fluid, fluids;
-
- POP2 (val, fluid);
- fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
- if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
- || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
- {
- /* Punt dynstate expansion and error handling to the C proc. */
- SYNC_REGISTER ();
- scm_fluid_set_x (fluid, val);
- }
- else
- SCM_SIMPLE_VECTOR_SET (fluids, num, val);
-
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0)
-{
- scm_t_ptrdiff n;
- SCM *old_sp;
-
- /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
- n = FETCH ();
-
- VM_ASSERT (sp - (fp - 1) == (n & 0x7),
- vm_error_wrong_num_args (program));
-
- old_sp = sp;
- sp += (n >> 3);
- CHECK_OVERFLOW ();
- while (old_sp < sp)
- *++old_sp = SCM_UNDEFINED;
-
- NEXT;
-}
-
-/* Like bind-optionals/shuffle, but if there are too many positional
- arguments, jumps to the next case-lambda clause. */
-VM_DEFINE_INSTRUCTION (94, bind_optionals_shuffle_or_br, "bind-optionals/shuffle-or-br", 9, -1, -1)
-{
- SCM *walk;
- scm_t_ptrdiff nreq, nreq_and_opt, ntotal;
- scm_t_int32 offset;
- nreq = FETCH () << 8;
- nreq += FETCH ();
- nreq_and_opt = FETCH () << 8;
- nreq_and_opt += FETCH ();
- ntotal = FETCH () << 8;
- ntotal += FETCH ();
- FETCH_OFFSET (offset);
-
- /* 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++;
- if (/* If we have filled all the positionals */
- walk - fp == nreq_and_opt
- /* and there are still more arguments */
- && walk <= sp
- /* and the next argument is not a keyword, */
- && !scm_is_keyword (*walk))
- {
- /* Jump to the next case-lambda* clause. */
- ip += offset;
- }
- else
- {
- /* Otherwise, finish as in bind-optionals/shuffle: 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;
-}
-
-
-/*
-(defun renumber-ops ()
- "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
- (interactive "")
- (save-excursion
- (let ((counter -1)) (goto-char (point-min))
- (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
- (replace-match
- (number-to-string (setq counter (1+ counter)))
- t t nil 1)))))
-(renumber-ops)
-*/
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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
* 02110-1301 USA
*/
+/* For mremap(2) on GNU/Linux systems. */
+#define _GNU_SOURCE
+
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <alignof.h>
#include <string.h>
#include <stdint.h>
+#include <unistd.h>
+
+#ifdef HAVE_SYS_MMAN_H
+#include <sys/mman.h>
+#endif
#include "libguile/bdw-gc.h"
#include <gc/gc_mark.h>
#include "_scm.h"
#include "control.h"
#include "frames.h"
+#include "gc-inline.h"
#include "instructions.h"
-#include "objcodes.h"
+#include "loader.h"
#include "programs.h"
+#include "simpos.h"
#include "vm.h"
-
-#include "private-gc.h" /* scm_getenv_int */
+#include "vm-builtins.h"
static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
static SCM sym_regular;
static SCM sym_debug;
+/* The page size. */
+static size_t page_size;
+
/* The VM has a number of internal assertions that shouldn't normally be
necessary, but might be if you think you found a bug in the VM. */
-#define VM_ENABLE_ASSERTIONS
+/* #define VM_ENABLE_ASSERTIONS */
-/* We can add a mode that ensures that all stack items above the stack pointer
- are NULL. This is useful for checking the internal consistency of the VM's
- assumptions and its operators, but isn't necessary for normal operation. It
- will ensure that assertions are enabled. Slows down the VM by about 30%. */
-/* NB! If you enable this, search for NULLING in throw.c */
-/* #define VM_ENABLE_STACK_NULLING */
+static void vm_expand_stack (struct scm_vm *vp, SCM *new_sp) SCM_NOINLINE;
-/* #define VM_ENABLE_PARANOID_ASSERTIONS */
+/* RESTORE is for the case where we know we have done a PUSH of equal or
+ greater stack size in the past. Otherwise PUSH is the thing, which
+ may expand the stack. */
+enum vm_increase_sp_kind { VM_SP_PUSH, VM_SP_RESTORE };
-#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
-#define VM_ENABLE_ASSERTIONS
-#endif
+static inline void
+vm_increase_sp (struct scm_vm *vp, SCM *new_sp, enum vm_increase_sp_kind kind)
+{
+ if (new_sp <= vp->sp_max_since_gc)
+ {
+ vp->sp = new_sp;
+ return;
+ }
-/* 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
+ if (kind == VM_SP_PUSH && new_sp >= vp->stack_limit)
+ vm_expand_stack (vp, new_sp);
+ else
+ vp->sp_max_since_gc = vp->sp = new_sp;
+}
-/* Size in SCM objects of the stack reserve. The reserve is used to run
- exception handling code in case of a VM stack overflow. */
-#define VM_STACK_RESERVE_SIZE 512
+static inline void
+vm_push_sp (struct scm_vm *vp, SCM *new_sp)
+{
+ vm_increase_sp (vp, new_sp, VM_SP_PUSH);
+}
+static inline void
+vm_restore_sp (struct scm_vm *vp, SCM *new_sp)
+{
+ vm_increase_sp (vp, new_sp, VM_SP_RESTORE);
+}
\f
/*
void
scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<vm-continuation ", port);
+ scm_puts_unlocked ("#<vm-continuation ", port);
scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
-/* In theory, a number of vm instances can be active in the call trace, and we
- only want to reify the continuations of those in the current continuation
- root. I don't see a nice way to do this -- ideally it would involve dynwinds,
- and previous values of the *the-vm* fluid within the current continuation
- root. But we don't have access to continuation roots in the dynwind stack.
- So, just punt for now, we just capture the continuation for the current VM.
+int
+scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame)
+{
+ struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont);
+
+ frame->stack_holder = data;
+ frame->fp_offset = (data->fp + data->reloc) - data->stack_base;
+ frame->sp_offset = (data->sp + data->reloc) - data->stack_base;
+ frame->ip = data->ra;
- While I'm on the topic, ideally we could avoid copying the C stack if the
- continuation root is inside VM code, and call/cc was invoked within that same
- call to vm_run; but that's currently not implemented.
- */
+ return 1;
+}
+
+/* Ideally we could avoid copying the C stack if the continuation root
+ is inside VM code, and call/cc was invoked within that same call to
+ vm_run. That's currently not implemented. */
SCM
-scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra,
- scm_t_uint8 *mvra, scm_t_uint32 flags)
+scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra,
+ scm_t_dynstack *dynstack, scm_t_uint32 flags)
{
struct scm_vm_cont *p;
p->stack_size = sp - stack_base + 1;
p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
"capture_vm_cont");
-#if defined(VM_ENABLE_STACK_NULLING) && 0
- /* Tail continuations leave their frame on the stack for subsequent
- application, but don't capture the frame -- so there are some elements on
- the stack then, and this check doesn't work, so disable it for now. */
- if (sp >= vp->stack_base)
- if (!vp->sp[0] || vp->sp[1])
- abort ();
- memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
-#endif
p->ra = ra;
- p->mvra = mvra;
p->sp = sp;
p->fp = fp;
memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM));
p->reloc = p->stack_base - stack_base;
+ p->dynstack = dynstack;
p->flags = flags;
return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
}
-static void
-vm_return_to_continuation (SCM vm, SCM cont, size_t n, SCM *argv)
+struct return_to_continuation_data
{
+ struct scm_vm_cont *cp;
struct scm_vm *vp;
+};
+
+/* Called with the GC lock to prevent the stack marker from traversing a
+ stack in an inconsistent state. */
+static void *
+vm_return_to_continuation_inner (void *data_ptr)
+{
+ struct return_to_continuation_data *data = data_ptr;
+ struct scm_vm *vp = data->vp;
+ struct scm_vm_cont *cp = data->cp;
+ scm_t_ptrdiff reloc;
+
+ /* We know that there is enough space for the continuation, because we
+ captured it in the past. However there may have been an expansion
+ since the capture, so we may have to re-link the frame
+ pointers. */
+ reloc = (vp->stack_base - (cp->stack_base - cp->reloc));
+ vp->fp = cp->fp + reloc;
+ memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
+ vm_restore_sp (vp, cp->sp + reloc);
+
+ if (reloc)
+ {
+ SCM *fp = vp->fp;
+ while (fp)
+ {
+ SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp);
+ if (next_fp)
+ {
+ next_fp += reloc;
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp);
+ }
+ fp = next_fp;
+ }
+ }
+
+ return NULL;
+}
+
+static void
+vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv)
+{
struct scm_vm_cont *cp;
SCM *argv_copy;
+ struct return_to_continuation_data data;
argv_copy = alloca (n * sizeof(SCM));
memcpy (argv_copy, argv, n * sizeof(SCM));
- vp = SCM_VM_DATA (vm);
cp = SCM_VM_CONT_DATA (cont);
- if (n == 0 && !cp->mvra)
- scm_misc_error (NULL, "Too few values returned to continuation",
- SCM_EOL);
+ data.cp = cp;
+ data.vp = vp;
+ GC_call_with_alloc_lock (vm_return_to_continuation_inner, &data);
- if (vp->stack_size < cp->stack_size + n + 1)
- scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
- scm_list_2 (vm, cont));
+ /* Now we have the continuation properly copied over. We just need to
+ copy the arguments. It is not guaranteed that there is actually
+ space for the arguments, though, so we have to bump the SP first. */
+ vm_push_sp (vp, vp->sp + 3 + n);
-#ifdef VM_ENABLE_STACK_NULLING
+ /* Now copy on an empty frame and the return values, as the
+ continuation expects. */
{
- scm_t_ptrdiff nzero = (vp->sp - cp->sp);
- if (nzero > 0)
- memset (vp->stack_base + cp->stack_size, 0, nzero * sizeof (SCM));
- /* actually nzero should always be negative, because vm_reset_stack will
- unwind the stack to some point *below* this continuation */
+ SCM *base = vp->sp + 1 - 3 - n;
+ size_t i;
+
+ for (i = 0; i < 3; i++)
+ base[i] = SCM_BOOL_F;
+
+ for (i = 0; i < n; i++)
+ base[i + 3] = argv_copy[i];
}
-#endif
- vp->sp = cp->sp;
- vp->fp = cp->fp;
- memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM));
- if (n == 1 || !cp->mvra)
- {
- vp->ip = cp->ra;
- vp->sp++;
- *vp->sp = argv_copy[0];
- }
- else
- {
- size_t i;
- for (i = 0; i < n; i++)
- {
- vp->sp++;
- *vp->sp = argv_copy[i];
- }
- vp->sp++;
- *vp->sp = scm_from_size_t (n);
- vp->ip = cp->mvra;
- }
+ vp->ip = cp->ra;
}
+static struct scm_vm * thread_vm (scm_i_thread *t);
SCM
-scm_i_vm_capture_continuation (SCM vm)
+scm_i_capture_current_stack (void)
{
- struct scm_vm *vp = SCM_VM_DATA (vm);
- return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, NULL, 0);
+ scm_i_thread *thread;
+ struct scm_vm *vp;
+
+ thread = SCM_I_CURRENT_THREAD;
+ vp = thread_vm (thread);
+
+ return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip,
+ scm_dynstack_capture_all (&thread->dynstack),
+ 0);
}
+static void vm_dispatch_apply_hook (struct scm_vm *vp) SCM_NOINLINE;
+static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) SCM_NOINLINE;
+static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) SCM_NOINLINE;
+static void vm_dispatch_next_hook (struct scm_vm *vp) SCM_NOINLINE;
+static void vm_dispatch_abort_hook (struct scm_vm *vp) SCM_NOINLINE;
+
static void
-vm_dispatch_hook (SCM vm, int hook_num)
+vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n)
{
- struct scm_vm *vp;
SCM hook;
struct scm_frame c_frame;
scm_t_cell *frame;
- SCM args[1];
int saved_trace_level;
- vp = SCM_VM_DATA (vm);
hook = vp->hooks[hook_num];
if (SCM_LIKELY (scm_is_false (hook))
while the stack frame represented by the frame object is visible, so it
seems reasonable to limit the lifetime of frame objects. */
- c_frame.stack_holder = vm;
- c_frame.fp = vp->fp;
- c_frame.sp = vp->sp;
+ c_frame.stack_holder = vp;
+ c_frame.fp_offset = vp->fp - vp->stack_base;
+ c_frame.sp_offset = vp->sp - vp->stack_base;
c_frame.ip = vp->ip;
- c_frame.offset = 0;
/* Arrange for FRAME to be 8-byte aligned, like any other cell. */
frame = alloca (sizeof (*frame) + 8);
frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL);
- frame->word_0 = SCM_PACK (scm_tc7_frame);
- frame->word_1 = PTR2SCM (&c_frame);
- args[0] = PTR2SCM (frame);
+ frame->word_0 = SCM_PACK (scm_tc7_frame | (SCM_VM_FRAME_KIND_VM << 8));
+ frame->word_1 = SCM_PACK_POINTER (&c_frame);
- scm_c_run_hookn (hook, args, 1);
+ if (n == 0)
+ {
+ SCM args[1];
+
+ args[0] = SCM_PACK_POINTER (frame);
+ scm_c_run_hookn (hook, args, 1);
+ }
+ else if (n == 1)
+ {
+ SCM args[2];
+
+ args[0] = SCM_PACK_POINTER (frame);
+ args[1] = argv[0];
+ scm_c_run_hookn (hook, args, 2);
+ }
+ else
+ {
+ SCM args = SCM_EOL;
+
+ while (n--)
+ args = scm_cons (argv[n], args);
+ scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args));
+ }
vp->trace_level = saved_trace_level;
}
-static void vm_abort (SCM vm, size_t n, scm_t_int64 cookie) SCM_NORETURN;
static void
-vm_abort (SCM vm, size_t n, scm_t_int64 vm_cookie)
+vm_dispatch_apply_hook (struct scm_vm *vp)
+{
+ return vm_dispatch_hook (vp, SCM_VM_APPLY_HOOK, NULL, 0);
+}
+static void vm_dispatch_push_continuation_hook (struct scm_vm *vp)
+{
+ return vm_dispatch_hook (vp, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0);
+}
+static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp)
+{
+ return vm_dispatch_hook (vp, SCM_VM_POP_CONTINUATION_HOOK,
+ &SCM_FRAME_LOCAL (old_fp, 1),
+ SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1);
+}
+static void vm_dispatch_next_hook (struct scm_vm *vp)
+{
+ return vm_dispatch_hook (vp, SCM_VM_NEXT_HOOK, NULL, 0);
+}
+static void vm_dispatch_abort_hook (struct scm_vm *vp)
+{
+ return vm_dispatch_hook (vp, SCM_VM_ABORT_CONTINUATION_HOOK,
+ &SCM_FRAME_LOCAL (vp->fp, 1),
+ SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1);
+}
+
+static void
+vm_abort (struct scm_vm *vp, SCM tag,
+ size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
+ scm_i_jmp_buf *current_registers) SCM_NORETURN;
+
+static void
+vm_abort (struct scm_vm *vp, SCM tag,
+ size_t nstack, SCM *stack_args, SCM tail, SCM *sp,
+ scm_i_jmp_buf *current_registers)
{
size_t i;
ssize_t tail_len;
- SCM tag, tail, *argv;
+ SCM *argv;
- /* FIXME: VM_ENABLE_STACK_NULLING */
- tail = *(SCM_VM_DATA (vm)->sp--);
- /* NULLSTACK (1) */
tail_len = scm_ilength (tail);
if (tail_len < 0)
scm_misc_error ("vm-engine", "tail values to abort should be a list",
scm_list_1 (tail));
- tag = SCM_VM_DATA (vm)->sp[-n];
- argv = alloca ((n + tail_len) * sizeof (SCM));
- for (i = 0; i < n; i++)
- argv[i] = SCM_VM_DATA (vm)->sp[-(n-1-i)];
- for (; i < n + tail_len; i++, tail = scm_cdr (tail))
+ argv = alloca ((nstack + tail_len) * sizeof (SCM));
+ for (i = 0; i < nstack; i++)
+ argv[i] = stack_args[i];
+ for (; i < nstack + tail_len; i++, tail = scm_cdr (tail))
argv[i] = scm_car (tail);
- /* NULLSTACK (n + 1) */
- SCM_VM_DATA (vm)->sp -= n + 1;
- scm_c_abort (vm, tag, n + tail_len, argv, vm_cookie);
+ vp->sp = sp;
+
+ scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers);
}
-static void
-vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
- size_t n, SCM *argv, scm_t_int64 vm_cookie)
+struct vm_reinstate_partial_continuation_data
{
struct scm_vm *vp;
struct scm_vm_cont *cp;
- SCM *argv_copy, *base;
- size_t i;
-
- argv_copy = alloca (n * sizeof(SCM));
- memcpy (argv_copy, argv, n * sizeof(SCM));
+ scm_t_ptrdiff reloc;
+};
- vp = SCM_VM_DATA (vm);
- cp = SCM_VM_CONT_DATA (cont);
- base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
-
-#define RELOC(scm_p) \
- (((SCM *) (scm_p)) + cp->reloc + (base - cp->stack_base))
+static void *
+vm_reinstate_partial_continuation_inner (void *data_ptr)
+{
+ struct vm_reinstate_partial_continuation_data *data = data_ptr;
+ struct scm_vm *vp = data->vp;
+ struct scm_vm_cont *cp = data->cp;
+ SCM *base;
+ scm_t_ptrdiff reloc;
- if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
- scm_misc_error ("vm-engine",
- "not enough space to instate partial continuation",
- scm_list_2 (vm, cont));
+ base = SCM_FRAME_LOCALS_ADDRESS (vp->fp);
+ reloc = cp->reloc + (base - cp->stack_base);
memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
+ vp->fp = cp->fp + reloc;
+ vp->ip = cp->ra;
+
/* now relocate frame pointers */
{
SCM *fp;
- for (fp = RELOC (cp->fp);
- SCM_FRAME_LOWER_ADDRESS (fp) > base;
+ for (fp = vp->fp;
+ SCM_FRAME_LOWER_ADDRESS (fp) >= base;
fp = SCM_FRAME_DYNAMIC_LINK (fp))
- SCM_FRAME_SET_DYNAMIC_LINK (fp, RELOC (SCM_FRAME_DYNAMIC_LINK (fp)));
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_FRAME_DYNAMIC_LINK (fp) + reloc);
}
- vp->sp = base - 1 + cp->stack_size;
- vp->fp = RELOC (cp->fp);
- vp->ip = cp->mvra;
+ data->reloc = reloc;
- /* now push args. ip is in a MV context. */
- for (i = 0; i < n; i++)
- {
- vp->sp++;
- *vp->sp = argv_copy[i];
- }
- vp->sp++;
- *vp->sp = scm_from_size_t (n);
+ return NULL;
+}
- /* Finally, rewind the dynamic state.
+static void
+vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont,
+ size_t n, SCM *argv,
+ scm_t_dynstack *dynstack,
+ scm_i_jmp_buf *registers)
+{
+ struct vm_reinstate_partial_continuation_data data;
+ struct scm_vm_cont *cp;
+ SCM *argv_copy;
+ scm_t_ptrdiff reloc;
+ size_t i;
- We have to treat prompts specially, because we could be rewinding the
- dynamic state from a different thread, or just a different position on the
- C and/or VM stack -- so we need to reset the jump buffers so that an abort
- comes back here, with appropriately adjusted sp and fp registers. */
- {
- long delta = 0;
- SCM newwinds = scm_i_dynwinds ();
- for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--)
- {
- SCM x = scm_car (intwinds);
- if (SCM_PROMPT_P (x))
- /* the jmpbuf will be reset by our caller */
- x = scm_c_make_prompt (SCM_PROMPT_TAG (x),
- RELOC (SCM_PROMPT_REGISTERS (x)->fp),
- RELOC (SCM_PROMPT_REGISTERS (x)->sp),
- SCM_PROMPT_REGISTERS (x)->ip,
- SCM_PROMPT_ESCAPE_P (x),
- vm_cookie,
- newwinds);
- newwinds = scm_cons (x, newwinds);
- }
- scm_dowinds (newwinds, delta);
- }
-#undef RELOC
-}
+ argv_copy = alloca (n * sizeof(SCM));
+ memcpy (argv_copy, argv, n * sizeof(SCM));
-\f
-/*
- * VM Internal functions
- */
+ cp = SCM_VM_CONT_DATA (cont);
-void
-scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
-{
- const struct scm_vm *vm;
+ vm_push_sp (vp, SCM_FRAME_LOCALS_ADDRESS (vp->fp) + cp->stack_size + n - 1);
- vm = SCM_VM_DATA (x);
+ data.vp = vp;
+ data.cp = cp;
+ GC_call_with_alloc_lock (vm_reinstate_partial_continuation_inner, &data);
+ reloc = data.reloc;
- scm_puts ("#<vm ", port);
- switch (vm->engine)
- {
- case SCM_VM_REGULAR_ENGINE:
- scm_puts ("regular-engine ", port);
- break;
+ /* Push the arguments. */
+ for (i = 0; i < n; i++)
+ vp->sp[i + 1 - n] = argv_copy[i];
- case SCM_VM_DEBUG_ENGINE:
- scm_puts ("debug-engine ", port);
- break;
+ /* The prompt captured a slice of the dynamic stack. Here we wind
+ those entries onto the current thread's stack. We also have to
+ relocate any prompts that we see along the way. */
+ {
+ scm_t_bits *walk;
- default:
- scm_puts ("unknown-engine ", port);
- }
- scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
+ for (walk = SCM_DYNSTACK_FIRST (cp->dynstack);
+ SCM_DYNSTACK_TAG (walk);
+ walk = SCM_DYNSTACK_NEXT (walk))
+ {
+ scm_t_bits tag = SCM_DYNSTACK_TAG (walk);
+
+ if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT)
+ scm_dynstack_wind_prompt (dynstack, walk, reloc, registers);
+ else
+ scm_dynstack_wind_1 (dynstack, walk);
+ }
+ }
}
\f
*/
static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
-static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN;
-static void vm_error_unbound (SCM proc, SCM sym) SCM_NORETURN;
-static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN;
-static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN;
-static void vm_error_not_a_thunk (const char *func_name, SCM x) SCM_NORETURN;
-static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN;
-static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN;
-static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN;
-static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN;
-static void vm_error_too_many_args (int nargs) SCM_NORETURN;
-static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN;
-static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN;
-static void vm_error_stack_overflow (struct scm_vm *vp) SCM_NORETURN;
-static void vm_error_stack_underflow (void) SCM_NORETURN;
-static void vm_error_improper_list (SCM x) SCM_NORETURN;
-static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN;
-static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN;
-static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN;
-static void vm_error_no_values (void) SCM_NORETURN;
-static void vm_error_not_enough_values (void) SCM_NORETURN;
-static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN;
-static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN;
-#if VM_CHECK_IP
-static void vm_error_invalid_address (void) SCM_NORETURN;
-#endif
-#if VM_CHECK_OBJECT
-static void vm_error_object (void) SCM_NORETURN;
-#endif
-#if VM_CHECK_FREE_VARIABLES
-static void vm_error_free_variable (void) SCM_NORETURN;
-#endif
+static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_unbound (SCM sym) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_unbound_fluid (SCM fluid) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_out_of_range (const char *subr, SCM k) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE;
static void
vm_error (const char *msg, SCM arg)
}
static void
-vm_error_unbound (SCM proc, SCM sym)
+vm_error_unbound (SCM sym)
{
- scm_error_scm (scm_misc_error_key, proc,
+ scm_error_scm (scm_misc_error_key, SCM_BOOL_F,
scm_from_latin1_string ("Unbound variable: ~s"),
scm_list_1 (sym), SCM_BOOL_F);
}
static void
-vm_error_unbound_fluid (SCM proc, SCM fluid)
+vm_error_unbound_fluid (SCM fluid)
{
- scm_error_scm (scm_misc_error_key, proc,
+ scm_error_scm (scm_misc_error_key, SCM_BOOL_F,
scm_from_latin1_string ("Unbound fluid: ~s"),
scm_list_1 (fluid), SCM_BOOL_F);
}
scm_list_1 (x), scm_list_1 (x));
}
-static void
-vm_error_not_a_thunk (const char *func_name, SCM x)
-{
- scm_error (scm_arg_type_key, func_name, "Not a thunk: ~S",
- scm_list_1 (x), scm_list_1 (x));
-}
-
static void
vm_error_apply_to_non_list (SCM x)
{
scm_list_1 (proc), scm_list_1 (proc));
}
-/* Reinstate the stack reserve in the VM pointed to by DATA. */
-static void
-reinstate_stack_reserve (void *data)
-{
- struct scm_vm *vp = data;
-
- vp->stack_limit -= VM_STACK_RESERVE_SIZE;
-}
-
-static void
-vm_error_stack_overflow (struct scm_vm *vp)
-{
- if (vp->stack_limit < vp->stack_base + vp->stack_size)
- /* There are VM_STACK_RESERVE_SIZE bytes left. Make them available so
- that `throw' below can run on this VM. */
- vp->stack_limit = vp->stack_base + vp->stack_size;
- else
- /* There is no space left on the stack. FIXME: Do something more
- sensible here! */
- abort ();
-
- /* Before throwing, install a handler that reinstates the reserve so
- that subsequent overflows are gracefully handled. */
- scm_dynwind_begin (0);
- scm_dynwind_unwind_handler (reinstate_stack_reserve, vp, 0);
- vm_error ("VM: Stack overflow", SCM_UNDEFINED);
- scm_dynwind_end ();
-}
-
static void
vm_error_stack_underflow (void)
{
}
static void
-vm_error_no_values (void)
+vm_error_not_a_vector (const char *subr, SCM x)
{
- vm_error ("Zero values returned to single-valued continuation",
- SCM_UNDEFINED);
+ scm_wrong_type_arg_msg (subr, 1, x, "vector");
}
static void
-vm_error_not_enough_values (void)
+vm_error_out_of_range (const char *subr, SCM k)
{
- vm_error ("Too few values returned to continuation", SCM_UNDEFINED);
+ scm_to_size_t (k);
+ scm_out_of_range (subr, k);
}
static void
-vm_error_continuation_not_rewindable (SCM cont)
+vm_error_no_values (void)
{
- vm_error ("Unrewindable partial continuation", cont);
+ vm_error ("Zero values returned to single-valued continuation",
+ SCM_UNDEFINED);
}
static void
-vm_error_bad_wide_string_length (size_t len)
+vm_error_not_enough_values (void)
{
- vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len));
+ vm_error ("Too few values returned to continuation", SCM_UNDEFINED);
}
-#ifdef VM_CHECK_IP
static void
-vm_error_invalid_address (void)
+vm_error_wrong_number_of_values (scm_t_uint32 expected)
{
- vm_error ("VM: Invalid program address", SCM_UNDEFINED);
+ vm_error ("Wrong number of values returned to continuation (expected ~a)",
+ scm_from_uint32 (expected));
}
-#endif
-#if VM_CHECK_OBJECT
static void
-vm_error_object ()
+vm_error_continuation_not_rewindable (SCM cont)
{
- vm_error ("VM: Invalid object table access", SCM_UNDEFINED);
+ vm_error ("Unrewindable partial continuation", cont);
}
-#endif
-#if VM_CHECK_FREE_VARIABLES
static void
-vm_error_free_variable ()
+vm_error_bad_wide_string_length (size_t len)
{
- vm_error ("VM: Invalid free variable access", SCM_UNDEFINED);
+ vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len));
}
-#endif
+
\f
-static SCM boot_continuation;
+static SCM vm_boot_continuation;
+static SCM vm_builtin_apply;
+static SCM vm_builtin_values;
+static SCM vm_builtin_abort_to_prompt;
+static SCM vm_builtin_call_with_values;
+static SCM vm_builtin_call_with_current_continuation;
+
+static const scm_t_uint32 vm_boot_continuation_code[] = {
+ SCM_PACK_OP_24 (halt, 0)
+};
+
+static const scm_t_uint32 vm_builtin_apply_code[] = {
+ SCM_PACK_OP_24 (assert_nargs_ge, 3),
+ SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */
+};
+
+static const scm_t_uint32 vm_builtin_values_code[] = {
+ SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */
+};
+
+static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = {
+ SCM_PACK_OP_24 (assert_nargs_ge, 2),
+ SCM_PACK_OP_24 (abort, 0), /* tag in r1, vals from r2 */
+ /* FIXME: Partial continuation should capture caller regs. */
+ SCM_PACK_OP_24 (return_values, 0) /* vals from r1 */
+};
+
+static const scm_t_uint32 vm_builtin_call_with_values_code[] = {
+ SCM_PACK_OP_24 (assert_nargs_ee, 3),
+ SCM_PACK_OP_24 (alloc_frame, 7),
+ SCM_PACK_OP_12_12 (mov, 6, 1),
+ SCM_PACK_OP_24 (call, 6), SCM_PACK_OP_ARG_8_24 (0, 1),
+ SCM_PACK_OP_12_12 (mov, 0, 2),
+ SCM_PACK_OP_24 (tail_call_shuffle, 7)
+};
+
+static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = {
+ SCM_PACK_OP_24 (assert_nargs_ee, 2),
+ SCM_PACK_OP_24 (call_cc, 0)
+};
-\f
-/*
- * VM
- */
static SCM
-resolve_variable (SCM what, SCM program_module)
+scm_vm_builtin_ref (unsigned idx)
{
- if (SCM_LIKELY (scm_is_symbol (what)))
+ switch (idx)
{
- if (scm_is_true (program_module))
- return scm_module_lookup (program_module, what);
- else
- return scm_module_lookup (scm_the_root_module (), what);
+#define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
+ case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
+ FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+ default: abort();
}
- else
+}
+
+SCM scm_sym_apply;
+static SCM scm_sym_values;
+static SCM scm_sym_abort_to_prompt;
+static SCM scm_sym_call_with_values;
+static SCM scm_sym_call_with_current_continuation;
+
+SCM
+scm_vm_builtin_name_to_index (SCM name)
+#define FUNC_NAME "builtin-name->index"
+{
+ SCM_VALIDATE_SYMBOL (1, name);
+
+#define NAME_TO_INDEX(builtin, BUILTIN, req, opt, rest) \
+ if (scm_is_eq (name, scm_sym_##builtin)) \
+ return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
+ FOR_EACH_VM_BUILTIN(NAME_TO_INDEX)
+#undef NAME_TO_INDEX
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM
+scm_vm_builtin_index_to_name (SCM index)
+#define FUNC_NAME "builtin-index->name"
+{
+ unsigned idx;
+
+ SCM_VALIDATE_UINT_COPY (1, index, idx);
+
+ switch (idx)
{
- SCM mod;
- /* compilation of @ or @@
- `what' is a three-element list: (MODNAME SYM INTERFACE?)
- INTERFACE? is #t if we compiled @ or #f if we compiled @@
- */
- mod = scm_resolve_module (SCM_CAR (what));
- if (scm_is_true (SCM_CADDR (what)))
- mod = scm_module_public_interface (mod);
- if (scm_is_false (mod))
- scm_misc_error (NULL, "no such module: ~S",
- scm_list_1 (SCM_CAR (what)));
- /* might longjmp */
- return scm_module_lookup (mod, SCM_CADR (what));
+#define INDEX_TO_NAME(builtin, BUILTIN, req, opt, rest) \
+ case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
+ FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+ default: return SCM_BOOL_F;
}
}
-
-#define VM_MIN_STACK_SIZE (1024)
-#define VM_DEFAULT_STACK_SIZE (64 * 1024)
-static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
+#undef FUNC_NAME
static void
-initialize_default_stack_size (void)
+scm_init_vm_builtins (void)
{
- int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size);
- if (size >= VM_MIN_STACK_SIZE)
- vm_stack_size = size;
+ scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
+ scm_vm_builtin_name_to_index);
+ scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
+ scm_vm_builtin_index_to_name);
}
-#define VM_NAME vm_regular_engine
+SCM
+scm_i_call_with_current_continuation (SCM proc)
+{
+ return scm_call_1 (vm_builtin_call_with_current_continuation, proc);
+}
+
+\f
+/*
+ * VM
+ */
+
+#define VM_NAME vm_regular_engine
+#define VM_USE_HOOKS 0
#define FUNC_NAME "vm-regular-engine"
-#define VM_ENGINE SCM_VM_REGULAR_ENGINE
#include "vm-engine.c"
-#undef VM_NAME
#undef FUNC_NAME
-#undef VM_ENGINE
+#undef VM_USE_HOOKS
+#undef VM_NAME
-#define VM_NAME vm_debug_engine
+#define VM_NAME vm_debug_engine
+#define VM_USE_HOOKS 1
#define FUNC_NAME "vm-debug-engine"
-#define VM_ENGINE SCM_VM_DEBUG_ENGINE
#include "vm-engine.c"
-#undef VM_NAME
#undef FUNC_NAME
-#undef VM_ENGINE
+#undef VM_USE_HOOKS
+#undef VM_NAME
+
+typedef SCM (*scm_t_vm_engine) (scm_i_thread *current_thread, struct scm_vm *vp,
+ scm_i_jmp_buf *registers, int resume);
-static const scm_t_vm_engine vm_engines[] =
+static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] =
{ vm_regular_engine, vm_debug_engine };
-#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
+static SCM*
+allocate_stack (size_t size)
+#define FUNC_NAME "make_vm"
+{
+ void *ret;
+
+ if (size >= ((size_t) -1) / sizeof (SCM))
+ abort ();
-/* The GC "kind" for the VM stack. */
-static int vm_stack_gc_kind;
+ size *= sizeof (SCM);
+#if HAVE_SYS_MMAN_H
+ ret = mmap (NULL, size, PROT_READ | PROT_WRITE,
+ MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
+ if (ret == MAP_FAILED)
+ ret = NULL;
+#else
+ ret = malloc (size);
#endif
-static SCM
-make_vm (void)
-#define FUNC_NAME "make_vm"
+ if (!ret)
+ {
+ perror ("allocate_stack failed");
+ return NULL;
+ }
+
+ return (SCM *) ret;
+}
+#undef FUNC_NAME
+
+static void
+free_stack (SCM *stack, size_t size)
{
- int i;
- struct scm_vm *vp;
+ size *= sizeof (SCM);
- vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
+#if HAVE_SYS_MMAN_H
+ munmap (stack, size);
+#else
+ free (stack);
+#endif
+}
+
+static SCM*
+expand_stack (SCM *old_stack, size_t old_size, size_t new_size)
+#define FUNC_NAME "expand_stack"
+{
+#if defined MREMAP_MAYMOVE
+ void *new_stack;
- vp->stack_size= vm_stack_size;
+ if (new_size >= ((size_t) -1) / sizeof (SCM))
+ abort ();
+
+ old_size *= sizeof (SCM);
+ new_size *= sizeof (SCM);
-#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
- vp->stack_base = (SCM *)
- GC_generic_malloc (vp->stack_size * sizeof (SCM), vm_stack_gc_kind);
+ new_stack = mremap (old_stack, old_size, new_size, MREMAP_MAYMOVE);
+ if (new_stack == MAP_FAILED)
+ return NULL;
- /* 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--;
+ return (SCM *) new_stack;
#else
- vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM),
- "stack-base");
-#endif
+ SCM *new_stack;
-#ifdef VM_ENABLE_STACK_NULLING
- memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
+ new_stack = allocate_stack (new_size);
+ if (!new_stack)
+ return NULL;
+
+ memcpy (new_stack, old_stack, old_size * sizeof (SCM));
+ free_stack (old_stack, old_size);
+
+ return new_stack;
#endif
- vp->stack_limit = vp->stack_base + vp->stack_size - VM_STACK_RESERVE_SIZE;
+}
+#undef FUNC_NAME
+
+static struct scm_vm *
+make_vm (void)
+#define FUNC_NAME "make_vm"
+{
+ int i;
+ struct scm_vm *vp;
+
+ vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
+
+ vp->stack_size = page_size / sizeof (SCM);
+ vp->stack_base = allocate_stack (vp->stack_size);
+ if (!vp->stack_base)
+ /* As in expand_stack, we don't have any way to throw an exception
+ if we can't allocate one measely page -- there's no stack to
+ handle it. For now, abort. */
+ abort ();
+ vp->stack_limit = vp->stack_base + vp->stack_size;
+ vp->overflow_handler_stack = SCM_EOL;
vp->ip = NULL;
vp->sp = vp->stack_base - 1;
vp->fp = NULL;
vp->trace_level = 0;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
- vp->cookie = 0;
- return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
+
+ return vp;
}
#undef FUNC_NAME
-#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
+static void
+return_unused_stack_to_os (struct scm_vm *vp)
+{
+#if HAVE_SYS_MMAN_H
+ scm_t_uintptr start = (scm_t_uintptr) (vp->sp + 1);
+ scm_t_uintptr end = (scm_t_uintptr) vp->stack_limit;
+ /* The second condition is needed to protect against wrap-around. */
+ if (vp->sp_max_since_gc < vp->stack_limit && vp->sp < vp->sp_max_since_gc)
+ end = (scm_t_uintptr) (vp->sp_max_since_gc + 1);
+
+ start = ((start - 1U) | (page_size - 1U)) + 1U; /* round up */
+ end = ((end - 1U) | (page_size - 1U)) + 1U; /* round up */
-/* 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)
+ /* Return these pages to the OS. The next time they are paged in,
+ they will be zeroed. */
+ if (start < end)
+ {
+ int ret = 0;
+
+ do
+ ret = madvise ((void *) start, end - start, MADV_DONTNEED);
+ while (ret && errno == -EAGAIN);
+
+ if (ret)
+ perror ("madvise failed");
+ }
+
+ vp->sp_max_since_gc = vp->sp;
+#endif
+}
+
+#define DEAD_SLOT_MAP_CACHE_SIZE 32U
+struct dead_slot_map_cache_entry
{
- GC_word *word;
- const struct scm_vm *vm;
+ scm_t_uint32 *ip;
+ const scm_t_uint8 *map;
+};
- /* The first word of the VM stack should contain a pointer to the
- corresponding VM. */
- vm = * ((struct scm_vm **) addr);
+struct dead_slot_map_cache
+{
+ struct dead_slot_map_cache_entry entries[DEAD_SLOT_MAP_CACHE_SIZE];
+};
- if (vm == NULL
- || (SCM *) addr != vm->stack_base - 1)
- /* 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;
+static const scm_t_uint8 *
+find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache)
+{
+ /* The lower two bits should be zero. FIXME: Use a better hash
+ function; we don't expose scm_raw_hashq currently. */
+ size_t slot = (((scm_t_uintptr) ip) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE;
+ const scm_t_uint8 *map;
- 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);
+ if (cache->entries[slot].ip == ip)
+ map = cache->entries[slot].map;
+ else
+ {
+ map = scm_find_dead_slot_map_unlocked (ip);
+ cache->entries[slot].ip = ip;
+ cache->entries[slot].map = map;
+ }
- return mark_stack_ptr;
+ return map;
}
-#endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
+/* Mark the VM stack region between its base and its current top. */
+struct GC_ms_entry *
+scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
+ struct GC_ms_entry *mark_stack_limit)
+{
+ SCM *sp, *fp;
+ /* The first frame will be marked conservatively (without a dead
+ slot map). This is because GC can happen at any point within the
+ hottest activation, due to multiple threads or per-instruction
+ hooks, and providing dead slot maps for all points in a program
+ would take a prohibitive amount of space. */
+ const scm_t_uint8 *dead_slots = NULL;
+ scm_t_uintptr upper = (scm_t_uintptr) GC_greatest_plausible_heap_addr;
+ scm_t_uintptr lower = (scm_t_uintptr) GC_least_plausible_heap_addr;
+ struct dead_slot_map_cache cache;
+
+ memset (&cache, 0, sizeof (cache));
+
+ for (fp = vp->fp, sp = vp->sp; fp; fp = SCM_FRAME_DYNAMIC_LINK (fp))
+ {
+ for (; sp >= &SCM_FRAME_LOCAL (fp, 0); sp--)
+ {
+ SCM elt = *sp;
+ if (SCM_NIMP (elt)
+ && SCM_UNPACK (elt) >= lower && SCM_UNPACK (elt) <= upper)
+ {
+ if (dead_slots)
+ {
+ size_t slot = sp - &SCM_FRAME_LOCAL (fp, 0);
+ if (dead_slots[slot / 8U] & (1U << (slot % 8U)))
+ {
+ /* This value may become dead as a result of GC,
+ so we can't just leave it on the stack. */
+ *sp = SCM_UNBOUND;
+ continue;
+ }
+ }
+
+ mark_stack_ptr = GC_mark_and_push ((void *) elt,
+ mark_stack_ptr,
+ mark_stack_limit,
+ NULL);
+ }
+ }
+ sp = SCM_FRAME_PREVIOUS_SP (fp);
+ /* Inner frames may have a dead slots map for precise marking.
+ Note that there may be other reasons to not have a dead slots
+ map, e.g. if all of the frame's slots below the callee frame
+ are live. */
+ dead_slots = find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache);
+ }
+ return_unused_stack_to_os (vp);
-SCM
-scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
+ return mark_stack_ptr;
+}
+
+/* Free the VM stack, as this thread is exiting. */
+void
+scm_i_vm_free_stack (struct scm_vm *vp)
{
- struct scm_vm *vp = SCM_VM_DATA (vm);
- SCM_CHECK_STACK;
- return vm_engines[vp->engine](vm, program, argv, nargs);
+ free_stack (vp->stack_base, vp->stack_size);
+ vp->stack_base = vp->stack_limit = NULL;
+ vp->stack_size = 0;
}
-/* Scheme interface */
+struct vm_expand_stack_data
+{
+ struct scm_vm *vp;
+ size_t stack_size;
+ SCM *new_sp;
+};
-SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
- (void),
- "Return the current thread's VM.")
-#define FUNC_NAME s_scm_the_vm
+static void *
+vm_expand_stack_inner (void *data_ptr)
{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ struct vm_expand_stack_data *data = data_ptr;
+
+ struct scm_vm *vp = data->vp;
+ SCM *old_stack, *new_stack;
+ size_t new_size;
+ scm_t_ptrdiff reloc;
+
+ new_size = vp->stack_size;
+ while (new_size < data->stack_size)
+ new_size *= 2;
+ old_stack = vp->stack_base;
- if (SCM_UNLIKELY (scm_is_false (t->vm)))
- t->vm = make_vm ();
+ new_stack = expand_stack (vp->stack_base, vp->stack_size, new_size);
+ if (!new_stack)
+ return NULL;
- return t->vm;
+ vp->stack_base = new_stack;
+ vp->stack_size = new_size;
+ vp->stack_limit = vp->stack_base + new_size;
+ reloc = vp->stack_base - old_stack;
+
+ if (reloc)
+ {
+ SCM *fp;
+ if (vp->fp)
+ vp->fp += reloc;
+ data->new_sp += reloc;
+ fp = vp->fp;
+ while (fp)
+ {
+ SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp);
+ if (next_fp)
+ {
+ next_fp += reloc;
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp);
+ }
+ fp = next_fp;
+ }
+ }
+
+ return new_stack;
}
-#undef FUNC_NAME
+static scm_t_ptrdiff
+current_overflow_size (struct scm_vm *vp)
+{
+ if (scm_is_pair (vp->overflow_handler_stack))
+ return scm_to_ptrdiff_t (scm_caar (vp->overflow_handler_stack));
+ return -1;
+}
-SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
- (SCM obj),
- "")
-#define FUNC_NAME s_scm_vm_p
+static int
+should_handle_stack_overflow (struct scm_vm *vp, scm_t_ptrdiff stack_size)
{
- return scm_from_bool (SCM_VM_P (obj));
+ scm_t_ptrdiff overflow_size = current_overflow_size (vp);
+ return overflow_size >= 0 && stack_size >= overflow_size;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
- (void),
- "")
-#define FUNC_NAME s_scm_make_vm,
+static void
+reset_stack_limit (struct scm_vm *vp)
{
- return make_vm ();
+ if (should_handle_stack_overflow (vp, vp->stack_size))
+ vp->stack_limit = vp->stack_base + current_overflow_size (vp);
+ else
+ vp->stack_limit = vp->stack_base + vp->stack_size;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_ip
+struct overflow_handler_data
{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->ip);
+ struct scm_vm *vp;
+ SCM overflow_handler_stack;
+};
+
+static void
+wind_overflow_handler (void *ptr)
+{
+ struct overflow_handler_data *data = ptr;
+
+ data->vp->overflow_handler_stack = data->overflow_handler_stack;
+
+ reset_stack_limit (data->vp);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_sp
+static void
+unwind_overflow_handler (void *ptr)
{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp);
+ struct overflow_handler_data *data = ptr;
+
+ data->vp->overflow_handler_stack = scm_cdr (data->overflow_handler_stack);
+
+ reset_stack_limit (data->vp);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_fp
+static void
+vm_expand_stack (struct scm_vm *vp, SCM *new_sp)
+{
+ scm_t_ptrdiff stack_size = new_sp + 1 - vp->stack_base;
+
+ if (stack_size > vp->stack_size)
+ {
+ struct vm_expand_stack_data data;
+
+ data.vp = vp;
+ data.stack_size = stack_size;
+ data.new_sp = new_sp;
+
+ if (!GC_call_with_alloc_lock (vm_expand_stack_inner, &data))
+ /* Throw an unwind-only exception. */
+ scm_report_stack_overflow ();
+
+ new_sp = data.new_sp;
+ }
+
+ vp->sp_max_since_gc = vp->sp = new_sp;
+
+ if (should_handle_stack_overflow (vp, stack_size))
+ {
+ SCM more_stack, new_limit;
+
+ struct overflow_handler_data data;
+ data.vp = vp;
+ data.overflow_handler_stack = vp->overflow_handler_stack;
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+
+ scm_dynwind_rewind_handler (unwind_overflow_handler, &data,
+ SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (wind_overflow_handler, &data,
+ SCM_F_WIND_EXPLICITLY);
+
+ /* Call the overflow handler. */
+ more_stack = scm_call_0 (scm_cdar (data.overflow_handler_stack));
+
+ /* If the overflow handler returns, its return value should be an
+ integral number of words from the outer stack limit to transfer
+ to the inner limit. */
+ if (scm_to_ptrdiff_t (more_stack) <= 0)
+ scm_out_of_range (NULL, more_stack);
+ new_limit = scm_sum (scm_caar (data.overflow_handler_stack), more_stack);
+ if (scm_is_pair (scm_cdr (data.overflow_handler_stack)))
+ new_limit = scm_min (new_limit,
+ scm_caadr (data.overflow_handler_stack));
+
+ /* Ensure the new limit is in range. */
+ scm_to_ptrdiff_t (new_limit);
+
+ /* Increase the limit that we will restore. */
+ scm_set_car_x (scm_car (data.overflow_handler_stack), new_limit);
+
+ scm_dynwind_end ();
+
+ /* Recurse */
+ return vm_expand_stack (vp, new_sp);
+ }
+}
+
+static struct scm_vm *
+thread_vm (scm_i_thread *t)
{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp);
+ if (SCM_UNLIKELY (!t->vp))
+ t->vp = make_vm ();
+
+ return t->vp;
+}
+
+struct scm_vm *
+scm_the_vm (void)
+{
+ return thread_vm (SCM_I_CURRENT_THREAD);
+}
+
+SCM
+scm_call_n (SCM proc, SCM *argv, size_t nargs)
+{
+ scm_i_thread *thread;
+ struct scm_vm *vp;
+ SCM *base;
+ ptrdiff_t base_frame_size;
+ /* Cached variables. */
+ scm_i_jmp_buf registers; /* used for prompts */
+ size_t i;
+
+ thread = SCM_I_CURRENT_THREAD;
+ vp = thread_vm (thread);
+
+ SCM_CHECK_STACK;
+
+ /* Check that we have enough space: 3 words for the boot continuation,
+ and 3 + nargs for the procedure application. */
+ base_frame_size = 3 + 3 + nargs;
+ vm_push_sp (vp, vp->sp + base_frame_size);
+ base = vp->sp + 1 - base_frame_size;
+
+ /* Since it's possible to receive the arguments on the stack itself,
+ shuffle up the arguments first. */
+ for (i = nargs; i > 0; i--)
+ base[6 + i - 1] = argv[i - 1];
+
+ /* Push the boot continuation, which calls PROC and returns its
+ result(s). */
+ base[0] = SCM_PACK (vp->fp); /* dynamic link */
+ base[1] = SCM_PACK (vp->ip); /* ra */
+ base[2] = vm_boot_continuation;
+ vp->fp = &base[2];
+ vp->ip = (scm_t_uint32 *) vm_boot_continuation_code;
+
+ /* The pending call to PROC. */
+ base[3] = SCM_PACK (vp->fp); /* dynamic link */
+ base[4] = SCM_PACK (vp->ip); /* ra */
+ base[5] = proc;
+ vp->fp = &base[5];
+
+ {
+ int resume = SCM_I_SETJMP (registers);
+
+ if (SCM_UNLIKELY (resume))
+ {
+ scm_gc_after_nonlocal_exit ();
+ /* Non-local return. */
+ vm_dispatch_abort_hook (vp);
+ }
+
+ return vm_engines[vp->engine](thread, vp, ®isters, resume);
+ }
}
-#undef FUNC_NAME
+
+/* Scheme interface */
#define VM_DEFINE_HOOK(n) \
{ \
struct scm_vm *vp; \
- SCM_VALIDATE_VM (1, vm); \
- vp = SCM_VM_DATA (vm); \
+ vp = scm_the_vm (); \
if (scm_is_false (vp->hooks[n])) \
vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
return vp->hooks[n]; \
}
-SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_apply_hook
{
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_push_continuation_hook
{
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_pop_continuation_hook
{
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_next_hook
{
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_abort_continuation_hook
{
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_restore_continuation_hook, "vm-restore-continuation-hook", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_restore_continuation_hook
-{
- VM_DEFINE_HOOK (SCM_VM_RESTORE_CONTINUATION_HOOK);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_trace_level, "vm-trace-level", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_trace_level
{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_int (SCM_VM_DATA (vm)->trace_level);
+ return scm_from_int (scm_the_vm ()->trace_level);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 2, 0, 0,
- (SCM vm, SCM level),
+SCM_DEFINE (scm_set_vm_trace_level_x, "set-vm-trace-level!", 1, 0, 0,
+ (SCM level),
"")
#define FUNC_NAME s_scm_set_vm_trace_level_x
{
- SCM_VALIDATE_VM (1, vm);
- SCM_VM_DATA (vm)->trace_level = scm_to_int (level);
+ scm_the_vm ()->trace_level = scm_to_int (level);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
}
}
-SCM_DEFINE (scm_vm_engine, "vm-engine", 1, 0, 0,
- (SCM vm),
+SCM_DEFINE (scm_vm_engine, "vm-engine", 0, 0, 0,
+ (void),
"")
#define FUNC_NAME s_scm_vm_engine
{
- SCM_VALIDATE_VM (1, vm);
- return vm_engine_to_symbol (SCM_VM_DATA (vm)->engine, FUNC_NAME);
+ return vm_engine_to_symbol (scm_the_vm ()->engine, FUNC_NAME);
}
#undef FUNC_NAME
void
-scm_c_set_vm_engine_x (SCM vm, int engine)
+scm_c_set_vm_engine_x (int engine)
#define FUNC_NAME "set-vm-engine!"
{
- SCM_VALIDATE_VM (1, vm);
-
if (engine < 0 || engine >= SCM_VM_NUM_ENGINES)
SCM_MISC_ERROR ("Unknown VM engine: ~a",
scm_list_1 (scm_from_int (engine)));
- SCM_VM_DATA (vm)->engine = engine;
+ scm_the_vm ()->engine = engine;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 2, 0, 0,
- (SCM vm, SCM engine),
+SCM_DEFINE (scm_set_vm_engine_x, "set-vm-engine!", 1, 0, 0,
+ (SCM engine),
"")
#define FUNC_NAME s_scm_set_vm_engine_x
{
- scm_c_set_vm_engine_x (vm, symbol_to_vm_engine (engine, FUNC_NAME));
+ scm_c_set_vm_engine_x (symbol_to_vm_engine (engine, FUNC_NAME));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-static void reinstate_vm (SCM vm)
+/* FIXME: This function makes no sense, but we keep it to make sure we
+ have a way of switching to the debug or regular VM. */
+SCM_DEFINE (scm_call_with_vm, "call-with-vm", 1, 0, 1,
+ (SCM proc, SCM args),
+ "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
+ "@var{vm} is the current VM.")
+#define FUNC_NAME s_scm_call_with_vm
{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
- t->vm = vm;
+ return scm_apply_0 (proc, args);
}
+#undef FUNC_NAME
-SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
- (SCM vm, SCM proc, SCM args),
- "Apply @var{proc} to @var{args} in a dynamic extent in which\n"
- "@var{vm} is the current VM.\n\n"
- "As an implementation restriction, if @var{vm} is not the same\n"
- "as the current thread's VM, continuations captured within the\n"
- "call to @var{proc} may not be reinstated once control leaves\n"
- "@var{proc}.")
-#define FUNC_NAME s_scm_call_with_vm
+SCM_DEFINE (scm_call_with_stack_overflow_handler,
+ "call-with-stack-overflow-handler", 3, 0, 0,
+ (SCM limit, SCM thunk, SCM handler),
+ "Call @var{thunk} in an environment in which the stack limit has\n"
+ "been reduced to @var{limit} additional words. If the limit is\n"
+ "reached, @var{handler} (a thunk) will be invoked in the dynamic\n"
+ "environment of the error. For the extent of the call to\n"
+ "@var{handler}, the stack limit and handler are restored to the\n"
+ "values that were in place when\n"
+ "@code{call-with-stack-overflow-handler} was called.")
+#define FUNC_NAME s_scm_call_with_stack_overflow_handler
{
- SCM prev_vm, ret;
- SCM *argv;
- int i, nargs;
- scm_t_wind_flags flags;
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ struct scm_vm *vp;
+ scm_t_ptrdiff c_limit, stack_size;
+ struct overflow_handler_data data;
+ SCM new_limit, ret;
- SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_PROC (2, proc);
+ vp = scm_the_vm ();
+ stack_size = vp->sp - vp->stack_base;
- nargs = scm_ilength (args);
- if (SCM_UNLIKELY (nargs < 0))
- scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
-
- argv = alloca (nargs * sizeof(SCM));
- for (i = 0; i < nargs; i++)
- {
- argv[i] = SCM_CAR (args);
- args = SCM_CDR (args);
- }
+ c_limit = scm_to_ptrdiff_t (limit);
+ if (c_limit <= 0)
+ scm_out_of_range (FUNC_NAME, limit);
- prev_vm = t->vm;
+ new_limit = scm_sum (scm_from_ptrdiff_t (stack_size), limit);
+ if (scm_is_pair (vp->overflow_handler_stack))
+ new_limit = scm_min (new_limit, scm_caar (vp->overflow_handler_stack));
- /* Reentry can happen via invokation of a saved continuation, but
- continuations only save the state of the VM that they are in at
- capture-time, which might be different from this one. So, in the
- case that the VMs are different, set up a non-rewindable frame to
- prevent reinstating an incomplete continuation. */
- flags = scm_is_eq (prev_vm, vm) ? 0 : SCM_F_WIND_EXPLICITLY;
- if (flags)
- {
- scm_dynwind_begin (0);
- scm_dynwind_unwind_handler_with_scm (reinstate_vm, prev_vm, flags);
- t->vm = vm;
- }
+ /* Hacky check that the current stack depth plus the limit is within
+ the range of a ptrdiff_t. */
+ scm_to_ptrdiff_t (new_limit);
- ret = scm_c_vm_run (vm, proc, argv, nargs);
+ data.vp = vp;
+ data.overflow_handler_stack =
+ scm_acons (limit, handler, vp->overflow_handler_stack);
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+
+ scm_dynwind_rewind_handler (wind_overflow_handler, &data,
+ SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (unwind_overflow_handler, &data,
+ SCM_F_WIND_EXPLICITLY);
+
+ /* Reset vp->sp_max_since_gc so that the VM checks actually
+ trigger. */
+ return_unused_stack_to_os (vp);
+
+ ret = scm_call_0 (thunk);
+
+ scm_dynwind_end ();
- if (flags)
- scm_dynwind_end ();
-
return ret;
}
#undef FUNC_NAME
* Initialize
*/
-SCM scm_load_compiled_with_vm (SCM file)
+SCM
+scm_load_compiled_with_vm (SCM file)
{
- SCM program = scm_make_program (scm_load_objcode (file),
- SCM_BOOL_F, SCM_BOOL_F);
-
- return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
+ return scm_call_0 (scm_load_thunk_from_file (file));
}
-static SCM
-make_boot_program (void)
-{
- struct scm_objcode *bp;
- size_t bp_size;
- SCM u8vec, ret;
-
- const scm_t_uint8 text[] = {
- scm_op_make_int8_1,
- scm_op_halt
- };
-
- bp_size = sizeof (struct scm_objcode) + sizeof (text);
- bp = scm_gc_malloc_pointerless (bp_size, "boot-program");
- memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
- bp->len = sizeof(text);
- bp->metalen = 0;
-
- u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size);
- ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
- SCM_BOOL_F, SCM_BOOL_F);
- SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT));
-
- return ret;
+void
+scm_init_vm_builtin_properties (void)
+{
+ /* FIXME: Seems hacky to do this here, but oh well :/ */
+ scm_sym_apply = scm_from_utf8_symbol ("apply");
+ scm_sym_values = scm_from_utf8_symbol ("values");
+ scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt");
+ scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values");
+ scm_sym_call_with_current_continuation =
+ scm_from_utf8_symbol ("call-with-current-continuation");
+
+#define INIT_BUILTIN(builtin, BUILTIN, req, opt, rest) \
+ scm_set_procedure_property_x (vm_builtin_##builtin, scm_sym_name, \
+ scm_sym_##builtin); \
+ scm_set_procedure_minimum_arity_x (vm_builtin_##builtin, \
+ SCM_I_MAKINUM (req), \
+ SCM_I_MAKINUM (opt), \
+ scm_from_bool (rest));
+ FOR_EACH_VM_BUILTIN (INIT_BUILTIN);
+#undef INIT_BUILTIN
}
void
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_vm_builtins",
+ (scm_t_extension_init_func)scm_init_vm_builtins,
+ NULL);
- initialize_default_stack_size ();
+ page_size = getpagesize ();
+ /* page_size should be a power of two. */
+ if (page_size & (page_size - 1))
+ abort ();
sym_vm_run = scm_from_latin1_symbol ("vm-run");
sym_vm_error = scm_from_latin1_symbol ("vm-error");
sym_regular = scm_from_latin1_symbol ("regular");
sym_debug = scm_from_latin1_symbol ("debug");
- boot_continuation = make_boot_program ();
-
-#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);
+ vm_boot_continuation = scm_i_make_program (vm_boot_continuation_code);
+ SCM_SET_CELL_WORD_0 (vm_boot_continuation,
+ (SCM_CELL_WORD_0 (vm_boot_continuation)
+ | SCM_F_PROGRAM_IS_BOOT));
-#endif
+#define DEFINE_BUILTIN(builtin, BUILTIN, req, opt, rest) \
+ vm_builtin_##builtin = scm_i_make_program (vm_builtin_##builtin##_code);
+ FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
+#undef DEFINE_BUILTIN
}
void
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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_VM_POP_CONTINUATION_HOOK,
SCM_VM_NEXT_HOOK,
SCM_VM_ABORT_CONTINUATION_HOOK,
- SCM_VM_RESTORE_CONTINUATION_HOOK,
SCM_VM_NUM_HOOKS,
};
-struct scm_vm;
-
-typedef SCM (*scm_t_vm_engine) (SCM vm, SCM program, SCM *argv, int nargs);
-
#define SCM_VM_REGULAR_ENGINE 0
#define SCM_VM_DEBUG_ENGINE 1
#define SCM_VM_NUM_ENGINES 2
struct scm_vm {
- scm_t_uint8 *ip; /* instruction pointer */
+ scm_t_uint32 *ip; /* instruction pointer */
SCM *sp; /* stack pointer */
SCM *fp; /* frame pointer */
+ SCM *stack_limit; /* stack limit address */
+ int trace_level; /* traces enabled if trace_level > 0 */
+ SCM *sp_max_since_gc; /* highest sp since last gc */
size_t stack_size; /* stack size */
SCM *stack_base; /* stack base address */
- SCM *stack_limit; /* stack limit address */
- int engine; /* which vm engine we're using */
+ SCM overflow_handler_stack; /* alist of max-stack-size -> thunk */
SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
- int trace_level; /* traces enabled if trace_level > 0 */
- scm_t_int64 cookie; /* used to detect unrewindable continuations */
+ int engine; /* which vm engine we're using */
};
-SCM_API SCM scm_the_vm_fluid;
-
-#define SCM_VM_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_vm)
-#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_CELL_WORD_1 (vm))
-#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
-
-SCM_API SCM scm_the_vm (void);
-SCM_API SCM scm_make_vm (void);
-
-SCM_API SCM scm_the_vm (void);
-SCM_API SCM scm_call_with_vm (SCM vm, SCM proc, SCM args);
-
-SCM_API SCM scm_vm_p (SCM obj);
-SCM_API SCM scm_vm_ip (SCM vm);
-SCM_API SCM scm_vm_sp (SCM vm);
-SCM_API SCM scm_vm_fp (SCM vm);
-SCM_API SCM scm_vm_apply_hook (SCM vm);
-SCM_API SCM scm_vm_push_continuation_hook (SCM vm);
-SCM_API SCM scm_vm_pop_continuation_hook (SCM vm);
-SCM_API SCM scm_vm_abort_continuation_hook (SCM vm);
-SCM_API SCM scm_vm_restore_continuation_hook (SCM vm);
-SCM_API SCM scm_vm_next_hook (SCM vm);
-SCM_API SCM scm_vm_trace_level (SCM vm);
-SCM_API SCM scm_set_vm_trace_level_x (SCM vm, SCM level);
-SCM_API SCM scm_vm_engine (SCM vm);
-SCM_API SCM scm_set_vm_engine_x (SCM vm, SCM engine);
+SCM_INTERNAL struct scm_vm *scm_the_vm (void);
+SCM_API SCM scm_call_with_vm (SCM proc, SCM args);
+
+SCM_API SCM scm_call_with_stack_overflow_handler (SCM limit, SCM thunk,
+ SCM handler);
+
+SCM_API SCM scm_vm_apply_hook (void);
+SCM_API SCM scm_vm_push_continuation_hook (void);
+SCM_API SCM scm_vm_pop_continuation_hook (void);
+SCM_API SCM scm_vm_abort_continuation_hook (void);
+SCM_API SCM scm_vm_next_hook (void);
+SCM_API SCM scm_vm_trace_level (void);
+SCM_API SCM scm_set_vm_trace_level_x (SCM level);
+SCM_API SCM scm_vm_engine (void);
+SCM_API SCM scm_set_vm_engine_x (SCM engine);
SCM_API SCM scm_set_default_vm_engine_x (SCM engine);
-SCM_API void scm_c_set_vm_engine_x (SCM vm, int engine);
+SCM_API void scm_c_set_vm_engine_x (int engine);
SCM_API void scm_c_set_default_vm_engine_x (int engine);
+struct GC_ms_entry;
+SCM_INTERNAL struct GC_ms_entry * scm_i_vm_mark_stack (struct scm_vm *,
+ struct GC_ms_entry *,
+ struct GC_ms_entry *);
+SCM_INTERNAL void scm_i_vm_free_stack (struct scm_vm *vp);
+
#define SCM_F_VM_CONT_PARTIAL 0x1
#define SCM_F_VM_CONT_REWINDABLE 0x2
struct scm_vm_cont {
SCM *sp;
SCM *fp;
- scm_t_uint8 *ra, *mvra;
+ scm_t_uint32 *ra;
scm_t_ptrdiff stack_size;
SCM *stack_base;
scm_t_ptrdiff reloc;
+ scm_t_dynstack *dynstack;
scm_t_uint32 flags;
};
-#define SCM_VM_CONT_P(OBJ) (SCM_NIMP (OBJ) && SCM_TYP7 (OBJ) == scm_tc7_vm_cont)
+#define SCM_VM_CONT_P(OBJ) (SCM_HAS_TYP7 (OBJ, scm_tc7_vm_cont))
#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
#define SCM_VM_CONT_PARTIAL_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & SCM_F_VM_CONT_PARTIAL)
#define SCM_VM_CONT_REWINDABLE_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & SCM_F_VM_CONT_REWINDABLE)
SCM_API SCM scm_load_compiled_with_vm (SCM file);
-SCM_INTERNAL SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
-
-SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
- scm_print_state *pstate);
-SCM_INTERNAL SCM scm_i_vm_capture_continuation (SCM vm);
+SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
+SCM_INTERNAL SCM scm_i_capture_current_stack (void);
SCM_INTERNAL SCM scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp,
- scm_t_uint8 *ra, scm_t_uint8 *mvra,
+ scm_t_uint32 *ra,
+ scm_t_dynstack *dynstack,
scm_t_uint32 flags);
+SCM_INTERNAL int scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame);
SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port,
scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_vm (void);
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006, 2009, 2010, 2011, 2013 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/_scm.h"
#include "libguile/eval.h"
#include "libguile/chars.h"
+#include "libguile/ports.h"
+#include "libguile/ports-internal.h"
#include "libguile/fports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
{
SCM p = SCM_PACK (SCM_STREAM (port));
SCM ans;
- scm_t_port *pt;
+ scm_t_wchar c;
+ scm_t_port_internal *pti;
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");
- pt = SCM_PTAB_ENTRY (port);
+ pti = SCM_PORT_GET_INTERNAL (port);
- if (pt->encoding == NULL)
+ c = SCM_CHAR (ans);
+
+ if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1
+ || (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8 && c < 0xff))
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- *pt->read_buf = SCM_CHAR (ans);
+ *pt->read_buf = c;
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);
+ {
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port);
+
+ scm_ungetc_unlocked (c, port);
+
+ SCM_LINUM (port) = line;
+ SCM_COL (port) = column;
+ }
+
+ return c;
}
#define FUNC_NAME s_scm_make_soft_port
{
int vlen;
- scm_t_port *pt;
SCM z;
SCM_VALIDATE_VECTOR (1, pv);
SCM_ASSERT ((vlen == 5) || (vlen == 6), pv, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, modes);
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
- z = scm_new_port_table_entry (scm_tc16_sfport);
- pt = SCM_PTAB_ENTRY (z);
- scm_port_non_buffer (pt);
- SCM_SET_CELL_TYPE (z, scm_tc16_sfport | scm_i_mode_bits (modes));
-
- SCM_SETSTREAM (z, SCM_UNPACK (pv));
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ z = scm_c_make_port (scm_tc16_sfport, scm_i_mode_bits (modes),
+ SCM_UNPACK (pv));
+ scm_port_non_buffer (SCM_PTAB_ENTRY (z));
+
return z;
}
#undef FUNC_NAME
--- /dev/null
+/* Copyright (C) 2011, 2012, 2013 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 <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/hash.h"
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+#include "libguile/bdw-gc.h"
+
+#include "libguile/validate.h"
+#include "libguile/weak-set.h"
+
+
+/* Weak Sets
+
+ This file implements weak sets. One example of a weak set is the
+ symbol table, where you want all instances of the `foo' symbol to map
+ to one object. So when you load a file and it wants a symbol with
+ the characters "foo", you one up in the table, using custom hash and
+ equality predicates. Only if one is not found will you bother to
+ cons one up and intern it.
+
+ Another use case for weak sets is the set of open ports. Guile needs
+ to be able to flush them all when the process exits, but the set
+ shouldn't prevent the GC from collecting the port (and thus closing
+ it).
+
+ Weak sets are implemented using an open-addressed hash table.
+ Basically this means that there is an array of entries, and the item
+ is expected to be found the slot corresponding to its hash code,
+ modulo the length of the array.
+
+ Collisions are handled using linear probing with the Robin Hood
+ technique. See Pedro Celis' paper, "Robin Hood Hashing":
+
+ http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf
+
+ The vector of entries is allocated as an "atomic" piece of memory, so
+ that the GC doesn't trace it. When an item is added to the set, a
+ disappearing link is registered to its location. If the item is
+ collected, then that link will be zeroed out.
+
+ An entry is not just an item, though; the hash code is also stored in
+ the entry. We munge hash codes so that they are never 0. In this
+ way we can detect removed entries (key of zero but nonzero hash
+ code), and can then reshuffle elements as needed to maintain the
+ robin hood ordering.
+
+ Compared to buckets-and-chains hash tables, open addressing has the
+ advantage that it is very cache-friendly. It also uses less memory.
+
+ Implementation-wise, there are two things to note.
+
+ 1. We assume that hash codes are evenly distributed across the
+ range of unsigned longs. The actual hash code stored in the
+ entry is left-shifted by 1 bit (losing 1 bit of hash precision),
+ and then or'd with 1. In this way we ensure that the hash field
+ of an occupied entry is nonzero. To map to an index, we
+ right-shift the hash by one, divide by the size, and take the
+ remainder.
+
+ 2. Since the "keys" (the objects in the set) are stored in an
+ atomic region with disappearing links, they need to be accessed
+ with the GC alloc lock. `copy_weak_entry' will do that for
+ you. The hash code itself can be read outside the lock,
+ though.
+*/
+
+
+typedef struct {
+ unsigned long hash;
+ scm_t_bits key;
+} scm_t_weak_entry;
+
+
+struct weak_entry_data {
+ scm_t_weak_entry *in;
+ scm_t_weak_entry *out;
+};
+
+static void*
+do_copy_weak_entry (void *data)
+{
+ struct weak_entry_data *e = data;
+
+ e->out->hash = e->in->hash;
+ e->out->key = e->in->key;
+
+ return NULL;
+}
+
+static void
+copy_weak_entry (scm_t_weak_entry *src, scm_t_weak_entry *dst)
+{
+ struct weak_entry_data data;
+
+ data.in = src;
+ data.out = dst;
+
+ GC_call_with_alloc_lock (do_copy_weak_entry, &data);
+}
+
+
+typedef struct {
+ scm_t_weak_entry *entries; /* the data */
+ scm_i_pthread_mutex_t lock; /* the lock */
+ unsigned long size; /* total number of slots. */
+ unsigned long n_items; /* number of items in set */
+ unsigned long lower; /* when to shrink */
+ unsigned long upper; /* when to grow */
+ int size_index; /* index into hashset_size */
+ int min_size_index; /* minimum size_index */
+} scm_t_weak_set;
+
+
+#define SCM_WEAK_SET_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_set))
+#define SCM_VALIDATE_WEAK_SET(pos, arg) \
+ SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_SET_P, "weak-set")
+#define SCM_WEAK_SET(x) ((scm_t_weak_set *) SCM_CELL_WORD_1 (x))
+
+
+static unsigned long
+hash_to_index (unsigned long hash, unsigned long size)
+{
+ return (hash >> 1) % size;
+}
+
+static unsigned long
+entry_distance (unsigned long hash, unsigned long k, unsigned long size)
+{
+ unsigned long origin = hash_to_index (hash, size);
+
+ if (k >= origin)
+ return k - origin;
+ else
+ /* The other key was displaced and wrapped around. */
+ return size - origin + k;
+}
+
+#ifndef HAVE_GC_MOVE_DISAPPEARING_LINK
+static void
+GC_move_disappearing_link (void **from, void **to)
+{
+ GC_unregister_disappearing_link (from);
+ SCM_I_REGISTER_DISAPPEARING_LINK (to, *to);
+}
+#endif
+
+static void
+move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to)
+{
+ if (from->hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (from, ©);
+ to->hash = copy.hash;
+ to->key = copy.key;
+
+ if (copy.key && SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
+ GC_move_disappearing_link ((void **) &from->key, (void **) &to->key);
+ }
+ else
+ {
+ to->hash = 0;
+ to->key = 0;
+ }
+}
+
+static void
+rob_from_rich (scm_t_weak_set *set, unsigned long k)
+{
+ unsigned long empty, size;
+
+ size = set->size;
+
+ /* If we are to free up slot K in the set, we need room to do so. */
+ assert (set->n_items < size);
+
+ empty = k;
+ do
+ empty = (empty + 1) % size;
+ /* Here we access key outside the lock. Is this a problem? At first
+ glance, I wouldn't think so. */
+ while (set->entries[empty].key);
+
+ do
+ {
+ unsigned long last = empty ? (empty - 1) : (size - 1);
+ move_weak_entry (&set->entries[last], &set->entries[empty]);
+ empty = last;
+ }
+ while (empty != k);
+
+ /* Just for sanity. */
+ set->entries[empty].hash = 0;
+ set->entries[empty].key = 0;
+}
+
+static void
+give_to_poor (scm_t_weak_set *set, unsigned long k)
+{
+ /* Slot K was just freed up; possibly shuffle others down. */
+ unsigned long size = set->size;
+
+ while (1)
+ {
+ unsigned long next = (k + 1) % size;
+ unsigned long hash;
+ scm_t_weak_entry copy;
+
+ hash = set->entries[next].hash;
+
+ if (!hash || hash_to_index (hash, size) == next)
+ break;
+
+ copy_weak_entry (&set->entries[next], ©);
+
+ if (!copy.key)
+ /* Lost weak reference. */
+ {
+ give_to_poor (set, next);
+ set->n_items--;
+ continue;
+ }
+
+ move_weak_entry (&set->entries[next], &set->entries[k]);
+
+ k = next;
+ }
+
+ /* We have shuffled down any entries that should be shuffled down; now
+ free the end. */
+ set->entries[k].hash = 0;
+ set->entries[k].key = 0;
+}
+
+
+\f
+
+/* Growing or shrinking is triggered when the load factor
+ *
+ * L = N / S (N: number of items in set, S: bucket vector length)
+ *
+ * passes an upper limit of 0.9 or a lower limit of 0.2.
+ *
+ * The implementation stores the upper and lower number of items which
+ * trigger a resize in the hashset object.
+ *
+ * Possible hash set sizes (primes) are stored in the array
+ * hashset_size.
+ */
+
+static unsigned long hashset_size[] = {
+ 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
+ 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041, 28762081,
+ 57524111, 115048217, 230096423
+};
+
+#define HASHSET_SIZE_N (sizeof(hashset_size)/sizeof(unsigned long))
+
+static int
+compute_size_index (scm_t_weak_set *set)
+{
+ int i = set->size_index;
+
+ if (set->n_items < set->lower)
+ {
+ /* rehashing is not triggered when i <= min_size */
+ do
+ --i;
+ while (i > set->min_size_index
+ && set->n_items < hashset_size[i] / 5);
+ }
+ else if (set->n_items > set->upper)
+ {
+ ++i;
+ if (i >= HASHSET_SIZE_N)
+ /* The biggest size currently is 230096423, which for a 32-bit
+ machine will occupy 1.5GB of memory at a load of 80%. There
+ is probably something better to do here, but if you have a
+ weak map of that size, you are hosed in any case. */
+ abort ();
+ }
+
+ return i;
+}
+
+static int
+is_acceptable_size_index (scm_t_weak_set *set, int size_index)
+{
+ int computed = compute_size_index (set);
+
+ if (size_index == computed)
+ /* We were going to grow or shrink, and allocating the new vector
+ didn't change the target size. */
+ return 1;
+
+ if (size_index == computed + 1)
+ {
+ /* We were going to enlarge the set, but allocating the new
+ vector finalized some objects, making an enlargement
+ unnecessary. It might still be a good idea to use the larger
+ set, though. (This branch also gets hit if, while allocating
+ the vector, some other thread was actively removing items from
+ the set. That is less likely, though.) */
+ unsigned long new_lower = hashset_size[size_index] / 5;
+
+ return set->size > new_lower;
+ }
+
+ if (size_index == computed - 1)
+ {
+ /* We were going to shrink the set, but when we dropped the lock
+ to allocate the new vector, some other thread added elements to
+ the set. */
+ return 0;
+ }
+
+ /* The computed size differs from our newly allocated size by more
+ than one size index -- recalculate. */
+ return 0;
+}
+
+static void
+resize_set (scm_t_weak_set *set)
+{
+ scm_t_weak_entry *old_entries, *new_entries;
+ int new_size_index;
+ unsigned long old_size, new_size, old_k;
+
+ do
+ {
+ new_size_index = compute_size_index (set);
+ if (new_size_index == set->size_index)
+ return;
+ new_size = hashset_size[new_size_index];
+ new_entries = scm_gc_malloc_pointerless (new_size * sizeof(scm_t_weak_entry),
+ "weak set");
+ }
+ while (!is_acceptable_size_index (set, new_size_index));
+
+ old_entries = set->entries;
+ old_size = set->size;
+
+ memset (new_entries, 0, new_size * sizeof(scm_t_weak_entry));
+
+ set->size_index = new_size_index;
+ set->size = new_size;
+ if (new_size_index <= set->min_size_index)
+ set->lower = 0;
+ else
+ set->lower = new_size / 5;
+ set->upper = 9 * new_size / 10;
+ set->n_items = 0;
+ set->entries = new_entries;
+
+ for (old_k = 0; old_k < old_size; old_k++)
+ {
+ scm_t_weak_entry copy;
+ unsigned long new_k, distance;
+
+ if (!old_entries[old_k].hash)
+ continue;
+
+ copy_weak_entry (&old_entries[old_k], ©);
+
+ if (!copy.key)
+ continue;
+
+ new_k = hash_to_index (copy.hash, new_size);
+
+ for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size)
+ {
+ unsigned long other_hash = new_entries[new_k].hash;
+
+ if (!other_hash)
+ /* Found an empty entry. */
+ break;
+
+ /* Displace the entry if our distance is less, otherwise keep
+ looking. */
+ if (entry_distance (other_hash, new_k, new_size) < distance)
+ {
+ rob_from_rich (set, new_k);
+ break;
+ }
+ }
+
+ set->n_items++;
+ new_entries[new_k].hash = copy.hash;
+ new_entries[new_k].key = copy.key;
+
+ if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &new_entries[new_k].key,
+ (void *) new_entries[new_k].key);
+ }
+}
+
+/* Run from a finalizer via do_vacuum_weak_set, this function runs over
+ the whole table, removing lost weak references, reshuffling the set
+ as it goes. It might resize the set if it reaps enough entries. */
+static void
+vacuum_weak_set (scm_t_weak_set *set)
+{
+ scm_t_weak_entry *entries = set->entries;
+ unsigned long size = set->size;
+ unsigned long k;
+
+ for (k = 0; k < size; k++)
+ {
+ unsigned long hash = entries[k].hash;
+
+ if (hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (set, k);
+ set->n_items--;
+ }
+ }
+ }
+
+ if (set->n_items < set->lower)
+ resize_set (set);
+}
+
+
+\f
+
+static SCM
+weak_set_lookup (scm_t_weak_set *set, unsigned long hash,
+ scm_t_set_predicate_fn pred, void *closure,
+ SCM dflt)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = set->size;
+ entries = set->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; distance < size; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Not found. */
+ return dflt;
+
+ if (hash == other_hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (set, k);
+ set->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), closure))
+ /* Found. */
+ return SCM_PACK (copy.key);
+ }
+
+ /* If the entry's distance is less, our key is not in the set. */
+ if (entry_distance (other_hash, k, size) < distance)
+ return dflt;
+ }
+
+ /* If we got here, then we were unfortunate enough to loop through the
+ whole set. Shouldn't happen, but hey. */
+ return dflt;
+}
+
+
+static SCM
+weak_set_add_x (scm_t_weak_set *set, unsigned long hash,
+ scm_t_set_predicate_fn pred, void *closure,
+ SCM obj)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = set->size;
+ entries = set->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; ; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Found an empty entry. */
+ break;
+
+ if (other_hash == hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (set, k);
+ set->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), closure))
+ /* Found an entry with this key. */
+ return SCM_PACK (copy.key);
+ }
+
+ if (set->n_items > set->upper)
+ /* Full set, time to resize. */
+ {
+ resize_set (set);
+ return weak_set_add_x (set, hash >> 1, pred, closure, obj);
+ }
+
+ /* Displace the entry if our distance is less, otherwise keep
+ looking. */
+ if (entry_distance (other_hash, k, size) < distance)
+ {
+ rob_from_rich (set, k);
+ break;
+ }
+ }
+
+ set->n_items++;
+ entries[k].hash = hash;
+ entries[k].key = SCM_UNPACK (obj);
+
+ if (SCM_HEAP_OBJECT_P (obj))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entries[k].key,
+ (void *) SCM2PTR (obj));
+
+ return obj;
+}
+
+
+static void
+weak_set_remove_x (scm_t_weak_set *set, unsigned long hash,
+ scm_t_set_predicate_fn pred, void *closure)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = set->size;
+ entries = set->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; distance < size; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Not found. */
+ return;
+
+ if (other_hash == hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (set, k);
+ set->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), closure))
+ /* Found an entry with this key. */
+ {
+ entries[k].hash = 0;
+ entries[k].key = 0;
+
+ if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
+ GC_unregister_disappearing_link ((void **) &entries[k].key);
+
+ if (--set->n_items < set->lower)
+ resize_set (set);
+ else
+ give_to_poor (set, k);
+
+ return;
+ }
+ }
+
+ /* If the entry's distance is less, our key is not in the set. */
+ if (entry_distance (other_hash, k, size) < distance)
+ return;
+ }
+}
+
+
+\f
+static SCM
+make_weak_set (unsigned long k)
+{
+ scm_t_weak_set *set;
+
+ int i = 0, n = k ? k : 31;
+ while (i + 1 < HASHSET_SIZE_N && n > hashset_size[i])
+ ++i;
+ n = hashset_size[i];
+
+ set = scm_gc_malloc (sizeof (*set), "weak-set");
+ set->entries = scm_gc_malloc_pointerless (n * sizeof(scm_t_weak_entry),
+ "weak-set");
+ memset (set->entries, 0, n * sizeof(scm_t_weak_entry));
+ set->n_items = 0;
+ set->size = n;
+ set->lower = 0;
+ set->upper = 9 * n / 10;
+ set->size_index = i;
+ set->min_size_index = i;
+ scm_i_pthread_mutex_init (&set->lock, NULL);
+
+ return scm_cell (scm_tc7_weak_set, (scm_t_bits)set);
+}
+
+void
+scm_i_weak_set_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+ scm_puts_unlocked ("#<", port);
+ scm_puts_unlocked ("weak-set ", port);
+ scm_uintprint (SCM_WEAK_SET (exp)->n_items, 10, port);
+ scm_putc_unlocked ('/', port);
+ scm_uintprint (SCM_WEAK_SET (exp)->size, 10, port);
+ scm_puts_unlocked (">", port);
+}
+
+static void
+do_vacuum_weak_set (SCM set)
+{
+ scm_t_weak_set *s;
+
+ s = SCM_WEAK_SET (set);
+
+ /* We should always be able to grab this lock, because we are run from
+ a finalizer, which runs in another thread (or an async, which is
+ mostly equivalent). */
+ scm_i_pthread_mutex_lock (&s->lock);
+ vacuum_weak_set (s);
+ scm_i_pthread_mutex_unlock (&s->lock);
+}
+
+SCM
+scm_c_make_weak_set (unsigned long k)
+{
+ SCM ret;
+
+ ret = make_weak_set (k);
+
+ scm_i_register_weak_gc_callback (ret, do_vacuum_weak_set);
+
+ return ret;
+}
+
+SCM
+scm_weak_set_p (SCM obj)
+{
+ return scm_from_bool (SCM_WEAK_SET_P (obj));
+}
+
+SCM
+scm_weak_set_clear_x (SCM set)
+{
+ scm_t_weak_set *s = SCM_WEAK_SET (set);
+
+ scm_i_pthread_mutex_lock (&s->lock);
+
+ memset (s->entries, 0, sizeof (scm_t_weak_entry) * s->size);
+ s->n_items = 0;
+
+ scm_i_pthread_mutex_unlock (&s->lock);
+
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+scm_c_weak_set_lookup (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure, SCM dflt)
+{
+ SCM ret;
+ scm_t_weak_set *s = SCM_WEAK_SET (set);
+
+ scm_i_pthread_mutex_lock (&s->lock);
+
+ ret = weak_set_lookup (s, raw_hash, pred, closure, dflt);
+
+ scm_i_pthread_mutex_unlock (&s->lock);
+
+ return ret;
+}
+
+SCM
+scm_c_weak_set_add_x (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure, SCM obj)
+{
+ SCM ret;
+ scm_t_weak_set *s = SCM_WEAK_SET (set);
+
+ scm_i_pthread_mutex_lock (&s->lock);
+
+ ret = weak_set_add_x (s, raw_hash, pred, closure, obj);
+
+ scm_i_pthread_mutex_unlock (&s->lock);
+
+ return ret;
+}
+
+void
+scm_c_weak_set_remove_x (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure)
+{
+ scm_t_weak_set *s = SCM_WEAK_SET (set);
+
+ scm_i_pthread_mutex_lock (&s->lock);
+
+ weak_set_remove_x (s, raw_hash, pred, closure);
+
+ scm_i_pthread_mutex_unlock (&s->lock);
+}
+
+static int
+eq_predicate (SCM x, void *closure)
+{
+ return scm_is_eq (x, SCM_PACK_POINTER (closure));
+}
+
+SCM
+scm_weak_set_add_x (SCM set, SCM obj)
+{
+ return scm_c_weak_set_add_x (set, scm_ihashq (obj, -1),
+ eq_predicate, SCM_UNPACK_POINTER (obj), obj);
+}
+
+SCM
+scm_weak_set_remove_x (SCM set, SCM obj)
+{
+ scm_c_weak_set_remove_x (set, scm_ihashq (obj, -1),
+ eq_predicate, SCM_UNPACK_POINTER (obj));
+
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+scm_c_weak_set_fold (scm_t_set_fold_fn proc, void *closure,
+ SCM init, SCM set)
+{
+ scm_t_weak_set *s;
+ scm_t_weak_entry *entries;
+ unsigned long k, size;
+
+ s = SCM_WEAK_SET (set);
+
+ scm_i_pthread_mutex_lock (&s->lock);
+
+ size = s->size;
+ entries = s->entries;
+
+ for (k = 0; k < size; k++)
+ {
+ if (entries[k].hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (copy.key)
+ {
+ /* Release set lock while we call the function. */
+ scm_i_pthread_mutex_unlock (&s->lock);
+ init = proc (closure, SCM_PACK (copy.key), init);
+ scm_i_pthread_mutex_lock (&s->lock);
+ }
+ }
+ }
+
+ scm_i_pthread_mutex_unlock (&s->lock);
+
+ return init;
+}
+
+static SCM
+fold_trampoline (void *closure, SCM item, SCM init)
+{
+ return scm_call_2 (SCM_PACK_POINTER (closure), item, init);
+}
+
+SCM
+scm_weak_set_fold (SCM proc, SCM init, SCM set)
+{
+ return scm_c_weak_set_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, set);
+}
+
+static SCM
+for_each_trampoline (void *closure, SCM item, SCM seed)
+{
+ scm_call_1 (SCM_PACK_POINTER (closure), item);
+ return seed;
+}
+
+SCM
+scm_weak_set_for_each (SCM proc, SCM set)
+{
+ scm_c_weak_set_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, set);
+
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+map_trampoline (void *closure, SCM item, SCM seed)
+{
+ return scm_cons (scm_call_1 (SCM_PACK_POINTER (closure), item), seed);
+}
+
+SCM
+scm_weak_set_map_to_list (SCM proc, SCM set)
+{
+ return scm_c_weak_set_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, set);
+}
+
+
+void
+scm_init_weak_set ()
+{
+#include "libguile/weak-set.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_WEAK_SET_H
+#define SCM_WEAK_SET_H
+
+/* Copyright (C) 2011 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public 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 weak set API is currently only used internally. We could make it
+ public later, after some API review. */
+
+/* Function that returns nonzero if the given object is the one we are
+ looking for. */
+typedef int (*scm_t_set_predicate_fn) (SCM obj, void *closure);
+
+/* Function to fold over the elements of a set. */
+typedef SCM (*scm_t_set_fold_fn) (void *closure, SCM key, SCM result);
+
+SCM_INTERNAL SCM scm_c_make_weak_set (unsigned long k);
+SCM_INTERNAL SCM scm_weak_set_p (SCM h);
+SCM_INTERNAL SCM scm_c_weak_set_lookup (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure, SCM dflt);
+SCM_INTERNAL SCM scm_c_weak_set_add_x (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure, SCM obj);
+SCM_INTERNAL void scm_c_weak_set_remove_x (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure);
+SCM_INTERNAL SCM scm_weak_set_add_x (SCM set, SCM obj);
+SCM_INTERNAL SCM scm_weak_set_remove_x (SCM set, SCM obj);
+SCM_INTERNAL SCM scm_weak_set_clear_x (SCM set);
+SCM_INTERNAL SCM scm_c_weak_set_fold (scm_t_set_fold_fn proc, void *closure,
+ SCM init, SCM set);
+SCM_INTERNAL SCM scm_weak_set_fold (SCM proc, SCM init, SCM set);
+SCM_INTERNAL SCM scm_weak_set_for_each (SCM proc, SCM set);
+SCM_INTERNAL SCM scm_weak_set_map_to_list (SCM proc, SCM set);
+
+SCM_INTERNAL void scm_i_weak_set_print (SCM exp, SCM port, scm_print_state *pstate);
+SCM_INTERNAL void scm_init_weak_set (void);
+
+#endif /* SCM_WEAK_SET_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2011, 2012, 2013, 2014 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 <assert.h>
+
+#include "libguile/bdw-gc.h"
+#include <gc/gc_mark.h>
+
+#include "libguile/_scm.h"
+#include "libguile/hash.h"
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+
+#include "libguile/validate.h"
+#include "libguile/weak-table.h"
+
+
+/* Weak Tables
+
+ This file implements weak hash tables. Weak hash tables are
+ generally used when you want to augment some object with additional
+ data, but when you don't have space to store the data in the object.
+ For example, procedure properties are implemented with weak tables.
+
+ Weak tables are implemented using an open-addressed hash table.
+ Basically this means that there is an array of entries, and the item
+ is expected to be found the slot corresponding to its hash code,
+ modulo the length of the array.
+
+ Collisions are handled using linear probing with the Robin Hood
+ technique. See Pedro Celis' paper, "Robin Hood Hashing":
+
+ http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf
+
+ The vector of entries is allocated in such a way that the GC doesn't
+ trace the weak values. For doubly-weak tables, this means that the
+ entries are allocated as an "atomic" piece of memory. Key-weak and
+ value-weak tables use a special GC kind with a custom mark procedure.
+ When items are added weakly into table, a disappearing link is
+ registered to their locations. If the referent is collected, then
+ that link will be zeroed out.
+
+ An entry in the table consists of the key and the value, together
+ with the hash code of the key. We munge hash codes so that they are
+ never 0. In this way we can detect removed entries (key of zero but
+ nonzero hash code), and can then reshuffle elements as needed to
+ maintain the robin hood ordering.
+
+ Compared to buckets-and-chains hash tables, open addressing has the
+ advantage that it is very cache-friendly. It also uses less memory.
+
+ Implementation-wise, there are two things to note.
+
+ 1. We assume that hash codes are evenly distributed across the
+ range of unsigned longs. The actual hash code stored in the
+ entry is left-shifted by 1 bit (losing 1 bit of hash precision),
+ and then or'd with 1. In this way we ensure that the hash field
+ of an occupied entry is nonzero. To map to an index, we
+ right-shift the hash by one, divide by the size, and take the
+ remainder.
+
+ 2. Since the weak references are stored in an atomic region with
+ disappearing links, they need to be accessed with the GC alloc
+ lock. `copy_weak_entry' will do that for you. The hash code
+ itself can be read outside the lock, though.
+ */
+
+
+typedef struct {
+ unsigned long hash;
+ scm_t_bits key;
+ scm_t_bits value;
+} scm_t_weak_entry;
+
+
+struct weak_entry_data {
+ scm_t_weak_entry *in;
+ scm_t_weak_entry *out;
+};
+
+static void*
+do_copy_weak_entry (void *data)
+{
+ struct weak_entry_data *e = data;
+
+ e->out->hash = e->in->hash;
+ e->out->key = e->in->key;
+ e->out->value = e->in->value;
+
+ return NULL;
+}
+
+static void
+copy_weak_entry (scm_t_weak_entry *src, scm_t_weak_entry *dst)
+{
+ struct weak_entry_data data;
+
+ data.in = src;
+ data.out = dst;
+
+ GC_call_with_alloc_lock (do_copy_weak_entry, &data);
+}
+
+static void
+register_disappearing_links (scm_t_weak_entry *entry,
+ SCM k, SCM v,
+ scm_t_weak_table_kind kind)
+{
+ if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k)
+ && (kind == SCM_WEAK_TABLE_KIND_KEY
+ || kind == SCM_WEAK_TABLE_KIND_BOTH))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->key,
+ SCM2PTR (k));
+
+ if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v)
+ && (kind == SCM_WEAK_TABLE_KIND_VALUE
+ || kind == SCM_WEAK_TABLE_KIND_BOTH))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value,
+ SCM2PTR (v));
+}
+
+static void
+unregister_disappearing_links (scm_t_weak_entry *entry,
+ scm_t_weak_table_kind kind)
+{
+ if (kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ GC_unregister_disappearing_link ((void **) &entry->key);
+
+ if (kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ GC_unregister_disappearing_link ((void **) &entry->value);
+}
+
+#ifndef HAVE_GC_MOVE_DISAPPEARING_LINK
+static void
+GC_move_disappearing_link (void **from, void **to)
+{
+ GC_unregister_disappearing_link (from);
+ SCM_I_REGISTER_DISAPPEARING_LINK (to, *to);
+}
+#endif
+
+static void
+move_disappearing_links (scm_t_weak_entry *from, scm_t_weak_entry *to,
+ SCM key, SCM value, scm_t_weak_table_kind kind)
+{
+ if ((kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ && SCM_HEAP_OBJECT_P (key))
+ GC_move_disappearing_link ((void **) &from->key, (void **) &to->key);
+
+ if ((kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ && SCM_HEAP_OBJECT_P (value))
+ GC_move_disappearing_link ((void **) &from->value, (void **) &to->value);
+}
+
+static void
+move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to,
+ scm_t_weak_table_kind kind)
+{
+ if (from->hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (from, ©);
+ to->hash = copy.hash;
+ to->key = copy.key;
+ to->value = copy.value;
+
+ move_disappearing_links (from, to,
+ SCM_PACK (copy.key), SCM_PACK (copy.value),
+ kind);
+ }
+ else
+ {
+ to->hash = 0;
+ to->key = 0;
+ to->value = 0;
+ }
+}
+
+
+typedef struct {
+ scm_t_weak_entry *entries; /* the data */
+ scm_i_pthread_mutex_t lock; /* the lock */
+ scm_t_weak_table_kind kind; /* what kind of table it is */
+ unsigned long size; /* total number of slots. */
+ unsigned long n_items; /* number of items in table */
+ unsigned long lower; /* when to shrink */
+ unsigned long upper; /* when to grow */
+ int size_index; /* index into hashtable_size */
+ int min_size_index; /* minimum size_index */
+} scm_t_weak_table;
+
+
+#define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_table))
+#define SCM_VALIDATE_WEAK_TABLE(pos, arg) \
+ SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_TABLE_P, "weak-table")
+#define SCM_WEAK_TABLE(x) ((scm_t_weak_table *) SCM_CELL_WORD_1 (x))
+
+
+static unsigned long
+hash_to_index (unsigned long hash, unsigned long size)
+{
+ return (hash >> 1) % size;
+}
+
+static unsigned long
+entry_distance (unsigned long hash, unsigned long k, unsigned long size)
+{
+ unsigned long origin = hash_to_index (hash, size);
+
+ if (k >= origin)
+ return k - origin;
+ else
+ /* The other key was displaced and wrapped around. */
+ return size - origin + k;
+}
+
+static void
+rob_from_rich (scm_t_weak_table *table, unsigned long k)
+{
+ unsigned long empty, size;
+
+ size = table->size;
+
+ /* If we are to free up slot K in the table, we need room to do so. */
+ assert (table->n_items < size);
+
+ empty = k;
+ do
+ empty = (empty + 1) % size;
+ while (table->entries[empty].hash);
+
+ do
+ {
+ unsigned long last = empty ? (empty - 1) : (size - 1);
+ move_weak_entry (&table->entries[last], &table->entries[empty],
+ table->kind);
+ empty = last;
+ }
+ while (empty != k);
+
+ table->entries[empty].hash = 0;
+ table->entries[empty].key = 0;
+ table->entries[empty].value = 0;
+}
+
+static void
+give_to_poor (scm_t_weak_table *table, unsigned long k)
+{
+ /* Slot K was just freed up; possibly shuffle others down. */
+ unsigned long size = table->size;
+
+ while (1)
+ {
+ unsigned long next = (k + 1) % size;
+ unsigned long hash;
+ scm_t_weak_entry copy;
+
+ hash = table->entries[next].hash;
+
+ if (!hash || hash_to_index (hash, size) == next)
+ break;
+
+ copy_weak_entry (&table->entries[next], ©);
+
+ if (!copy.key || !copy.value)
+ /* Lost weak reference. */
+ {
+ give_to_poor (table, next);
+ table->n_items--;
+ continue;
+ }
+
+ move_weak_entry (&table->entries[next], &table->entries[k],
+ table->kind);
+
+ k = next;
+ }
+
+ /* We have shuffled down any entries that should be shuffled down; now
+ free the end. */
+ table->entries[k].hash = 0;
+ table->entries[k].key = 0;
+ table->entries[k].value = 0;
+}
+
+
+\f
+
+/* The GC "kinds" for singly-weak tables. */
+static int weak_key_gc_kind;
+static int weak_value_gc_kind;
+
+static struct GC_ms_entry *
+mark_weak_key_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
+ struct GC_ms_entry *mark_stack_limit, GC_word env)
+{
+ scm_t_weak_entry *entries = (scm_t_weak_entry*) addr;
+ unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry);
+
+ for (k = 0; k < size; k++)
+ if (entries[k].hash && entries[k].key)
+ {
+ SCM value = SCM_PACK (entries[k].value);
+ mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (value),
+ mark_stack_ptr, mark_stack_limit,
+ NULL);
+ }
+
+ return mark_stack_ptr;
+}
+
+static struct GC_ms_entry *
+mark_weak_value_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
+ struct GC_ms_entry *mark_stack_limit, GC_word env)
+{
+ scm_t_weak_entry *entries = (scm_t_weak_entry*) addr;
+ unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry);
+
+ for (k = 0; k < size; k++)
+ if (entries[k].hash && entries[k].value)
+ {
+ SCM key = SCM_PACK (entries[k].key);
+ mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (key),
+ mark_stack_ptr, mark_stack_limit,
+ NULL);
+ }
+
+ return mark_stack_ptr;
+}
+
+static scm_t_weak_entry *
+allocate_entries (unsigned long size, scm_t_weak_table_kind kind)
+{
+ scm_t_weak_entry *ret;
+ size_t bytes = size * sizeof (*ret);
+
+ switch (kind)
+ {
+ case SCM_WEAK_TABLE_KIND_KEY:
+ ret = GC_generic_malloc (bytes, weak_key_gc_kind);
+ break;
+ case SCM_WEAK_TABLE_KIND_VALUE:
+ ret = GC_generic_malloc (bytes, weak_value_gc_kind);
+ break;
+ case SCM_WEAK_TABLE_KIND_BOTH:
+ ret = scm_gc_malloc_pointerless (bytes, "weak-table");
+ break;
+ default:
+ abort ();
+ }
+
+ memset (ret, 0, bytes);
+
+ return ret;
+}
+
+\f
+
+/* Growing or shrinking is triggered when the load factor
+ *
+ * L = N / S (N: number of items in table, S: bucket vector length)
+ *
+ * passes an upper limit of 0.9 or a lower limit of 0.2.
+ *
+ * The implementation stores the upper and lower number of items which
+ * trigger a resize in the hashtable object.
+ *
+ * Possible hash table sizes (primes) are stored in the array
+ * hashtable_size.
+ */
+
+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, 28762081,
+ 57524111, 115048217, 230096423
+};
+
+#define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
+
+static int
+compute_size_index (scm_t_weak_table *table)
+{
+ int i = table->size_index;
+
+ if (table->n_items < table->lower)
+ {
+ /* rehashing is not triggered when i <= min_size */
+ do
+ --i;
+ while (i > table->min_size_index
+ && table->n_items < hashtable_size[i] / 5);
+ }
+ else if (table->n_items > table->upper)
+ {
+ ++i;
+ if (i >= HASHTABLE_SIZE_N)
+ /* The biggest size currently is 230096423, which for a 32-bit
+ machine will occupy 2.3GB of memory at a load of 80%. There
+ is probably something better to do here, but if you have a
+ weak map of that size, you are hosed in any case. */
+ abort ();
+ }
+
+ return i;
+}
+
+static int
+is_acceptable_size_index (scm_t_weak_table *table, int size_index)
+{
+ int computed = compute_size_index (table);
+
+ if (size_index == computed)
+ /* We were going to grow or shrink, and allocating the new vector
+ didn't change the target size. */
+ return 1;
+
+ if (size_index == computed + 1)
+ {
+ /* We were going to enlarge the table, but allocating the new
+ vector finalized some objects, making an enlargement
+ unnecessary. It might still be a good idea to use the larger
+ table, though. (This branch also gets hit if, while allocating
+ the vector, some other thread was actively removing items from
+ the table. That is less likely, though.) */
+ unsigned long new_lower = hashtable_size[size_index] / 5;
+
+ return table->size > new_lower;
+ }
+
+ if (size_index == computed - 1)
+ {
+ /* We were going to shrink the table, but when we dropped the lock
+ to allocate the new vector, some other thread added elements to
+ the table. */
+ return 0;
+ }
+
+ /* The computed size differs from our newly allocated size by more
+ than one size index -- recalculate. */
+ return 0;
+}
+
+static void
+resize_table (scm_t_weak_table *table)
+{
+ scm_t_weak_entry *old_entries, *new_entries;
+ int new_size_index;
+ unsigned long old_size, new_size, old_k;
+
+ do
+ {
+ new_size_index = compute_size_index (table);
+ if (new_size_index == table->size_index)
+ return;
+ new_size = hashtable_size[new_size_index];
+ new_entries = allocate_entries (new_size, table->kind);
+ }
+ while (!is_acceptable_size_index (table, new_size_index));
+
+ old_entries = table->entries;
+ old_size = table->size;
+
+ table->size_index = new_size_index;
+ table->size = new_size;
+ if (new_size_index <= table->min_size_index)
+ table->lower = 0;
+ else
+ table->lower = new_size / 5;
+ table->upper = 9 * new_size / 10;
+ table->n_items = 0;
+ table->entries = new_entries;
+
+ for (old_k = 0; old_k < old_size; old_k++)
+ {
+ scm_t_weak_entry copy;
+ unsigned long new_k, distance;
+
+ if (!old_entries[old_k].hash)
+ continue;
+
+ copy_weak_entry (&old_entries[old_k], ©);
+
+ if (!copy.key || !copy.value)
+ continue;
+
+ new_k = hash_to_index (copy.hash, new_size);
+
+ for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size)
+ {
+ unsigned long other_hash = new_entries[new_k].hash;
+
+ if (!other_hash)
+ /* Found an empty entry. */
+ break;
+
+ /* Displace the entry if our distance is less, otherwise keep
+ looking. */
+ if (entry_distance (other_hash, new_k, new_size) < distance)
+ {
+ rob_from_rich (table, new_k);
+ break;
+ }
+ }
+
+ table->n_items++;
+ new_entries[new_k].hash = copy.hash;
+ new_entries[new_k].key = copy.key;
+ new_entries[new_k].value = copy.value;
+
+ register_disappearing_links (&new_entries[new_k],
+ SCM_PACK (copy.key), SCM_PACK (copy.value),
+ table->kind);
+ }
+}
+
+/* Run after GC via do_vacuum_weak_table, this function runs over the
+ whole table, removing lost weak references, reshuffling the table as it
+ goes. It might resize the table if it reaps enough entries. */
+static void
+vacuum_weak_table (scm_t_weak_table *table)
+{
+ scm_t_weak_entry *entries = table->entries;
+ unsigned long size = table->size;
+ unsigned long k;
+
+ for (k = 0; k < size; k++)
+ {
+ unsigned long hash = entries[k].hash;
+
+ if (hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key || !copy.value)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (table, k);
+ table->n_items--;
+ }
+ }
+ }
+
+ if (table->n_items < table->lower)
+ resize_table (table);
+}
+
+
+\f
+
+static SCM
+weak_table_ref (scm_t_weak_table *table, unsigned long hash,
+ scm_t_table_predicate_fn pred, void *closure,
+ SCM dflt)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = table->size;
+ entries = table->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; distance < size; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Not found. */
+ return dflt;
+
+ if (hash == other_hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key || !copy.value)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (table, k);
+ table->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
+ /* Found. */
+ return SCM_PACK (copy.value);
+ }
+
+ /* If the entry's distance is less, our key is not in the table. */
+ if (entry_distance (other_hash, k, size) < distance)
+ return dflt;
+ }
+
+ /* If we got here, then we were unfortunate enough to loop through the
+ whole table. Shouldn't happen, but hey. */
+ return dflt;
+}
+
+
+static void
+weak_table_put_x (scm_t_weak_table *table, unsigned long hash,
+ scm_t_table_predicate_fn pred, void *closure,
+ SCM key, SCM value)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = table->size;
+ entries = table->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; ; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Found an empty entry. */
+ break;
+
+ if (other_hash == hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key || !copy.value)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (table, k);
+ table->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
+ /* Found an entry with this key. */
+ break;
+ }
+
+ if (table->n_items > table->upper)
+ /* Full table, time to resize. */
+ {
+ resize_table (table);
+ return weak_table_put_x (table, hash >> 1, pred, closure, key, value);
+ }
+
+ /* Displace the entry if our distance is less, otherwise keep
+ looking. */
+ if (entry_distance (other_hash, k, size) < distance)
+ {
+ rob_from_rich (table, k);
+ break;
+ }
+ }
+
+ if (entries[k].hash)
+ unregister_disappearing_links (&entries[k], table->kind);
+ else
+ table->n_items++;
+
+ entries[k].hash = hash;
+ entries[k].key = SCM_UNPACK (key);
+ entries[k].value = SCM_UNPACK (value);
+
+ register_disappearing_links (&entries[k], key, value, table->kind);
+}
+
+
+static void
+weak_table_remove_x (scm_t_weak_table *table, unsigned long hash,
+ scm_t_table_predicate_fn pred, void *closure)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = table->size;
+ entries = table->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; distance < size; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Not found. */
+ return;
+
+ if (other_hash == hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key || !copy.value)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (table, k);
+ table->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
+ /* Found an entry with this key. */
+ {
+ entries[k].hash = 0;
+ entries[k].key = 0;
+ entries[k].value = 0;
+
+ unregister_disappearing_links (&entries[k], table->kind);
+
+ if (--table->n_items < table->lower)
+ resize_table (table);
+ else
+ give_to_poor (table, k);
+
+ return;
+ }
+ }
+
+ /* If the entry's distance is less, our key is not in the table. */
+ if (entry_distance (other_hash, k, size) < distance)
+ return;
+ }
+}
+
+
+\f
+static SCM
+make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
+{
+ scm_t_weak_table *table;
+
+ int i = 0, n = k ? k : 31;
+ while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
+ ++i;
+ n = hashtable_size[i];
+
+ table = scm_gc_malloc (sizeof (*table), "weak-table");
+ table->entries = allocate_entries (n, kind);
+ table->kind = kind;
+ table->n_items = 0;
+ table->size = n;
+ table->lower = 0;
+ table->upper = 9 * n / 10;
+ table->size_index = i;
+ table->min_size_index = i;
+ scm_i_pthread_mutex_init (&table->lock, NULL);
+
+ return scm_cell (scm_tc7_weak_table, (scm_t_bits)table);
+}
+
+void
+scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+ scm_puts_unlocked ("#<", port);
+ scm_puts_unlocked ("weak-table ", port);
+ scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port);
+ scm_putc_unlocked ('/', port);
+ scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port);
+ scm_puts_unlocked (">", port);
+}
+
+static void
+do_vacuum_weak_table (SCM table)
+{
+ scm_t_weak_table *t;
+
+ t = SCM_WEAK_TABLE (table);
+
+ /* Unlike weak sets, the weak table interface allows custom predicates
+ to call out to arbitrary Scheme. There are two ways that this code
+ can be re-entrant, then: calling weak hash procedures while in a
+ custom predicate, or via finalizers run explicitly by (gc) or in an
+ async (for non-threaded Guile). We add a restriction that
+ prohibits the first case, by convention. But since we can't
+ prohibit the second case, here we trylock instead of lock. Not so
+ nice. */
+ if (scm_i_pthread_mutex_trylock (&t->lock) == 0)
+ {
+ vacuum_weak_table (t);
+ scm_i_pthread_mutex_unlock (&t->lock);
+ }
+
+ return;
+}
+
+SCM
+scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
+{
+ SCM ret;
+
+ ret = make_weak_table (k, kind);
+
+ scm_i_register_weak_gc_callback (ret, do_vacuum_weak_table);
+
+ return ret;
+}
+
+SCM
+scm_weak_table_p (SCM obj)
+{
+ return scm_from_bool (SCM_WEAK_TABLE_P (obj));
+}
+
+SCM
+scm_c_weak_table_ref (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure, SCM dflt)
+#define FUNC_NAME "weak-table-ref"
+{
+ SCM ret;
+ scm_t_weak_table *t;
+
+ SCM_VALIDATE_WEAK_TABLE (1, table);
+
+ t = SCM_WEAK_TABLE (table);
+
+ scm_i_pthread_mutex_lock (&t->lock);
+
+ ret = weak_table_ref (t, raw_hash, pred, closure, dflt);
+
+ scm_i_pthread_mutex_unlock (&t->lock);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+void
+scm_c_weak_table_put_x (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure, SCM key, SCM value)
+#define FUNC_NAME "weak-table-put!"
+{
+ scm_t_weak_table *t;
+
+ SCM_VALIDATE_WEAK_TABLE (1, table);
+
+ t = SCM_WEAK_TABLE (table);
+
+ scm_i_pthread_mutex_lock (&t->lock);
+
+ weak_table_put_x (t, raw_hash, pred, closure, key, value);
+
+ scm_i_pthread_mutex_unlock (&t->lock);
+}
+#undef FUNC_NAME
+
+void
+scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure)
+#define FUNC_NAME "weak-table-remove!"
+{
+ scm_t_weak_table *t;
+
+ SCM_VALIDATE_WEAK_TABLE (1, table);
+
+ t = SCM_WEAK_TABLE (table);
+
+ scm_i_pthread_mutex_lock (&t->lock);
+
+ weak_table_remove_x (t, raw_hash, pred, closure);
+
+ scm_i_pthread_mutex_unlock (&t->lock);
+}
+#undef FUNC_NAME
+
+static int
+assq_predicate (SCM x, SCM y, void *closure)
+{
+ return scm_is_eq (x, SCM_PACK_POINTER (closure));
+}
+
+SCM
+scm_weak_table_refq (SCM table, SCM key, SCM dflt)
+{
+ if (SCM_UNBNDP (dflt))
+ dflt = SCM_BOOL_F;
+
+ return scm_c_weak_table_ref (table, scm_ihashq (key, -1),
+ assq_predicate, SCM_UNPACK_POINTER (key),
+ dflt);
+}
+
+void
+scm_weak_table_putq_x (SCM table, SCM key, SCM value)
+{
+ scm_c_weak_table_put_x (table, scm_ihashq (key, -1),
+ assq_predicate, SCM_UNPACK_POINTER (key),
+ key, value);
+}
+
+void
+scm_weak_table_remq_x (SCM table, SCM key)
+{
+ scm_c_weak_table_remove_x (table, scm_ihashq (key, -1),
+ assq_predicate, SCM_UNPACK_POINTER (key));
+}
+
+void
+scm_weak_table_clear_x (SCM table)
+#define FUNC_NAME "weak-table-clear!"
+{
+ scm_t_weak_table *t;
+
+ SCM_VALIDATE_WEAK_TABLE (1, table);
+
+ t = SCM_WEAK_TABLE (table);
+
+ scm_i_pthread_mutex_lock (&t->lock);
+
+ memset (t->entries, 0, sizeof (scm_t_weak_entry) * t->size);
+ t->n_items = 0;
+
+ scm_i_pthread_mutex_unlock (&t->lock);
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure,
+ SCM init, SCM table)
+{
+ scm_t_weak_table *t;
+ scm_t_weak_entry *entries;
+ unsigned long k, size;
+
+ t = SCM_WEAK_TABLE (table);
+
+ scm_i_pthread_mutex_lock (&t->lock);
+
+ size = t->size;
+ entries = t->entries;
+
+ for (k = 0; k < size; k++)
+ {
+ if (entries[k].hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (copy.key && copy.value)
+ {
+ /* Release table lock while we call the function. */
+ scm_i_pthread_mutex_unlock (&t->lock);
+ init = proc (closure,
+ SCM_PACK (copy.key), SCM_PACK (copy.value),
+ init);
+ scm_i_pthread_mutex_lock (&t->lock);
+ }
+ }
+ }
+
+ scm_i_pthread_mutex_unlock (&t->lock);
+
+ return init;
+}
+
+static SCM
+fold_trampoline (void *closure, SCM k, SCM v, SCM init)
+{
+ return scm_call_3 (SCM_PACK_POINTER (closure), k, v, init);
+}
+
+SCM
+scm_weak_table_fold (SCM proc, SCM init, SCM table)
+#define FUNC_NAME "weak-table-fold"
+{
+ SCM_VALIDATE_WEAK_TABLE (3, table);
+ SCM_VALIDATE_PROC (1, proc);
+
+ return scm_c_weak_table_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, table);
+}
+#undef FUNC_NAME
+
+static SCM
+for_each_trampoline (void *closure, SCM k, SCM v, SCM seed)
+{
+ scm_call_2 (SCM_PACK_POINTER (closure), k, v);
+ return seed;
+}
+
+void
+scm_weak_table_for_each (SCM proc, SCM table)
+#define FUNC_NAME "weak-table-for-each"
+{
+ SCM_VALIDATE_WEAK_TABLE (2, table);
+ SCM_VALIDATE_PROC (1, proc);
+
+ scm_c_weak_table_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, table);
+}
+#undef FUNC_NAME
+
+static SCM
+map_trampoline (void *closure, SCM k, SCM v, SCM seed)
+{
+ return scm_cons (scm_call_2 (SCM_PACK_POINTER (closure), k, v), seed);
+}
+
+SCM
+scm_weak_table_map_to_list (SCM proc, SCM table)
+#define FUNC_NAME "weak-table-map->list"
+{
+ SCM_VALIDATE_WEAK_TABLE (2, table);
+ SCM_VALIDATE_PROC (1, proc);
+
+ return scm_c_weak_table_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, table);
+}
+#undef FUNC_NAME
+
+
+\f
+
+/* Legacy interface. */
+
+SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
+ (SCM n),
+ "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
+ "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
+ "Return a weak hash table with @var{size} buckets.\n"
+ "\n"
+ "You can modify weak hash tables in exactly the same way you\n"
+ "would modify regular hash tables. (@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_weak_key_hash_table
+{
+ return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
+ SCM_WEAK_TABLE_KIND_KEY);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0,
+ (SCM n),
+ "Return a hash table with weak values with @var{size} buckets.\n"
+ "(@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_weak_value_hash_table
+{
+ return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
+ SCM_WEAK_TABLE_KIND_VALUE);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 0, 1, 0,
+ (SCM n),
+ "Return a hash table with weak keys and values with @var{size}\n"
+ "buckets. (@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_doubly_weak_hash_table
+{
+ return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
+ SCM_WEAK_TABLE_KIND_BOTH);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
+ "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
+ "Return @code{#t} if @var{obj} is the specified weak hash\n"
+ "table. Note that a doubly weak hash table is neither a weak key\n"
+ "nor a weak value hash table.")
+#define FUNC_NAME s_scm_weak_key_hash_table_p
+{
+ return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
+ SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_KEY);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a weak value hash table.")
+#define FUNC_NAME s_scm_weak_value_hash_table_p
+{
+ return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
+ SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_VALUE);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a doubly weak hash table.")
+#define FUNC_NAME s_scm_doubly_weak_hash_table_p
+{
+ return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
+ SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_BOTH);
+}
+#undef FUNC_NAME
+
+
+
+\f
+
+void
+scm_weak_table_prehistory (void)
+{
+ weak_key_gc_kind =
+ GC_new_kind (GC_new_free_list (),
+ GC_MAKE_PROC (GC_new_proc (mark_weak_key_table), 0),
+ 0, 0);
+ weak_value_gc_kind =
+ GC_new_kind (GC_new_free_list (),
+ GC_MAKE_PROC (GC_new_proc (mark_weak_value_table), 0),
+ 0, 0);
+}
+
+void
+scm_init_weak_table ()
+{
+#include "libguile/weak-table.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_WEAK_TABLE_H
+#define SCM_WEAK_TABLE_H
+
+/* Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * 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 weak table API is currently only used internally. We could make it
+ public later, after some API review. */
+
+typedef enum {
+ SCM_WEAK_TABLE_KIND_KEY,
+ SCM_WEAK_TABLE_KIND_VALUE,
+ SCM_WEAK_TABLE_KIND_BOTH,
+} scm_t_weak_table_kind;
+
+/* Function that returns nonzero if the given mapping is the one we are
+ looking for. */
+typedef int (*scm_t_table_predicate_fn) (SCM k, SCM v, void *closure);
+
+/* Function to fold over the elements of a set. */
+typedef SCM (*scm_t_table_fold_fn) (void *closure, SCM k, SCM v, SCM result);
+
+SCM_INTERNAL SCM scm_c_make_weak_table (unsigned long k,
+ scm_t_weak_table_kind kind);
+SCM_INTERNAL SCM scm_weak_table_p (SCM h);
+
+SCM_INTERNAL SCM scm_c_weak_table_ref (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure, SCM dflt);
+SCM_INTERNAL void scm_c_weak_table_put_x (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure, SCM key, SCM value);
+SCM_INTERNAL void scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure);
+
+SCM_INTERNAL SCM scm_weak_table_refq (SCM table, SCM key, SCM dflt);
+SCM_INTERNAL void scm_weak_table_putq_x (SCM table, SCM key, SCM value);
+SCM_INTERNAL void scm_weak_table_remq_x (SCM table, SCM key);
+
+SCM_INTERNAL void scm_weak_table_clear_x (SCM table);
+
+SCM_INTERNAL SCM scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure,
+ SCM init, SCM table);
+SCM_INTERNAL SCM scm_weak_table_fold (SCM proc, SCM init, SCM table);
+SCM_INTERNAL void scm_weak_table_for_each (SCM proc, SCM table);
+SCM_INTERNAL SCM scm_weak_table_map_to_list (SCM proc, SCM table);
+
+\f
+
+/* Legacy interface. */
+SCM_API SCM scm_make_weak_key_hash_table (SCM k);
+SCM_API SCM scm_make_weak_value_hash_table (SCM k);
+SCM_API SCM scm_make_doubly_weak_hash_table (SCM k);
+SCM_API SCM scm_weak_key_hash_table_p (SCM h);
+SCM_API SCM scm_weak_value_hash_table_p (SCM h);
+SCM_API SCM scm_doubly_weak_hash_table_p (SCM h);
+
+\f
+
+SCM_INTERNAL void scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate);
+SCM_INTERNAL void scm_weak_table_prehistory (void);
+SCM_INTERNAL void scm_init_weak_table (void);
+
+#endif /* SCM_WEAK_TABLE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2006, 2008, 2009,
+ * 2010, 2011, 2012, 2013, 2014 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 "libguile/_scm.h"
+#include "libguile/vectors.h"
+
+#include "libguile/validate.h"
+
+\f
+
+/* {Weak Vectors}
+ */
+
+#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
+
+SCM
+scm_c_make_weak_vector (size_t len, SCM fill)
+#define FUNC_NAME "make-weak-vector"
+{
+ SCM wv;
+ size_t j;
+
+ SCM_ASSERT_RANGE (1, scm_from_size_t (len), len <= VECTOR_MAX_LENGTH);
+
+ if (SCM_UNBNDP (fill))
+ fill = SCM_UNSPECIFIED;
+
+ wv = SCM_PACK_POINTER (scm_gc_malloc_pointerless ((len + 1) * sizeof (SCM),
+ "weak vector"));
+
+ SCM_SET_CELL_WORD_0 (wv, (len << 8) | scm_tc7_wvect);
+
+ if (SCM_HEAP_OBJECT_P (fill))
+ {
+ memset (SCM_I_VECTOR_WELTS (wv), 0, len * sizeof (SCM));
+ for (j = 0; j < len; j++)
+ scm_c_weak_vector_set_x (wv, j, fill);
+ }
+ else
+ for (j = 0; j < len; j++)
+ SCM_SIMPLE_VECTOR_SET (wv, j, fill);
+
+ return wv;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
+ (SCM size, SCM fill),
+ "Return a weak vector with @var{size} elements. If the optional\n"
+ "argument @var{fill} is given, all entries in the vector will be\n"
+ "set to @var{fill}. The default value for @var{fill} is the\n"
+ "empty list.")
+#define FUNC_NAME s_scm_make_weak_vector
+{
+ return scm_c_make_weak_vector (scm_to_size_t (size), fill);
+}
+#undef FUNC_NAME
+
+
+SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
+
+SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
+ (SCM lst),
+ "@deffnx {Scheme Procedure} list->weak-vector lst\n"
+ "Construct a weak vector from a list: @code{weak-vector} uses\n"
+ "the list of its arguments while @code{list->weak-vector} uses\n"
+ "its only argument @var{l} (a list) to construct a weak vector\n"
+ "the same way @code{list->vector} would.")
+#define FUNC_NAME s_scm_weak_vector
+{
+ SCM wv;
+ size_t i;
+ long c_size;
+
+ SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, c_size);
+
+ wv = scm_c_make_weak_vector ((size_t) c_size, SCM_BOOL_F);
+
+ for (i = 0; scm_is_pair (lst); lst = SCM_CDR (lst), i++)
+ scm_c_weak_vector_set_x (wv, i, SCM_CAR (lst));
+
+ return wv;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
+ "weak hashes are also weak vectors.")
+#define FUNC_NAME s_scm_weak_vector_p
+{
+ return scm_from_bool (scm_is_weak_vector (obj));
+}
+#undef FUNC_NAME
+
+
+int
+scm_is_weak_vector (SCM obj)
+#define FUNC_NAME s_scm_weak_vector_p
+{
+ return SCM_I_WVECTP (obj);
+}
+#undef FUNC_NAME
+
+
+#define SCM_VALIDATE_WEAK_VECTOR(pos, var) \
+ SCM_I_MAKE_VALIDATE_MSG2 (pos, var, SCM_I_WVECTP, "weak vector")
+
+
+SCM_DEFINE (scm_weak_vector_length, "weak-vector-length", 1, 0, 0,
+ (SCM wvect),
+ "Like @code{vector-length}, but for weak vectors.")
+#define FUNC_NAME s_scm_weak_vector_length
+{
+ return scm_from_size_t (scm_c_weak_vector_length (wvect));
+}
+#undef FUNC_NAME
+
+
+size_t
+scm_c_weak_vector_length (SCM wvect)
+#define FUNC_NAME s_scm_weak_vector_length
+{
+ SCM_VALIDATE_WEAK_VECTOR (1, wvect);
+ return SCM_I_VECTOR_LENGTH (wvect);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_vector_ref, "weak-vector-ref", 2, 0, 0,
+ (SCM wvect, SCM k),
+ "Like @code{vector-ref}, but for weak vectors.")
+#define FUNC_NAME s_scm_weak_vector_ref
+{
+ return scm_c_weak_vector_ref (wvect, scm_to_size_t (k));
+}
+#undef FUNC_NAME
+
+
+struct weak_vector_ref_data
+{
+ SCM wv;
+ size_t k;
+};
+
+static void*
+weak_vector_ref (void *data)
+{
+ struct weak_vector_ref_data *d = data;
+
+ return (void *) SCM_UNPACK (SCM_SIMPLE_VECTOR_REF (d->wv, d->k));
+}
+
+SCM
+scm_c_weak_vector_ref (SCM wv, size_t k)
+#define FUNC_NAME s_scm_weak_vector_ref
+{
+ struct weak_vector_ref_data d;
+ void *ret;
+
+ SCM_VALIDATE_WEAK_VECTOR (1, wv);
+
+ d.wv = wv;
+ d.k = k;
+
+ if (k >= SCM_I_VECTOR_LENGTH (wv))
+ scm_out_of_range ("weak-vector-ref", scm_from_size_t (k));
+
+ ret = GC_call_with_alloc_lock (weak_vector_ref, &d);
+
+ if (ret)
+ return SCM_PACK_POINTER (ret);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_vector_set_x, "weak-vector-set!", 3, 0, 0,
+ (SCM wvect, SCM k, SCM obj),
+ "Like @code{vector-set!}, but for weak vectors.")
+#define FUNC_NAME s_scm_weak_vector_set_x
+{
+ scm_c_weak_vector_set_x (wvect, scm_to_size_t (k), obj);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+void
+scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x)
+#define FUNC_NAME s_scm_weak_vector_set_x
+{
+ SCM *elts;
+ struct weak_vector_ref_data d;
+ void *prev;
+
+ SCM_VALIDATE_WEAK_VECTOR (1, wv);
+
+ d.wv = wv;
+ d.k = k;
+
+ if (k >= SCM_I_VECTOR_LENGTH (wv))
+ scm_out_of_range ("weak-vector-set!", scm_from_size_t (k));
+
+ prev = GC_call_with_alloc_lock (weak_vector_ref, &d);
+
+ elts = SCM_I_VECTOR_WELTS (wv);
+
+ if (prev && SCM_HEAP_OBJECT_P (SCM_PACK_POINTER (prev)))
+ GC_unregister_disappearing_link ((void **) &elts[k]);
+
+ elts[k] = x;
+
+ if (SCM_HEAP_OBJECT_P (x))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k],
+ SCM2PTR (x));
+}
+#undef FUNC_NAME
+
+
+\f
+static void
+scm_init_weak_vector_builtins (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/weak-vector.x"
+#endif
+}
+
+void
+scm_init_weak_vectors ()
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_weak_vector_builtins",
+ (scm_t_extension_init_func)scm_init_weak_vector_builtins,
+ NULL);
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_WEAK_VECTOR_H
+#define SCM_WEAK_VECTOR_H
+
+/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009, 2011, 2014 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
+/* Weak vectors. */
+
+#define SCM_I_WVECTP(x) (SCM_HAS_TYP7 (x, scm_tc7_wvect))
+
+SCM_API SCM scm_make_weak_vector (SCM len, SCM fill);
+SCM_API SCM scm_weak_vector (SCM l);
+SCM_API SCM scm_weak_vector_p (SCM x);
+SCM_API SCM scm_weak_vector_length (SCM v);
+SCM_API SCM scm_weak_vector_ref (SCM v, SCM k);
+SCM_API SCM scm_weak_vector_set_x (SCM v, SCM k, SCM x);
+
+SCM_API SCM scm_c_make_weak_vector (size_t len, SCM fill);
+SCM_API int scm_is_weak_vector (SCM obj);
+SCM_API size_t scm_c_weak_vector_length (SCM vec);
+SCM_API SCM scm_c_weak_vector_ref (SCM v, size_t k);
+SCM_API void scm_c_weak_vector_set_x (SCM v, size_t k, SCM x);
+
+SCM_INTERNAL void scm_init_weak_vectors (void);
+
+
+#endif /* SCM_WEAK_VECTOR_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
+++ /dev/null
-/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2006, 2008, 2009, 2010,
- * 2011, 2012, 2014 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 "libguile/_scm.h"
-#include "libguile/vectors.h"
-#include "libguile/hashtab.h"
-
-#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 ((void **) &cell->word_0, SCM2PTR (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 ((void **) &cell->word_1, SCM2PTR (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 ((void **) &cell->word_0, SCM2PTR (car));
- if (SCM_NIMP (cdr))
- SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &cell->word_1, SCM2PTR (cdr));
-
- return (SCM_PACK (cell));
-}
-
-
-\f
-
-/* 1. The current hash table implementation in hashtab.c uses weak alist
- * vectors (formerly called weak hash tables) internally.
- *
- * 2. All hash table operations still work on alist vectors.
- *
- * 3. The weak vector and alist vector Scheme API is accessed through
- * the module (ice-9 weak-vector).
- */
-
-
-/* {Weak Vectors}
- */
-
-
-#define SCM_VALIDATE_WEAK_VECTOR(pos, var) \
- SCM_I_MAKE_VALIDATE_MSG2 (pos, var, SCM_I_WVECTP, "weak vector")
-
-
-SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
- (SCM size, SCM fill),
- "Return a weak vector with @var{size} elements. If the optional\n"
- "argument @var{fill} is given, all entries in the vector will be\n"
- "set to @var{fill}. The default value for @var{fill} is the\n"
- "empty list.")
-#define FUNC_NAME s_scm_make_weak_vector
-{
- return scm_i_make_weak_vector (0, size, fill);
-}
-#undef FUNC_NAME
-
-
-SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
-
-SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
- (SCM l),
- "@deffnx {Scheme Procedure} list->weak-vector l\n"
- "Construct a weak vector from a list: @code{weak-vector} uses\n"
- "the list of its arguments while @code{list->weak-vector} uses\n"
- "its only argument @var{l} (a list) to construct a weak vector\n"
- "the same way @code{list->vector} would.")
-#define FUNC_NAME s_scm_weak_vector
-{
- return scm_i_make_weak_vector_from_list (0, l);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
- "weak hashes are also weak vectors.")
-#define FUNC_NAME s_scm_weak_vector_p
-{
- return scm_from_bool (scm_is_weak_vector (obj));
-}
-#undef FUNC_NAME
-
-
-int
-scm_is_weak_vector (SCM obj)
-{
- return SCM_I_WVECTP (obj) && !SCM_IS_WHVEC (obj);
-}
-
-
-SCM_DEFINE (scm_weak_vector_length, "weak-vector-length", 1, 0, 0,
- (SCM wvect),
- "Returns the number of elements in @var{wvect} as an exact integer.")
-#define FUNC_NAME s_scm_weak_vector_length
-{
- return scm_from_size_t (scm_c_weak_vector_length (wvect));
-}
-#undef FUNC_NAME
-
-
-size_t
-scm_c_weak_vector_length (SCM wvect)
-#define FUNC_NAME s_scm_weak_vector_length
-{
- SCM_VALIDATE_WEAK_VECTOR (1, wvect);
- return SCM_I_VECTOR_LENGTH (wvect);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_vector_ref, "weak-vector-ref", 2, 0, 0,
- (SCM wvect, SCM k),
- "Like @code{vector-ref}, but for weak vectors.")
-#define FUNC_NAME s_scm_weak_vector_ref
-{
- return scm_c_weak_vector_ref (wvect, scm_to_size_t (k));
-}
-#undef FUNC_NAME
-
-
-SCM
-scm_c_weak_vector_ref (SCM wvect, size_t k)
-#define FUNC_NAME s_scm_weak_vector_ref
-{
- SCM elt;
-
- SCM_VALIDATE_WEAK_VECTOR (1, wvect);
-
- if (k >= SCM_I_VECTOR_LENGTH (wvect))
- scm_out_of_range ("weak-vector-ref", scm_from_size_t (k));
- elt = (SCM_I_VECTOR_ELTS(wvect))[k];
-
- if (SCM_UNPACK (elt) == 0)
- /* ELT was a weak pointer and got nullified by the GC. */
- return SCM_BOOL_F;
-
- return elt;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_vector_set_x, "weak-vector-set!", 3, 0, 0,
- (SCM wvect, SCM k, SCM elt),
- "Like @code{vector-set!}, but for weak vectors.")
-#define FUNC_NAME s_scm_weak_vector_set_x
-{
- scm_c_weak_vector_set_x (wvect, scm_to_size_t (k), elt);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-void
-scm_c_weak_vector_set_x (SCM wvect, size_t k, SCM elt)
-#define FUNC_NAME s_scm_weak_vector_set_x
-{
- SCM *loc;
-
- SCM_VALIDATE_WEAK_VECTOR (1, wvect);
-
- if (k >= SCM_I_VECTOR_LENGTH (wvect))
- scm_out_of_range ("weak-vector-set!", scm_from_size_t (k));
-
- loc = & SCM_I_VECTOR_WELTS (wvect)[k];
- *loc = elt;
-
- /* Make it a weak pointer. */
- SCM_I_REGISTER_DISAPPEARING_LINK ((void **) loc, SCM2PTR (elt));
-}
-#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),
- "@deffnx {Scheme Procedure} make-weak-value-alist-vector size\n"
- "@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size\n"
- "Return a weak hash table with @var{size} buckets. As with any\n"
- "hash table, choosing a good size for the table requires some\n"
- "caution.\n"
- "\n"
- "You can modify weak hash tables in exactly the same way you\n"
- "would modify regular hash tables. (@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_weak_key_alist_vector
-{
- return scm_make_weak_key_hash_table (size);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, 1, 0,
- (SCM size),
- "Return a hash table with weak values with @var{size} buckets.\n"
- "(@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_weak_value_alist_vector
-{
- return scm_make_weak_value_hash_table (size);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", 1, 0, 0,
- (SCM size),
- "Return a hash table with weak keys and values with @var{size}\n"
- "buckets. (@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_doubly_weak_alist_vector
-{
- return scm_make_doubly_weak_hash_table (size);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0,
- (SCM obj),
- "@deffnx {Scheme Procedure} weak-value-alist-vector? obj\n"
- "@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj\n"
- "Return @code{#t} if @var{obj} is the specified weak hash\n"
- "table. Note that a doubly weak hash table is neither a weak key\n"
- "nor a weak value hash table.")
-#define FUNC_NAME s_scm_weak_key_alist_vector_p
-{
- return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a weak value hash table.")
-#define FUNC_NAME s_scm_weak_value_alist_vector_p
-{
- return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a doubly weak hash table.")
-#define FUNC_NAME s_scm_doubly_weak_alist_vector_p
-{
- return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
-}
-#undef FUNC_NAME
-
-
-
-\f
-SCM
-scm_init_weaks_builtins ()
-{
-#include "libguile/weaks.x"
- 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 ()
-{
- scm_c_define_gsubr ("%init-weaks-builtins", 0, 0, 0,
- scm_init_weaks_builtins);
-}
-
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+++ /dev/null
-/* classes: h_files */
-
-#ifndef SCM_WEAKS_H
-#define SCM_WEAKS_H
-
-/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009, 2011, 2014 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
-
-#define SCM_WVECTF_WEAK_KEY 1
-#define SCM_WVECTF_WEAK_VALUE 2
-
-#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)
-
-#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(X) (SCM_I_WVECT_TYPE (X) == 1)
-#define SCM_IS_WHVEC_V(X) (SCM_I_WVECT_TYPE (X) == 2)
-#define SCM_IS_WHVEC_B(X) (SCM_I_WVECT_TYPE (X) == 3)
-#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_UNPACK (SCM_CELL_OBJECT ((_cell), (_word))) == 0)
-#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_vector_p (SCM x);
-SCM_API SCM scm_weak_vector_length (SCM v);
-SCM_API SCM scm_weak_vector_ref (SCM v, SCM k);
-SCM_API SCM scm_weak_vector_set_x (SCM v, SCM k, SCM x);
-
-SCM_API SCM scm_c_make_weak_vector (size_t k, SCM fill);
-SCM_API int scm_is_weak_vector (SCM obj);
-SCM_API size_t scm_c_weak_vector_length (SCM vec);
-SCM_API SCM scm_c_weak_vector_ref (SCM v, size_t k);
-SCM_API void scm_c_weak_vector_set_x (SCM v, size_t k, SCM x);
-
-SCM_API SCM scm_make_weak_key_alist_vector (SCM k);
-SCM_API SCM scm_make_weak_value_alist_vector (SCM k);
-SCM_API SCM scm_make_doubly_weak_alist_vector (SCM k);
-SCM_API SCM scm_weak_key_alist_vector_p (SCM x);
-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);
-SCM_INTERNAL void scm_i_mark_weak_vector (SCM w);
-SCM_INTERNAL int scm_i_mark_weak_vectors_non_weaks (void);
-SCM_INTERNAL void scm_i_remove_weaks_from_weak_vectors (void);
-
-
-#endif /* SCM_WEAKS_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
isfinite
isinf
isnan
+ largefile
ldexp
lib-symbol-versions
lib-symbol-visibility
## Jim Blandy <jimb@red-bean.com> --- September 1997
##
## Copyright (C) 1998, 1999, 2001, 2006, 2007, 2008, 2009, 2011,
-## 2012, 2013, 2014 Free Software Foundation, Inc.
+## 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## Fifth Floor, Boston, MA 02110-1301 USA
bin_SCRIPTS = guile-config guild
-EXTRA_DIST= \
- guile.m4 ChangeLog-2008 \
- guile-2.0.pc.in guile-2.0-uninstalled.pc.in \
+EXTRA_DIST= \
+ guile.m4 ChangeLog-2008 \
+ guile-$(GUILE_EFFECTIVE_VERSION).pc.in \
+ guile-$(GUILE_EFFECTIVE_VERSION)-uninstalled.pc.in \
guild.in guile-config.in
# What we now call `guild' used to be known as `guile-tools'.
$(LN_S) "$$guild" "$$guile_tools"
pkgconfigdir = $(libdir)/pkgconfig
-pkgconfig_DATA = guile-2.0.pc
+pkgconfig_DATA = guile-$(GUILE_EFFECTIVE_VERSION).pc
## FIXME: in the future there will be direct automake support for
## doing this. When that happens, switch over.
-e "s|[@]INET_NTOP_LIB[@]|$(INET_NTOP_LIB)|g" \
-e "s|[@]INET_PTON_LIB[@]|$(INET_PTON_LIB)|g"
-guile-2.0.pc: guile-2.0.pc.in
+guile-$(GUILE_EFFECTIVE_VERSION).pc: guile-$(GUILE_EFFECTIVE_VERSION).pc.in
$(substitute) < "$<" > "$@.out"
mv "$@.out" "$@"
-guile-2.0-uninstalled.pc: guile-2.0-uninstalled.pc.in
+guile-$(GUILE_EFFECTIVE_VERSION)-uninstalled.pc: guile-$(GUILE_EFFECTIVE_VERSION)-uninstalled.pc.in
$(substitute) < "$<" > "$@.out"
mv "$@.out" "$@"
CLEANFILES = \
guile-config guild \
- guile-2.0.pc guile-2.0-uninstalled.pc
+ guile-$(GUILE_EFFECTIVE_VERSION).pc guile-$(GUILE_EFFECTIVE_VERSION)-uninstalled.pc
;;;; guile-config --- utility for linking programs with Guile
;;;; Jim Blandy <jim@red-bean.com> --- September 1997
;;;;
-;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(dle " " p " --help - show usage info (this message)")
(dle " " p " --help SUBCOMMAND - show help for SUBCOMMAND")))
-(define guile-module "guile-2.0")
+(define guile-module "guile-2.2")
(define (pkg-config . args)
(let* ((real-args (cons %pkg-config-program args))
# We're at the root of the module hierarchy.
modpath =
-# Build eval.go first.
-$(GOBJECTS): ice-9/eval.go
-CLEANFILES += ice-9/eval.go
-nobase_mod_DATA += ice-9/eval.scm
-nobase_ccache_DATA += ice-9/eval.go
-EXTRA_DIST += ice-9/eval.scm
-ETAGS_ARGS += ice-9/eval.scm
+# Build eval.go first. Then build psyntax-pp.go, as the expander has to
+# run on every loaded scheme file. It doesn't pay off at compile-time
+# to interpret the expander in parallel.
+BOOT_SOURCES = ice-9/psyntax-pp.scm
+BOOT_GOBJECTS = $(BOOT_SOURCES:%.scm=%.go)
+$(BOOT_GOBJECTS): ice-9/eval.go
+$(GOBJECTS): $(BOOT_GOBJECTS)
+CLEANFILES += ice-9/eval.go $(BOOT_GOBJECTS)
+nobase_mod_DATA += ice-9/eval.scm $(BOOT_SOURCES)
+nobase_ccache_DATA += ice-9/eval.go $(BOOT_GOBJECTS)
+EXTRA_DIST += ice-9/eval.scm $(BOOT_SOURCES)
+ETAGS_ARGS += ice-9/eval.scm $(BOOT_SOURCES)
+
+VM_TARGETS := system/vm/assembler.go system/vm/disassembler.go
+$(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h
ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm
ice-9/match.go: ice-9/match.scm ice-9/match.upstream.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.
+# 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/peval.scm \
+ language/cps/types.scm \
+ system/vm/elf.scm \
ice-9/vlist.scm \
srfi/srfi-1.scm \
- language/tree-il/peval.scm \
- language/tree-il/cse.scm \
+ system/vm/linker.scm \
+ system/vm/dwarf.scm \
+ system/vm/assembler.scm \
\
language/tree-il.scm \
- language/glil.scm \
- language/assembly.scm \
$(TREE_IL_LANG_SOURCES) \
- $(GLIL_LANG_SOURCES) \
- $(ASSEMBLY_LANG_SOURCES) \
+ $(CPS_LANG_SOURCES) \
$(BYTECODE_LANG_SOURCES) \
- $(OBJCODE_LANG_SOURCES) \
$(VALUE_LANG_SOURCES) \
$(SCHEME_LANG_SOURCES) \
$(SYSTEM_BASE_SOURCES) \
\
$(ICE_9_SOURCES) \
+ $(SYSTEM_SOURCES) \
$(SRFI_SOURCES) \
$(RNRS_SOURCES) \
$(OOP_SOURCES) \
- $(SYSTEM_SOURCES) \
$(SCRIPTS_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
$(ELISP_LANG_SOURCES) \
ice-9/ChangeLog-2008
ice-9/psyntax-pp.scm.gen:
- GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \
- $(top_builddir_absolute)/meta/guile -s $(srcdir)/ice-9/compile-psyntax.scm \
+ $(top_builddir_absolute)/meta/guile --no-auto-compile -s $(srcdir)/ice-9/compile-psyntax.scm \
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
.PHONY: ice-9/psyntax-pp.scm.gen
# Keep this rule in sync with that in `am/guilec'.
ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
- $(AM_V_GUILEC)GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 \
+ $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \
$(top_builddir)/meta/uninstalled-env \
guild compile --target="$(host)" $(GUILE_WARNINGS) \
-L "$(abs_srcdir)" -L "$(abs_builddir)" \
language/tree-il/canonicalize.scm \
language/tree-il/analyze.scm \
language/tree-il/inline.scm \
- language/tree-il/compile-glil.scm \
+ language/tree-il/compile-cps.scm \
language/tree-il/debug.scm \
language/tree-il/spec.scm
-GLIL_LANG_SOURCES = \
- language/glil/spec.scm language/glil/compile-assembly.scm
-
-ASSEMBLY_LANG_SOURCES = \
- language/assembly/spec.scm \
- language/assembly/compile-bytecode.scm \
- language/assembly/decompile-bytecode.scm \
- language/assembly/disassemble.scm
-
-BYTECODE_LANG_SOURCES = \
+CPS_LANG_SOURCES = \
+ language/cps.scm \
+ language/cps/arities.scm \
+ language/cps/closure-conversion.scm \
+ language/cps/compile-bytecode.scm \
+ language/cps/constructors.scm \
+ language/cps/contification.scm \
+ language/cps/cse.scm \
+ language/cps/dce.scm \
+ language/cps/dfg.scm \
+ language/cps/effects-analysis.scm \
+ language/cps/elide-values.scm \
+ language/cps/intmap.scm \
+ language/cps/intset.scm \
+ language/cps/primitives.scm \
+ language/cps/prune-bailouts.scm \
+ language/cps/prune-top-level-scopes.scm \
+ language/cps/reify-primitives.scm \
+ language/cps/renumber.scm \
+ language/cps/self-references.scm \
+ language/cps/slot-allocation.scm \
+ language/cps/simplify.scm \
+ language/cps/spec.scm \
+ language/cps/specialize-primcalls.scm \
+ language/cps/type-fold.scm \
+ language/cps/verify.scm
+
+BYTECODE_LANG_SOURCES = \
+ language/bytecode.scm \
language/bytecode/spec.scm
-OBJCODE_LANG_SOURCES = \
- language/objcode/spec.scm
-
VALUE_LANG_SOURCES = \
language/value/spec.scm
language/ecmascript/spec.scm
ELISP_LANG_SOURCES = \
+ language/elisp/falias.scm \
language/elisp/lexer.scm \
language/elisp/parser.scm \
language/elisp/bindings.scm \
language/elisp/runtime.scm \
language/elisp/runtime/function-slot.scm \
language/elisp/runtime/value-slot.scm \
- language/elisp/runtime/macros.scm \
- language/elisp/runtime/subrs.scm \
language/elisp/spec.scm
BRAINFUCK_LANG_SOURCES = \
system/base/ck.scm
ICE_9_SOURCES = \
- ice-9/r4rs.scm \
ice-9/r5rs.scm \
ice-9/deprecated.scm \
ice-9/and-let-star.scm \
ice-9/null.scm \
ice-9/occam-channel.scm \
ice-9/optargs.scm \
+ ice-9/peg/simplify-tree.scm \
+ ice-9/peg/codegen.scm \
+ ice-9/peg/cache.scm \
+ ice-9/peg/using-parsers.scm \
+ ice-9/peg/string-peg.scm \
+ ice-9/peg.scm \
ice-9/poe.scm \
ice-9/poll.scm \
ice-9/popen.scm \
system/vm/inspect.scm \
system/vm/coverage.scm \
system/vm/frame.scm \
- system/vm/instruction.scm \
- system/vm/objcode.scm \
+ system/vm/loader.scm \
system/vm/program.scm \
system/vm/trace.scm \
system/vm/traps.scm \
system/vm/trap-state.scm \
+ system/vm/debug.scm \
+ system/vm/disassembler.scm \
system/vm/vm.scm \
system/foreign.scm \
system/foreign-object.scm \
EXTRA_DIST += oop/ChangeLog-2008
+ELISP_SOURCES = \
+ language/elisp/boot.el
+
NOCOMP_SOURCES = \
ice-9/match.upstream.scm \
ice-9/psyntax.scm \
\f
-;;; {Error handling}
+;;; {Language primitives}
;;;
-;; Define delimited continuation operators, and implement catch and throw in
-;; terms of them.
-
-(define make-prompt-tag
- (lambda* (#:optional (stem "prompt"))
- (gensym stem)))
-
-(define default-prompt-tag
- ;; not sure if we should expose this to the user as a fluid
- (let ((%default-prompt-tag (make-prompt-tag)))
- (lambda ()
- %default-prompt-tag)))
-
-(define (call-with-prompt tag thunk handler)
- (@prompt tag (thunk) handler))
-(define (abort-to-prompt tag . args)
- (@abort tag args))
-
-
-;; Define catch and with-throw-handler, using some common helper routines and a
-;; shared fluid. Hide the helpers in a lexical contour.
-
-(define with-throw-handler #f)
-(let ()
- (define (default-exception-handler k . args)
- (cond
- ((eq? k 'quit)
- (primitive-exit (cond
- ((not (pair? args)) 0)
- ((integer? (car args)) (car args))
- ((not (car args)) 1)
- (else 0))))
- (else
- (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
- (primitive-exit 1))))
-
- (define %running-exception-handlers (make-fluid '()))
- (define %exception-handler (make-fluid default-exception-handler))
-
- (define (default-throw-handler prompt-tag catch-k)
- (let ((prev (fluid-ref %exception-handler)))
- (lambda (thrown-k . args)
- (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
- (apply abort-to-prompt prompt-tag thrown-k args)
- (apply prev thrown-k args)))))
-
- (define (custom-throw-handler prompt-tag catch-k pre)
- (let ((prev (fluid-ref %exception-handler)))
- (lambda (thrown-k . args)
- (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
- (let ((running (fluid-ref %running-exception-handlers)))
- (with-fluids ((%running-exception-handlers (cons pre running)))
- (if (not (memq pre running))
- (apply pre thrown-k args))
- ;; fall through
- (if prompt-tag
- (apply abort-to-prompt prompt-tag thrown-k args)
- (apply prev thrown-k args))))
- (apply prev thrown-k args)))))
-
- (set! catch
- (lambda* (k thunk handler #:optional pre-unwind-handler)
- "Invoke @var{thunk} in the dynamic context of @var{handler} for
-exceptions matching @var{key}. If thunk throws to the symbol
-@var{key}, then @var{handler} is invoked this way:
+;; These are are the procedural wrappers around the primitives of
+;; Guile's language: apply, call-with-current-continuation, etc.
+;;
+;; Usually, a call to a primitive is compiled specially. The compiler
+;; knows about all these kinds of expressions. But the primitives may
+;; be referenced not only as operators, but as values as well. These
+;; stub procedures are the "values" of apply, dynamic-wind, and other
+;; such primitives.
+;;
+(define apply
+ (case-lambda
+ ((fun args)
+ ((@@ primitive apply) fun args))
+ ((fun arg1 . args)
+ (letrec ((append* (lambda (tail)
+ (let ((tail (car tail))
+ (tail* (cdr tail)))
+ (if (null? tail*)
+ tail
+ (cons tail (append* tail*)))))))
+ (apply fun (cons arg1 (append* args)))))))
+(define (call-with-current-continuation proc)
+ ((@@ primitive call-with-current-continuation) proc))
+(define (call-with-values producer consumer)
+ ((@@ primitive call-with-values) producer consumer))
+(define (dynamic-wind in thunk out)
+ "All three arguments must be 0-argument procedures.
+Guard @var{in} is called, then @var{thunk}, then
+guard @var{out}.
+
+If, any time during the execution of @var{thunk}, the
+continuation of the @code{dynamic_wind} expression is escaped
+non-locally, @var{out} is called. If the continuation of
+the dynamic-wind is re-entered, @var{in} is called. Thus
+@var{in} and @var{out} may be called any number of
+times.
@lisp
- (handler key args ...)
-@end lisp
-
-@var{key} is a symbol or @code{#t}.
-
-@var{thunk} takes no arguments. If @var{thunk} returns
-normally, that is the return value of @code{catch}.
-
-Handler is invoked outside the scope of its own @code{catch}.
-If @var{handler} again throws to the same key, a new handler
-from further up the call chain is invoked.
-
-If the key is @code{#t}, then a throw to @emph{any} symbol will
-match this call to @code{catch}.
-
-If a @var{pre-unwind-handler} is given and @var{thunk} throws
-an exception that matches @var{key}, Guile calls the
-@var{pre-unwind-handler} before unwinding the dynamic state and
-invoking the main @var{handler}. @var{pre-unwind-handler} should
-be a procedure with the same signature as @var{handler}, that
-is @code{(lambda (key . args))}. It is typically used to save
-the stack at the point where the exception occurred, but can also
-query other parts of the dynamic state at that point, such as
-fluid values.
+ (define x 'normal-binding)
+@result{} x
+ (define a-cont
+ (call-with-current-continuation
+ (lambda (escape)
+ (let ((old-x x))
+ (dynamic-wind
+ ;; in-guard:
+ ;;
+ (lambda () (set! x 'special-binding))
+
+ ;; thunk
+ ;;
+ (lambda () (display x) (newline)
+ (call-with-current-continuation escape)
+ (display x) (newline)
+ x)
+
+ ;; out-guard:
+ ;;
+ (lambda () (set! x old-x)))))))
+
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont
+x
+@result{} normal-binding
+ (a-cont #f)
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont ;; the value of the (define a-cont...)
+x
+@result{} normal-binding
+a-cont
+@result{} special-binding
+@end lisp"
+ ;; FIXME: Here we don't check that the out procedure is a thunk before
+ ;; calling the in-guard, as dynamic-wind is called as part of loading
+ ;; modules, but thunk? requires loading (system vm debug). This is in
+ ;; contrast to the open-coded version of dynamic-wind, which does
+ ;; currently insert an eager thunk? check (but often optimizes it
+ ;; out). Not sure what the right thing to do is here -- make thunk?
+ ;; callable before modules are loaded, live with this inconsistency,
+ ;; or remove the thunk? check from the compiler? Questions,
+ ;; questions.
+ #;
+ (unless (thunk? out)
+ (scm-error 'wrong-type-arg "dynamic-wind" "Not a thunk: ~S"
+ (list out) #f))
+ (in)
+ ((@@ primitive wind) in out)
+ (call-with-values thunk
+ (lambda vals
+ ((@@ primitive unwind))
+ (out)
+ (apply values vals))))
+
+(define (with-fluid* fluid val thunk)
+ "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.
+@var{thunk} must be a procedure of no arguments."
+ ((@@ primitive push-fluid) fluid val)
+ (call-with-values thunk
+ (lambda vals
+ ((@@ primitive pop-fluid))
+ (apply values vals))))
-A @var{pre-unwind-handler} can exit either normally or non-locally.
-If it exits normally, Guile unwinds the stack and dynamic context
-and then calls the normal (third argument) handler. If it exits
-non-locally, that exit determines the continuation."
- (if (not (or (symbol? k) (eqv? k #t)))
- (scm-error 'wrong-type-arg "catch"
- "Wrong type argument in position ~a: ~a"
- (list 1 k) (list k)))
- (let ((tag (make-prompt-tag "catch")))
- (call-with-prompt
- tag
- (lambda ()
- (with-fluids
- ((%exception-handler
- (if pre-unwind-handler
- (custom-throw-handler tag k pre-unwind-handler)
- (default-throw-handler tag k))))
- (thunk)))
- (lambda (cont k . args)
- (apply handler k args))))))
-
- (set! with-throw-handler
- (lambda (k thunk pre-unwind-handler)
- "Add @var{handler} to the dynamic context as a throw handler
-for key @var{k}, then invoke @var{thunk}."
- (if (not (or (symbol? k) (eqv? k #t)))
- (scm-error 'wrong-type-arg "with-throw-handler"
- "Wrong type argument in position ~a: ~a"
- (list 1 k) (list k)))
- (with-fluids ((%exception-handler
- (custom-throw-handler #f k pre-unwind-handler)))
- (thunk))))
-
- (set! throw
- (lambda (key . args)
- "Invoke the catch form matching @var{key}, passing @var{args} to the
-@var{handler}.
+\f
-@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
+;;; {Low-Level Port Code}
+;;;
-If there is no handler at all, Guile prints an error and then exits."
- (if (not (symbol? key))
- ((fluid-ref %exception-handler) 'wrong-type-arg "throw"
- "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
- (apply (fluid-ref %exception-handler) key args)))))
+;; These are used to request the proper mode to open files in.
+;;
+(define OPEN_READ "r")
+(define OPEN_WRITE "w")
+(define OPEN_BOTH "r+")
+(define *null-device* "/dev/null")
-\f
+;; NOTE: Later in this file, this is redefined to support keywords
+(define (open-input-file str)
+ "Takes a string naming an existing file and returns an input port
+capable of delivering characters from the file. If the file
+cannot be opened, an error is signalled."
+ (open-file str OPEN_READ))
-;;; {R4RS compliance}
-;;;
+;; NOTE: Later in this file, this is redefined to support keywords
+(define (open-output-file str)
+ "Takes a string naming an output file to be created and returns an
+output port capable of writing characters to a new file by that
+name. If the file cannot be opened, an error is signalled. If a
+file with the given name already exists, the effect is unspecified."
+ (open-file str OPEN_WRITE))
-(primitive-load-path "ice-9/r4rs")
+(define (open-io-file str)
+ "Open file with name STR for both input and output."
+ (open-file str OPEN_BOTH))
\f
(define pk peek)
-;; Temporary definition; replaced later.
-(define current-warning-port current-error-port)
-
(define (warn . stuff)
- (with-output-to-port (current-warning-port)
- (lambda ()
- (newline)
- (display ";;; WARNING ")
- (display stuff)
- (newline)
- (car (last-pair stuff)))))
+ (newline (current-warning-port))
+ (display ";;; WARNING " (current-warning-port))
+ (display stuff (current-warning-port))
+ (newline (current-warning-port))
+ (car (last-pair stuff)))
\f
\f
-;;; Boot versions of `map' and `for-each', enough to get the expander
-;;; running.
+;;; {map and for-each}
;;;
+
(define map
(case-lambda
((f l)
+ (if (not (list? l))
+ (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+ (list l) #f))
(let map1 ((l l))
- (if (null? l)
- '()
- (cons (f (car l)) (map1 (cdr l))))))
+ (if (pair? l)
+ (cons (f (car l)) (map1 (cdr l)))
+ '())))
+
((f l1 l2)
+ (if (not (= (length l1) (length l2)))
+ (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+ (list l2) #f))
+
(let map2 ((l1 l1) (l2 l2))
- (if (null? l1)
- '()
+ (if (pair? l1)
(cons (f (car l1) (car l2))
- (map2 (cdr l1) (cdr l2))))))
+ (map2 (cdr l1) (cdr l2)))
+ '())))
+
((f l1 . rest)
- (let lp ((l1 l1) (rest rest))
- (if (null? l1)
- '()
+ (let ((len (length l1)))
+ (let mapn ((rest rest))
+ (or (null? rest)
+ (if (= (length (car rest)) len)
+ (mapn (cdr rest))
+ (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+ (list (car rest)) #f)))))
+ (let mapn ((l1 l1) (rest rest))
+ (if (pair? l1)
(cons (apply f (car l1) (map car rest))
- (lp (cdr l1) (map cdr rest))))))))
+ (mapn (cdr l1) (map cdr rest)))
+ '())))))
+
+(define map-in-order map)
(define for-each
(case-lambda
((f l)
+ (if (not (list? l))
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
(let for-each1 ((l l))
- (if (pair? l)
+ (if (not (null? l))
(begin
(f (car l))
(for-each1 (cdr l))))))
+
((f l1 l2)
+ (if (not (= (length l1) (length l2)))
+ (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+ (list l2) #f))
(let for-each2 ((l1 l1) (l2 l2))
- (if (pair? l1)
+ (if (not (null? l1))
(begin
(f (car l1) (car l2))
(for-each2 (cdr l1) (cdr l2))))))
+
((f l1 . rest)
- (let lp ((l1 l1) (rest rest))
+ (let ((len (length l1)))
+ (let for-eachn ((rest rest))
+ (or (null? rest)
+ (if (= (length (car rest)) len)
+ (for-eachn (cdr rest))
+ (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+ (list (car rest)) #f)))))
+
+ (let for-eachn ((l1 l1) (rest rest))
(if (pair? l1)
(begin
(apply f (car l1) (map car rest))
- (lp (cdr l1) (map cdr rest))))))))
+ (for-eachn (cdr l1) (map cdr rest))))))))
+
;; Temporary definition used in the include-from-path expansion;
;; replaced later.
((do "step" x y)
y)))
-;; XXX FIXME: When 'call-with-values' is fixed to no longer do automatic
-;; truncation of values (in 2.2 ?), then this hack can be removed.
-(define (%define-values-arity-error)
- (throw 'wrong-number-of-args
- #f
- "define-values: wrong number of return values returned by expression"
- '()
- #f))
-
(define-syntax define-values
(lambda (orig-form)
(syntax-case orig-form ()
(with-syntax (((dummy) (generate-temporaries '(dummy))))
#`(define dummy
(call-with-values (lambda () expr)
- (case-lambda
- (() #f)
- (_ (%define-values-arity-error)))))))
+ (lambda () #f)))))
((_ (var) expr)
(identifier? #'var)
#`(define var
(call-with-values (lambda () expr)
- (case-lambda
- ((v) v)
- (_ (%define-values-arity-error))))))
+ (lambda (v) v))))
((_ (var0 ... varn) expr)
(and-map identifier? #'(var0 ... varn))
;; XXX Work around the lack of hygienic toplevel identifiers
;; Avoid mutating the user-visible variables
(define dummy
(call-with-values (lambda () expr)
- (case-lambda
- ((var0 ... varn)
- (list var0 ... varn))
- (_ (%define-values-arity-error)))))
+ (lambda (var0 ... varn)
+ (list var0 ... varn))))
(define var0
(let ((v (car dummy)))
(set! dummy (cdr dummy))
;; Avoid mutating the user-visible variables
(define dummy
(call-with-values (lambda () expr)
- (case-lambda
- ((var0 ... . varn)
- (list var0 ... varn))
- (_ (%define-values-arity-error)))))
+ (lambda (var0 ... . varn)
+ (list var0 ... varn))))
(define var0
(let ((v (car dummy)))
(set! dummy (cdr dummy))
(define-syntax-rule (delay exp)
(make-promise (lambda () exp)))
+(define-syntax with-fluids
+ (lambda (stx)
+ (define (emit-with-fluids bindings body)
+ (syntax-case bindings ()
+ (()
+ body)
+ (((f v) . bindings)
+ #`(with-fluid* f v
+ (lambda ()
+ #,(emit-with-fluids #'bindings body))))))
+ (syntax-case stx ()
+ ((_ ((fluid val) ...) exp exp* ...)
+ (with-syntax (((fluid-tmp ...) (generate-temporaries #'(fluid ...)))
+ ((val-tmp ...) (generate-temporaries #'(val ...))))
+ #`(let ((fluid-tmp fluid) ...)
+ (let ((val-tmp val) ...)
+ #,(emit-with-fluids #'((fluid-tmp val-tmp) ...)
+ #'(begin exp exp* ...)))))))))
+
(define-syntax current-source-location
(lambda (x)
(syntax-case x ()
(define sym
(if (module-locally-bound? (current-module) 'sym) sym val)))
-;;; The real versions of `map' and `for-each', with cycle detection, and
-;;; that use reverse! instead of recursion in the case of `map'.
+
+\f
+
+;;; {Error handling}
;;;
-(define map
- (case-lambda
- ((f l)
- (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
- (if (pair? hare)
- (if move?
- (if (eq? tortoise hare)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l) #f)
- (map1 (cdr hare) (cdr tortoise) #f
- (cons (f (car hare)) out)))
- (map1 (cdr hare) tortoise #t
- (cons (f (car hare)) out)))
- (if (null? hare)
- (reverse! out)
- (scm-error 'wrong-type-arg "map" "Not a list: ~S"
- (list l) #f)))))
-
- ((f l1 l2)
- (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
- (cond
- ((pair? h1)
- (cond
- ((not (pair? h2))
- (scm-error 'wrong-type-arg "map"
- (if (list? h2)
- "List of wrong length: ~S"
- "Not a list: ~S")
- (list l2) #f))
- ((not move?)
- (map2 (cdr h1) (cdr h2) t1 t2 #t
- (cons (f (car h1) (car h2)) out)))
- ((eq? t1 h1)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l1) #f))
- ((eq? t2 h2)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l2) #f))
- (else
- (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
- (cons (f (car h1) (car h2)) out)))))
-
- ((and (null? h1) (null? h2))
- (reverse! out))
-
- ((null? h1)
- (scm-error 'wrong-type-arg "map"
- (if (list? h2)
- "List of wrong length: ~S"
- "Not a list: ~S")
- (list l2) #f))
- (else
- (scm-error 'wrong-type-arg "map"
- "Not a list: ~S"
- (list l1) #f)))))
- ((f l1 . rest)
- (let ((len (length l1)))
- (let mapn ((rest rest))
- (or (null? rest)
- (if (= (length (car rest)) len)
- (mapn (cdr rest))
- (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
- (list (car rest)) #f)))))
- (let mapn ((l1 l1) (rest rest) (out '()))
- (if (null? l1)
- (reverse! out)
- (mapn (cdr l1) (map cdr rest)
- (cons (apply f (car l1) (map car rest)) out)))))))
+;; Define delimited continuation operators, and implement catch and throw in
+;; terms of them.
-(define map-in-order map)
+(define make-prompt-tag
+ (lambda* (#:optional (stem "prompt"))
+ ;; The only property that prompt tags need have is uniqueness in the
+ ;; sense of eq?. A one-element list will serve nicely.
+ (list stem)))
-(define for-each
- (case-lambda
- ((f l)
- (let for-each1 ((hare l) (tortoise l))
- (if (pair? hare)
- (begin
- (f (car hare))
- (let ((hare (cdr hare)))
- (if (pair? hare)
- (begin
- (when (eq? tortoise hare)
- (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
- (list l) #f))
- (f (car hare))
- (for-each1 (cdr hare) (cdr tortoise))))))
- (if (not (null? hare))
- (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
- (list l) #f)))))
+(define default-prompt-tag
+ ;; Redefined later to be a parameter.
+ (let ((%default-prompt-tag (make-prompt-tag)))
+ (lambda ()
+ %default-prompt-tag)))
- ((f l1 l2)
- (let for-each2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f))
- (cond
- ((and (pair? h1) (pair? h2))
- (cond
- ((not move?)
- (f (car h1) (car h2))
- (for-each2 (cdr h1) (cdr h2) t1 t2 #t))
- ((eq? t1 h1)
- (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
- (list l1) #f))
- ((eq? t2 h2)
- (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
- (list l2) #f))
- (else
- (f (car h1) (car h2))
- (for-each2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f))))
-
- ((if (null? h1)
- (or (null? h2) (pair? h2))
- (and (pair? h1) (null? h2)))
- (if #f #f))
-
- ((list? h1)
- (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
- (list h2) #f))
- (else
- (scm-error 'wrong-type-arg "for-each" "Unexpected tail: ~S"
- (list h1) #f)))))
+(define (call-with-prompt tag thunk handler)
+ ((@@ primitive call-with-prompt) tag thunk handler))
+(define (abort-to-prompt tag . args)
+ (abort-to-prompt* tag args))
- ((f l1 . rest)
- (let ((len (length l1)))
- (let for-eachn ((rest rest))
- (or (null? rest)
- (if (= (length (car rest)) len)
- (for-eachn (cdr rest))
- (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
- (list (car rest)) #f)))))
-
- (let for-eachn ((l1 l1) (rest rest))
- (if (pair? l1)
- (begin
- (apply f (car l1) (map car rest))
- (for-eachn (cdr l1) (map cdr rest))))))))
+;; Define catch and with-throw-handler, using some common helper routines and a
+;; shared fluid. Hide the helpers in a lexical contour.
+
+(define with-throw-handler #f)
+(let ((%eh (module-ref (current-module) '%exception-handler)))
+ (define (make-exception-handler catch-key prompt-tag pre-unwind)
+ (vector (fluid-ref %eh) catch-key prompt-tag pre-unwind))
+ (define (exception-handler-prev handler) (vector-ref handler 0))
+ (define (exception-handler-catch-key handler) (vector-ref handler 1))
+ (define (exception-handler-prompt-tag handler) (vector-ref handler 2))
+ (define (exception-handler-pre-unwind handler) (vector-ref handler 3))
+
+ (define %running-pre-unwind (make-fluid '()))
+
+ (define (dispatch-exception handler key args)
+ (unless handler
+ (when (eq? key 'quit)
+ (primitive-exit (cond
+ ((not (pair? args)) 0)
+ ((integer? (car args)) (car args))
+ ((not (car args)) 1)
+ (else 0))))
+ (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" key args)
+ (primitive-exit 1))
+
+ (let ((catch-key (exception-handler-catch-key handler))
+ (prev (exception-handler-prev handler)))
+ (if (or (eqv? catch-key #t) (eq? catch-key key))
+ (let ((prompt-tag (exception-handler-prompt-tag handler))
+ (pre-unwind (exception-handler-pre-unwind handler)))
+ (if pre-unwind
+ ;; Instead of using a "running" set, it would be a lot
+ ;; cleaner semantically to roll back the exception
+ ;; handler binding to the one that was in place when the
+ ;; pre-unwind handler was installed, and keep it like
+ ;; that for the rest of the dispatch. Unfortunately
+ ;; that is incompatible with existing semantics. We'll
+ ;; see if we can change that later on.
+ (let ((running (fluid-ref %running-pre-unwind)))
+ (with-fluid* %running-pre-unwind (cons handler running)
+ (lambda ()
+ (unless (memq handler running)
+ (apply pre-unwind key args))
+ (if prompt-tag
+ (apply abort-to-prompt prompt-tag key args)
+ (dispatch-exception prev key args)))))
+ (apply abort-to-prompt prompt-tag key args)))
+ (dispatch-exception prev key args))))
+
+ (define (throw key . args)
+ "Invoke the catch form matching @var{key}, passing @var{args} to the
+@var{handler}.
+
+@var{key} is a symbol. It will match catches of the same symbol or of @code{#t}.
+
+If there is no handler at all, Guile prints an error and then exits."
+ (unless (symbol? key)
+ (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
+ (list 1 key) (list key)))
+ (dispatch-exception (fluid-ref %eh) key args))
+
+ (define* (catch k thunk handler #:optional pre-unwind-handler)
+ "Invoke @var{thunk} in the dynamic context of @var{handler} for
+exceptions matching @var{key}. If thunk throws to the symbol
+@var{key}, then @var{handler} is invoked this way:
+@lisp
+ (handler key args ...)
+@end lisp
+
+@var{key} is a symbol or @code{#t}.
+
+@var{thunk} takes no arguments. If @var{thunk} returns
+normally, that is the return value of @code{catch}.
+
+Handler is invoked outside the scope of its own @code{catch}.
+If @var{handler} again throws to the same key, a new handler
+from further up the call chain is invoked.
+
+If the key is @code{#t}, then a throw to @emph{any} symbol will
+match this call to @code{catch}.
+
+If a @var{pre-unwind-handler} is given and @var{thunk} throws
+an exception that matches @var{key}, Guile calls the
+@var{pre-unwind-handler} before unwinding the dynamic state and
+invoking the main @var{handler}. @var{pre-unwind-handler} should
+be a procedure with the same signature as @var{handler}, that
+is @code{(lambda (key . args))}. It is typically used to save
+the stack at the point where the exception occurred, but can also
+query other parts of the dynamic state at that point, such as
+fluid values.
+
+A @var{pre-unwind-handler} can exit either normally or non-locally.
+If it exits normally, Guile unwinds the stack and dynamic context
+and then calls the normal (third argument) handler. If it exits
+non-locally, that exit determines the continuation."
+ (define (wrong-type-arg n val)
+ (scm-error 'wrong-type-arg "catch"
+ "Wrong type argument in position ~a: ~a"
+ (list n val) (list val)))
+ (unless (or (symbol? k) (eqv? k #t))
+ (wrong-type-arg 1 k))
+ (unless (procedure? handler)
+ (wrong-type-arg 3 handler))
+ (unless (or (not pre-unwind-handler) (procedure? pre-unwind-handler))
+ (wrong-type-arg 4 pre-unwind-handler))
+ (let ((tag (make-prompt-tag "catch")))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (with-fluid* %eh (make-exception-handler k tag pre-unwind-handler)
+ thunk))
+ (lambda (cont k . args)
+ (apply handler k args)))))
+
+ (define (with-throw-handler k thunk pre-unwind-handler)
+ "Add @var{handler} to the dynamic context as a throw handler
+for key @var{k}, then invoke @var{thunk}."
+ (if (not (or (symbol? k) (eqv? k #t)))
+ (scm-error 'wrong-type-arg "with-throw-handler"
+ "Wrong type argument in position ~a: ~a"
+ (list 1 k) (list k)))
+ (with-fluid* %eh (make-exception-handler k #f pre-unwind-handler)
+ thunk))
+
+ (hashq-remove! (%get-pre-modules-obarray) '%exception-handler)
+ (define! 'catch catch)
+ (define! 'with-throw-handler with-throw-handler)
+ (define! 'throw throw))
\f
;;;
-;;; Enhanced file opening procedures
+;;; Extensible exception printing.
;;;
-(define* (open-input-file
- file #:key (binary #f) (encoding #f) (guess-encoding #f))
- "Takes a string naming an existing file and returns an input port
-capable of delivering characters from the file. If the file
-cannot be opened, an error is signalled."
- (open-file file (if binary "rb" "r")
- #:encoding encoding
- #:guess-encoding guess-encoding))
+(define set-exception-printer! #f)
+;; There is already a definition of print-exception from backtrace.c
+;; that we will override.
-(define* (open-output-file file #:key (binary #f) (encoding #f))
- "Takes a string naming an output file to be created and returns an
-output port capable of writing characters to a new file by that
-name. If the file cannot be opened, an error is signalled. If a
-file with the given name already exists, the effect is unspecified."
- (open-file file (if binary "wb" "w")
- #:encoding encoding))
-
-(define* (call-with-input-file
- file proc #:key (binary #f) (encoding #f) (guess-encoding #f))
- "PROC should be a procedure of one argument, and FILE should be a
-string naming a file. The file must
-already exist. These procedures call PROC
-with one argument: the port obtained by opening the named file for
-input or output. If the file cannot be opened, an error is
-signalled. If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned.
-If the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will
-never again be used for a read or write operation."
- (let ((p (open-input-file file
- #:binary binary
- #:encoding encoding
- #:guess-encoding guess-encoding)))
- (call-with-values
- (lambda () (proc p))
- (lambda vals
- (close-input-port p)
- (apply values vals)))))
-
-(define* (call-with-output-file file proc #:key (binary #f) (encoding #f))
- "PROC should be a procedure of one argument, and FILE should be a
-string naming a file. The behaviour is unspecified if the file
-already exists. These procedures call PROC
-with one argument: the port obtained by opening the named file for
-input or output. If the file cannot be opened, an error is
-signalled. If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned.
-If the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will
-never again be used for a read or write operation."
- (let ((p (open-output-file file #:binary binary #:encoding encoding)))
- (call-with-values
- (lambda () (proc p))
- (lambda vals
- (close-output-port p)
- (apply values vals)))))
-
-(define* (with-input-from-file
- file thunk #:key (binary #f) (encoding #f) (guess-encoding #f))
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The file must already exist. The file is opened for
-input, an input port connected to it is made
-the default value returned by `current-input-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-input-file file
- (lambda (p) (with-input-from-port p thunk))
- #:binary binary
- #:encoding encoding
- #:guess-encoding guess-encoding))
-
-(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
-The file is opened for output, an output port connected to it is made
-the default value returned by `current-output-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-output-file file
- (lambda (p) (with-output-to-port p thunk))
- #:binary binary
- #:encoding encoding))
-
-(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
-The file is opened for output, an output port connected to it is made
-the default value returned by `current-error-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-output-file file
- (lambda (p) (with-error-to-port p thunk))
- #:binary binary
- #:encoding encoding))
-
-\f
-
-;;;
-;;; Extensible exception printing.
-;;;
-
-(define set-exception-printer! #f)
-;; There is already a definition of print-exception from backtrace.c
-;; that we will override.
-
-(let ((exception-printers '()))
- (define (print-location frame port)
- (let ((source (and=> frame frame-source)))
- ;; source := (addr . (filename . (line . column)))
- (if source
- (let ((filename (or (cadr source) "<unnamed port>"))
- (line (caddr source))
- (col (cdddr source)))
- (format port "~a:~a:~a: " filename (1+ line) col))
- (format port "ERROR: "))))
+(let ((exception-printers '()))
+ (define (print-location frame port)
+ (let ((source (and=> frame frame-source)))
+ ;; source := (addr . (filename . (line . column)))
+ (if source
+ (let ((filename (or (cadr source) "<unnamed port>"))
+ (line (caddr source))
+ (col (cdddr source)))
+ (format port "~a:~a:~a: " filename (1+ line) col))
+ (format port "ERROR: "))))
(set! set-exception-printer!
(lambda (key proc)
(set-exception-printer! 'no-data scm-error-printer)
(set-exception-printer! 'no-recovery scm-error-printer)
(set-exception-printer! 'null-pointer-error scm-error-printer)
+ (set-exception-printer! 'out-of-memory scm-error-printer)
(set-exception-printer! 'out-of-range scm-error-printer)
(set-exception-printer! 'program-error scm-error-printer)
(set-exception-printer! 'read-error scm-error-printer)
;; properties within the object itself.
(define (make-object-property)
- (define-syntax-rule (with-mutex lock exp)
- (dynamic-wind (lambda () (lock-mutex lock))
- (lambda () exp)
- (lambda () (unlock-mutex lock))))
- (let ((prop (make-weak-key-hash-table))
- (lock (make-mutex)))
+ ;; Weak tables are thread-safe.
+ (let ((prop (make-weak-key-hash-table)))
(make-procedure-with-setter
- (lambda (obj) (with-mutex lock (hashq-ref prop obj)))
- (lambda (obj val) (with-mutex lock (hashq-set! prop obj val))))))
+ (lambda (obj) (hashq-ref prop obj))
+ (lambda (obj val) (hashq-set! prop obj val)))))
\f
\f
+;;; {IOTA functions: generating lists of numbers}
+;;;
+
+(define (iota n)
+ (let loop ((count (1- n)) (result '()))
+ (if (< count 0) result
+ (loop (1- count) (cons count result)))))
+
+\f
+
;;; {Structs}
;;;
#,@(let lp ((n 0))
(if (< n *max-static-argument-count*)
(cons (with-syntax (((formal ...) (make-formals n))
+ ((idx ...) (iota n))
(n n))
#'((n)
(lambda (formal ...)
- (make-struct rtd 0 formal ...))))
+ (let ((s (allocate-struct rtd n)))
+ (struct-set! s idx formal)
+ ...
+ s))))
(lp (1+ n)))
'()))
(else
(string->symbol type-name)))
rtd))
-(define (record-type-name obj)
- (if (record-type? obj)
- (struct-ref obj vtable-offset-user)
- (error 'not-a-record-type obj)))
+(define (record-type-name obj)
+ (if (record-type? obj)
+ (struct-ref obj vtable-offset-user)
+ (error 'not-a-record-type obj)))
+
+(define (record-type-fields obj)
+ (if (record-type? obj)
+ (struct-ref obj (+ 1 vtable-offset-user))
+ (error 'not-a-record-type obj)))
+
+(define* (record-constructor rtd #:optional field-names)
+ (if (not field-names)
+ (struct-ref rtd (+ 2 vtable-offset-user))
+ (primitive-eval
+ `(lambda ,field-names
+ (make-struct ',rtd 0 ,@(map (lambda (f)
+ (if (memq f field-names)
+ f
+ #f))
+ (record-type-fields rtd)))))))
+
+(define (record-predicate rtd)
+ (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
+
+(define (%record-type-error rtd obj) ;; private helper
+ (or (eq? rtd (record-type-descriptor obj))
+ (scm-error 'wrong-type-arg "%record-type-check"
+ "Wrong type record (want `~S'): ~S"
+ (list (record-type-name rtd) obj)
+ #f)))
+
+(define (record-accessor rtd field-name)
+ (let ((pos (list-index (record-type-fields rtd) field-name)))
+ (if (not pos)
+ (error 'no-such-field field-name))
+ (lambda (obj)
+ (if (eq? (struct-vtable obj) rtd)
+ (struct-ref obj pos)
+ (%record-type-error rtd obj)))))
+
+(define (record-modifier rtd field-name)
+ (let ((pos (list-index (record-type-fields rtd) field-name)))
+ (if (not pos)
+ (error 'no-such-field field-name))
+ (lambda (obj val)
+ (if (eq? (struct-vtable obj) rtd)
+ (struct-set! obj pos val)
+ (%record-type-error rtd obj)))))
+
+(define (record? obj)
+ (and (struct? obj) (record-type? (struct-vtable obj))))
+
+(define (record-type-descriptor obj)
+ (if (struct? obj)
+ (struct-vtable obj)
+ (error 'not-a-record obj)))
+
+(provide 'record)
+
+
+\f
+;;; {Parameters}
+;;;
+
+(define <parameter>
+ ;; Three fields: the procedure itself, the fluid, and the converter.
+ (make-struct <applicable-struct-vtable> 0 'pwprpr))
+(set-struct-vtable-name! <parameter> '<parameter>)
+
+(define* (make-parameter init #:optional (conv (lambda (x) x)))
+ "Make a new parameter.
+
+A parameter is a dynamically bound value, accessed through a procedure.
+To access the current value, apply the procedure with no arguments:
+
+ (define p (make-parameter 10))
+ (p) => 10
+
+To provide a new value for the parameter in a dynamic extent, use
+`parameterize':
+
+ (parameterize ((p 20))
+ (p)) => 20
+ (p) => 10
+
+The value outside of the dynamic extent of the body is unaffected. To
+update the current value, apply it to one argument:
+
+ (p 20) => 10
+ (p) => 20
+
+As you can see, the call that updates a parameter returns its previous
+value.
+
+All values for the parameter are first run through the CONV procedure,
+including INIT, the initial value. The default CONV procedure is the
+identity procedure. CONV is commonly used to ensure some set of
+invariants on the values that a parameter may have."
+ (let ((fluid (make-fluid (conv init))))
+ (make-struct <parameter> 0
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((x) (let ((prev (fluid-ref fluid)))
+ (fluid-set! fluid (conv x))
+ prev)))
+ fluid conv)))
+
+(define (parameter? x)
+ (and (struct? x) (eq? (struct-vtable x) <parameter>)))
+
+(define (parameter-fluid p)
+ (if (parameter? p)
+ (struct-ref p 1)
+ (scm-error 'wrong-type-arg "parameter-fluid"
+ "Not a parameter: ~S" (list p) #f)))
+
+(define (parameter-converter p)
+ (if (parameter? p)
+ (struct-ref p 2)
+ (scm-error 'wrong-type-arg "parameter-fluid"
+ "Not a parameter: ~S" (list p) #f)))
+
+(define-syntax parameterize
+ (lambda (x)
+ (syntax-case x ()
+ ((_ ((param value) ...) body body* ...)
+ (with-syntax (((p ...) (generate-temporaries #'(param ...))))
+ #'(let ((p param) ...)
+ (if (not (parameter? p))
+ (scm-error 'wrong-type-arg "parameterize"
+ "Not a parameter: ~S" (list p) #f))
+ ...
+ (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
+ ...)
+ body body* ...)))))))
+
+(define* (fluid->parameter fluid #:optional (conv (lambda (x) x)))
+ "Make a parameter that wraps a fluid.
+
+The value of the parameter will be the same as the value of the fluid.
+If the parameter is rebound in some dynamic extent, perhaps via
+`parameterize', the new value will be run through the optional CONV
+procedure, as with any parameter. Note that unlike `make-parameter',
+CONV is not applied to the initial value."
+ (make-struct <parameter> 0
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((x) (let ((prev (fluid-ref fluid)))
+ (fluid-set! fluid (conv x))
+ prev)))
+ fluid conv))
+
+\f
+
+;;; Once parameters have booted, define the default prompt tag as being
+;;; a parameter.
+;;;
+
+(set! default-prompt-tag (make-parameter (default-prompt-tag)))
+
+\f
+
+;;; Current ports as parameters.
+;;;
+
+(let ()
+ (define-syntax-rule (port-parameterize! binding fluid predicate msg)
+ (begin
+ (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
+ (lambda (x)
+ (if (predicate x) x
+ (error msg x)))))
+ (hashq-remove! (%get-pre-modules-obarray) 'fluid)))
+
+ (port-parameterize! current-input-port %current-input-port-fluid
+ input-port? "expected an input port")
+ (port-parameterize! current-output-port %current-output-port-fluid
+ output-port? "expected an output port")
+ (port-parameterize! current-error-port %current-error-port-fluid
+ output-port? "expected an output port")
+ (port-parameterize! current-warning-port %current-warning-port-fluid
+ output-port? "expected an output port"))
+
+\f
+
+;;; {Languages}
+;;;
+
+;; The language can be a symbolic name or a <language> object from
+;; (system base language).
+;;
+(define current-language (make-parameter 'scheme))
+
+
+\f
+
+;;; {High-Level Port Routines}
+;;;
+
+(define* (open-input-file
+ file #:key (binary #f) (encoding #f) (guess-encoding #f))
+ "Takes a string naming an existing file and returns an input port
+capable of delivering characters from the file. If the file
+cannot be opened, an error is signalled."
+ (open-file file (if binary "rb" "r")
+ #:encoding encoding
+ #:guess-encoding guess-encoding))
+
+(define* (open-output-file file #:key (binary #f) (encoding #f))
+ "Takes a string naming an output file to be created and returns an
+output port capable of writing characters to a new file by that
+name. If the file cannot be opened, an error is signalled. If a
+file with the given name already exists, the effect is unspecified."
+ (open-file file (if binary "wb" "w")
+ #:encoding encoding))
+
+(define* (call-with-input-file
+ file proc #:key (binary #f) (encoding #f) (guess-encoding #f))
+ "PROC should be a procedure of one argument, and FILE should be a
+string naming a file. The file must
+already exist. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output. If the file cannot be opened, an error is
+signalled. If the procedure returns, then the port is closed
+automatically and the values yielded by the procedure are returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+ (let ((p (open-input-file file
+ #:binary binary
+ #:encoding encoding
+ #:guess-encoding guess-encoding)))
+ (call-with-values
+ (lambda () (proc p))
+ (lambda vals
+ (close-input-port p)
+ (apply values vals)))))
+
+(define* (call-with-output-file file proc #:key (binary #f) (encoding #f))
+ "PROC should be a procedure of one argument, and FILE should be a
+string naming a file. The behaviour is unspecified if the file
+already exists. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output. If the file cannot be opened, an error is
+signalled. If the procedure returns, then the port is closed
+automatically and the values yielded by the procedure are returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+ (let ((p (open-output-file file #:binary binary #:encoding encoding)))
+ (call-with-values
+ (lambda () (proc p))
+ (lambda vals
+ (close-output-port p)
+ (apply values vals)))))
+
+(define (with-input-from-port port thunk)
+ (parameterize ((current-input-port port))
+ (thunk)))
-(define (record-type-fields obj)
- (if (record-type? obj)
- (struct-ref obj (+ 1 vtable-offset-user))
- (error 'not-a-record-type obj)))
+(define (with-output-to-port port thunk)
+ (parameterize ((current-output-port port))
+ (thunk)))
-(define* (record-constructor rtd #:optional field-names)
- (if (not field-names)
- (struct-ref rtd (+ 2 vtable-offset-user))
- (primitive-eval
- `(lambda ,field-names
- (make-struct ',rtd 0 ,@(map (lambda (f)
- (if (memq f field-names)
- f
- #f))
- (record-type-fields rtd)))))))
-
-(define (record-predicate rtd)
- (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
+(define (with-error-to-port port thunk)
+ (parameterize ((current-error-port port))
+ (thunk)))
-(define (%record-type-error rtd obj) ;; private helper
- (or (eq? rtd (record-type-descriptor obj))
- (scm-error 'wrong-type-arg "%record-type-check"
- "Wrong type record (want `~S'): ~S"
- (list (record-type-name rtd) obj)
- #f)))
+(define* (with-input-from-file
+ file thunk #:key (binary #f) (encoding #f) (guess-encoding #f))
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The file must already exist. The file is opened for
+input, an input port connected to it is made
+the default value returned by `current-input-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-input-file file
+ (lambda (p) (with-input-from-port p thunk))
+ #:binary binary
+ #:encoding encoding
+ #:guess-encoding guess-encoding))
-(define (record-accessor rtd field-name)
- (let ((pos (list-index (record-type-fields rtd) field-name)))
- (if (not pos)
- (error 'no-such-field field-name))
- (lambda (obj)
- (if (eq? (struct-vtable obj) rtd)
- (struct-ref obj pos)
- (%record-type-error rtd obj)))))
+(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The effect is unspecified if the file already exists.
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-output-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-output-file file
+ (lambda (p) (with-output-to-port p thunk))
+ #:binary binary
+ #:encoding encoding))
-(define (record-modifier rtd field-name)
- (let ((pos (list-index (record-type-fields rtd) field-name)))
- (if (not pos)
- (error 'no-such-field field-name))
- (lambda (obj val)
- (if (eq? (struct-vtable obj) rtd)
- (struct-set! obj pos val)
- (%record-type-error rtd obj)))))
+(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The effect is unspecified if the file already exists.
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-error-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-output-file file
+ (lambda (p) (with-error-to-port p thunk))
+ #:binary binary
+ #:encoding encoding))
-(define (record? obj)
- (and (struct? obj) (record-type? (struct-vtable obj))))
+(define (call-with-input-string string proc)
+ "Calls the one-argument procedure @var{proc} with a newly created
+input port from which @var{string}'s contents may be read. The value
+yielded by the @var{proc} is returned."
+ (proc (open-input-string string)))
-(define (record-type-descriptor obj)
- (if (struct? obj)
- (struct-vtable obj)
- (error 'not-a-record obj)))
+(define (with-input-from-string string thunk)
+ "THUNK must be a procedure of no arguments.
+The test of STRING is opened for
+input, an input port connected to it is made,
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed.
+Returns the values yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-input-string string
+ (lambda (p) (with-input-from-port p thunk))))
-(provide 'record)
+(define (call-with-output-string proc)
+ "Calls the one-argument procedure @var{proc} with a newly created output
+port. When the function returns, the string composed of the characters
+written into the port is returned."
+ (let ((port (open-output-string)))
+ (proc port)
+ (get-output-string port)))
+
+(define (with-output-to-string thunk)
+ "Calls THUNK and returns its output as a string."
+ (call-with-output-string
+ (lambda (p) (with-output-to-port p thunk))))
+
+(define (with-error-to-string thunk)
+ "Calls THUNK and returns its error output as a string."
+ (call-with-output-string
+ (lambda (p) (with-error-to-port p thunk))))
+
+(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
\f
(lambda (str)
(->bool (stat str #f)))
(lambda (str)
- (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
+ (let ((port (catch 'system-error (lambda () (open-input-file str))
(lambda args #f))))
(if port (begin (close-port port) #t)
#f)))))
(eq? (stat:type (stat str)) 'directory))
(lambda (str)
(let ((port (catch 'system-error
- (lambda () (open-file (string-append str "/.")
- OPEN_READ))
+ (lambda ()
+ (open-input-file (string-append str "/.")))
(lambda args #f))))
(if port (begin (close-port port) #t)
#f)))))
((define-record-type
(lambda (x)
(define (make-id scope . fragments)
- (datum->syntax #'scope
+ (datum->syntax scope
(apply symbol-append
(map (lambda (x)
(if (symbol? x) x (syntax->datum x)))
(cons #'f (field-list #'rest)))))
(define (constructor rtd type-name fields exp)
- (let ((ctor (make-id rtd type-name '-constructor))
- (args (field-list fields)))
+ (let* ((ctor (make-id rtd type-name '-constructor))
+ (args (field-list fields))
+ (n (length fields))
+ (slots (iota n)))
(predicate rtd type-name fields
#`(begin #,exp
(define #,ctor
(let ((rtd #,rtd))
(lambda #,args
- (make-struct rtd 0 #,@args))))
+ (let ((s (allocate-struct rtd #,n)))
+ #,@(map
+ (lambda (arg slot)
+ #`(struct-set! s #,slot #,arg))
+ args slots)
+ s))))
(struct-set! #,rtd (+ vtable-offset-user 2)
#,ctor)))))
;; initial uses list, or binding procedure.
;;
(define* (make-module #:optional (size 31) (uses '()) (binder #f))
- (define %default-import-size
- ;; Typical number of imported bindings actually used by a module.
- 600)
-
(if (not (integer? size))
(error "Illegal size to make-module." size))
(if (not (and (list? uses)
(module-constructor (make-hash-table size)
uses binder #f macroexpand
#f #f #f
- (make-hash-table %default-import-size)
+ (make-hash-table)
'()
(make-weak-key-hash-table 31) #f
(make-hash-table 7) #f #f #f))
(define (module-define-submodule! module name submodule)
(hashq-set! (module-submodules module) name submodule))
-;; It used to be, however, that module names were also present in the
-;; value namespace. When we enable deprecated code, we preserve this
-;; legacy behavior.
-;;
-;; These shims are defined here instead of in deprecated.scm because we
-;; need their definitions before loading other modules.
-;;
-(begin-deprecated
- (define (module-ref-submodule module name)
- (or (hashq-ref (module-submodules module) name)
- (and (module-submodule-binder module)
- ((module-submodule-binder module) module name))
- (let ((var (module-local-variable module name)))
- (and var (variable-bound? var) (module? (variable-ref var))
- (begin
- (warn "module" module "not in submodules table")
- (variable-ref var))))))
-
- (define (module-define-submodule! module name submodule)
- (let ((var (module-local-variable module name)))
- (if (and var
- (or (not (variable-bound? var))
- (not (module? (variable-ref var)))))
- (warn "defining module" module ": not overriding local definition" var)
- (module-define! module name submodule)))
- (hashq-set! (module-submodules module) name submodule)))
-
\f
;;; {Module-based Loading}
\f
-;;; {Parameters}
-;;;
-
-(define <parameter>
- ;; Three fields: the procedure itself, the fluid, and the converter.
- (make-struct <applicable-struct-vtable> 0 'pwprpr))
-(set-struct-vtable-name! <parameter> '<parameter>)
-
-(define* (make-parameter init #:optional (conv (lambda (x) x)))
- "Make a new parameter.
-
-A parameter is a dynamically bound value, accessed through a procedure.
-To access the current value, apply the procedure with no arguments:
-
- (define p (make-parameter 10))
- (p) => 10
-
-To provide a new value for the parameter in a dynamic extent, use
-`parameterize':
-
- (parameterize ((p 20))
- (p)) => 20
- (p) => 10
-
-The value outside of the dynamic extent of the body is unaffected. To
-update the current value, apply it to one argument:
-
- (p 20) => 10
- (p) => 20
-
-As you can see, the call that updates a parameter returns its previous
-value.
-
-All values for the parameter are first run through the CONV procedure,
-including INIT, the initial value. The default CONV procedure is the
-identity procedure. CONV is commonly used to ensure some set of
-invariants on the values that a parameter may have."
- (let ((fluid (make-fluid (conv init))))
- (make-struct <parameter> 0
- (case-lambda
- (() (fluid-ref fluid))
- ((x) (let ((prev (fluid-ref fluid)))
- (fluid-set! fluid (conv x))
- prev)))
- fluid conv)))
-
-(define* (fluid->parameter fluid #:optional (conv (lambda (x) x)))
- "Make a parameter that wraps a fluid.
-
-The value of the parameter will be the same as the value of the fluid.
-If the parameter is rebound in some dynamic extent, perhaps via
-`parameterize', the new value will be run through the optional CONV
-procedure, as with any parameter. Note that unlike `make-parameter',
-CONV is not applied to the initial value."
- (make-struct <parameter> 0
- (case-lambda
- (() (fluid-ref fluid))
- ((x) (let ((prev (fluid-ref fluid)))
- (fluid-set! fluid (conv x))
- prev)))
- fluid conv))
-
-(define (parameter? x)
- (and (struct? x) (eq? (struct-vtable x) <parameter>)))
-
-(define (parameter-fluid p)
- (if (parameter? p)
- (struct-ref p 1)
- (scm-error 'wrong-type-arg "parameter-fluid"
- "Not a parameter: ~S" (list p) #f)))
-
-(define (parameter-converter p)
- (if (parameter? p)
- (struct-ref p 2)
- (scm-error 'wrong-type-arg "parameter-fluid"
- "Not a parameter: ~S" (list p) #f)))
-
-(define-syntax parameterize
- (lambda (x)
- (syntax-case x ()
- ((_ ((param value) ...) body body* ...)
- (with-syntax (((p ...) (generate-temporaries #'(param ...))))
- #'(let ((p param) ...)
- (if (not (parameter? p))
- (scm-error 'wrong-type-arg "parameterize"
- "Not a parameter: ~S" (list p) #f))
- ...
- (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
- ...)
- body body* ...)))))))
-
-\f
-;;;
-;;; Current ports as parameters.
-;;;
-
-(let ()
- (define-syntax-rule (port-parameterize! binding fluid predicate msg)
- (begin
- (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
- (lambda (x)
- (if (predicate x) x
- (error msg x)))))
- (module-remove! (current-module) 'fluid)))
-
- (port-parameterize! current-input-port %current-input-port-fluid
- input-port? "expected an input port")
- (port-parameterize! current-output-port %current-output-port-fluid
- output-port? "expected an output port")
- (port-parameterize! current-error-port %current-error-port-fluid
- output-port? "expected an output port"))
-
-
-\f
-;;;
-;;; Warnings.
-;;;
-
-(define current-warning-port
- (make-parameter (current-error-port)
- (lambda (x)
- (if (output-port? x)
- x
- (error "expected an output port" x)))))
-
-
-\f
-;;;
-;;; Languages.
-;;;
-
-;; The language can be a symbolic name or a <language> object from
-;; (system base language).
-;;
-(define current-language (make-parameter 'scheme))
-
-
-\f
-
;;; {Running Repls}
;;;
\f
-;;; {IOTA functions: generating lists of numbers}
-;;;
-
-(define (iota n)
- (let loop ((count (1- n)) (result '()))
- (if (< count 0) result
- (loop (1- count) (cons count result)))))
-
-\f
-
;;; {While}
;;;
;;; with `continue' and `break'.
(process-use-modules (list quoted-args ...))
*unspecified*))))))
-(define-syntax-rule (use-syntax spec ...)
- (begin
- (eval-when (expand load eval)
- (issue-deprecation-warning
- "`use-syntax' is deprecated. Please contact guile-devel for more info."))
- (use-modules spec ...)))
-
(include-from-path "ice-9/r6rs-libraries")
(define-syntax-rule (define-private foo bar)
;; placing 'cond-expand-provide' in the relevant module.
'(guile
guile-2
+ guile-2.2
r5rs
srfi-0 ;; cond-expand itself
srfi-4 ;; homogeneous numeric vectors
- ;; We omit srfi-6 because the 'open-input-string' etc in Guile
- ;; core are not conformant with SRFI-6; they expose details
- ;; of the binary I/O model and may fail to support some characters.
+ srfi-6 ;; string ports
srfi-13 ;; string library
srfi-14 ;; character sets
srfi-16 ;; case-lambda
;;;
(define-module (ice-9 command-line)
- #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine! the-vm)
+ #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine!)
#:export (compile-shell-switches
version-etc
*GPLv3+*
(and interactive? (not turn-off-debugging?)))
(begin
(set-default-vm-engine! 'debug)
- (set-vm-engine! (the-vm) 'debug)))
+ (set-vm-engine! 'debug)))
;; Return this value.
`(;; It would be nice not to load up (ice-9 control), but the
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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
x)
(else x)))
-(define (squeeze-tree-il! x)
- (post-order! (lambda (x)
- (if (const? x)
- (set! (const-exp x)
- (squeeze-constant! (const-exp x))))
- #f)
- x))
+(define (squeeze-tree-il x)
+ (post-order (lambda (x)
+ (if (const? x)
+ (make-const (const-src x)
+ (squeeze-constant! (const-exp x)))
+ x))
+ x))
;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
;; changing session identifiers.
(close-port in))
(begin
(pretty-print (tree-il->scheme
- (squeeze-tree-il!
- (canonicalize!
- (resolve-primitives!
+ (squeeze-tree-il
+ (canonicalize
+ (resolve-primitives
(macroexpand x 'c '(compile load eval))
(current-module))))
(current-module)
-;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010, 2011, 2012, 2013 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 (ice-9 deprecated)
- #:export (substring-move-left! substring-move-right!
- dynamic-maybe-call dynamic-maybe-link
- try-module-linked try-module-dynamic-link
- list* feature? eval-case unmemoize-expr
- $asinh
- $acosh
- $atanh
- $sqrt
- $abs
- $exp
- $expt
- $log
- $sin
- $cos
- $tan
- $asin
- $acos
- $atan
- $sinh
- $cosh
- $tanh
- closure?
- %nil
- @bind
- bad-throw
- error-catching-loop
- error-catching-repl
- scm-style-repl
- apply-to-args
- has-suffix?
- scheme-file-suffix
- get-option
- for-next-option
- display-usage-report
- transform-usage-lambda
- collect
- assert-repl-silence
- assert-repl-print-unspecified
- assert-repl-verbosity
- set-repl-prompt!
- set-batch-mode?!
- repl
- pre-unwind-handler-dispatch
- default-pre-unwind-handler
- handle-system-error
- stack-saved?
- the-last-stack
- save-stack
- named-module-use!
- top-repl
- turn-on-debugging
- read-hash-procedures
- process-define-module
- fluid-let-syntax
- set-system-module!
- char-code-limit
- generalized-vector?
- generalized-vector-length
- generalized-vector-ref
- generalized-vector-set!
- generalized-vector->list))
-
-
-;;;; Deprecated definitions.
-
-(define substring-move-left!
- (lambda args
- (issue-deprecation-warning
- "`substring-move-left!' is deprecated. Use `substring-move!' instead.")
- (apply substring-move! args)))
-(define substring-move-right!
- (lambda args
- (issue-deprecation-warning
- "`substring-move-right!' is deprecated. Use `substring-move!' instead.")
- (apply substring-move! args)))
-
-
-\f
-;; This method of dynamically linking Guile Extensions is deprecated.
-;; Use `load-extension' explicitly from Scheme code instead.
-
-(define (split-c-module-name str)
- (let loop ((rev '())
- (start 0)
- (pos 0)
- (end (string-length str)))
- (cond
- ((= pos end)
- (reverse (cons (string->symbol (substring str start pos)) rev)))
- ((eq? (string-ref str pos) #\space)
- (loop (cons (string->symbol (substring str start pos)) rev)
- (+ pos 1)
- (+ pos 1)
- end))
- (else
- (loop rev start (+ pos 1) end)))))
-
-(define (convert-c-registered-modules dynobj)
- (let ((res (map (lambda (c)
- (list (split-c-module-name (car c)) (cdr c) dynobj))
- (c-registered-modules))))
- (c-clear-registered-modules)
- res))
-
-(define registered-modules '())
-
-(define (register-modules dynobj)
- (set! registered-modules
- (append! (convert-c-registered-modules dynobj)
- registered-modules)))
-
-(define (warn-autoload-deprecation modname)
- (issue-deprecation-warning
- "Autoloading of compiled code modules is deprecated."
- "Write a Scheme file instead that uses `load-extension'.")
- (issue-deprecation-warning
- (simple-format #f "(You just autoloaded module ~S.)" modname)))
-
-(define (init-dynamic-module modname)
- ;; Register any linked modules which have been registered on the C level
- (register-modules #f)
- (or-map (lambda (modinfo)
- (if (equal? (car modinfo) modname)
- (begin
- (warn-autoload-deprecation modname)
- (set! registered-modules (delq! modinfo registered-modules))
- (let ((mod (resolve-module modname #f)))
- (save-module-excursion
- (lambda ()
- (set-current-module mod)
- (set-module-public-interface! mod mod)
- (dynamic-call (cadr modinfo) (caddr modinfo))
- ))
- #t))
- #f))
- registered-modules))
-
-(define (dynamic-maybe-call name dynobj)
- (issue-deprecation-warning
- "`dynamic-maybe-call' is deprecated. "
- "Wrap `dynamic-call' in a `false-if-exception' yourself.")
- (false-if-exception (dynamic-call name dynobj)))
-
-
-(define (dynamic-maybe-link filename)
- (issue-deprecation-warning
- "`dynamic-maybe-link' is deprecated. "
- "Wrap `dynamic-link' in a `false-if-exception' yourself.")
- (false-if-exception (dynamic-link filename)))
-
-(define (find-and-link-dynamic-module module-name)
- (define (make-init-name mod-name)
- (string-append "scm_init"
- (list->string (map (lambda (c)
- (if (or (char-alphabetic? c)
- (char-numeric? c))
- c
- #\_))
- (string->list mod-name)))
- "_module"))
-
- ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
- ;; and the `libname' (the name of the module prepended by `lib') in the cdr
- ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then
- ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
- (let ((subdir-and-libname
- (let loop ((dirs "")
- (syms module-name))
- (if (null? (cdr syms))
- (cons dirs (string-append "lib" (symbol->string (car syms))))
- (loop (string-append dirs (symbol->string (car syms)) "/")
- (cdr syms)))))
- (init (make-init-name (apply string-append
- (map (lambda (s)
- (string-append "_"
- (symbol->string s)))
- module-name)))))
- (let ((subdir (car subdir-and-libname))
- (libname (cdr subdir-and-libname)))
-
- ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that
- ;; file exists, fetch the dlname from that file and attempt to link
- ;; against it. If `subdir/libfoo.la' does not exist, or does not seem
- ;; to name any shared library, look for `subdir/libfoo.so' instead and
- ;; link against that.
- (let check-dirs ((dir-list %load-path))
- (if (null? dir-list)
- #f
- (let* ((dir (in-vicinity (car dir-list) subdir))
- (sharlib-full
- (or (try-using-libtool-name dir libname)
- (try-using-sharlib-name dir libname))))
- (if (and sharlib-full (file-exists? sharlib-full))
- (link-dynamic-module sharlib-full init)
- (check-dirs (cdr dir-list)))))))))
-
-(define (try-using-libtool-name libdir libname)
- (let ((libtool-filename (in-vicinity libdir
- (string-append libname ".la"))))
- (and (file-exists? libtool-filename)
- libtool-filename)))
-
-(define (try-using-sharlib-name libdir libname)
- (in-vicinity libdir (string-append libname ".so")))
-
-(define (link-dynamic-module filename initname)
- ;; Register any linked modules which have been registered on the C level
- (register-modules #f)
- (let ((dynobj (dynamic-link filename)))
- (dynamic-call initname dynobj)
- (register-modules dynobj)))
-
-(define (try-module-linked module-name)
- (issue-deprecation-warning
- "`try-module-linked' is deprecated."
- "See the manual for how more on C extensions.")
- (init-dynamic-module module-name))
-
-(define (try-module-dynamic-link module-name)
- (issue-deprecation-warning
- "`try-module-dynamic-link' is deprecated."
- "See the manual for how more on C extensions.")
- (and (find-and-link-dynamic-module module-name)
- (init-dynamic-module module-name)))
-
-\f
-(define (list* . args)
- (issue-deprecation-warning "'list*' is deprecated. Use 'cons*' instead.")
- (apply cons* args))
-
-(define (feature? sym)
- (issue-deprecation-warning
- "`feature?' is deprecated. Use `provided?' instead.")
- (provided? sym))
-
-(define-macro (eval-case . clauses)
- (issue-deprecation-warning
- "`eval-case' is deprecated. Use `eval-when' instead.")
- ;; Practically speaking, eval-case only had load-toplevel and else as
- ;; conditions.
- (cond
- ((assoc-ref clauses '(load-toplevel))
- => (lambda (exps)
- ;; the *unspecified so that non-toplevel definitions will be
- ;; caught
- `(begin *unspecified* . ,exps)))
- ((assoc-ref clauses 'else)
- => (lambda (exps)
- `(begin *unspecified* . ,exps)))
- (else
- `(begin))))
-
-;; The strange prototype system for uniform arrays has been
-;; deprecated.
-(read-hash-extend
- #\y
- (lambda (c port)
- (issue-deprecation-warning
- "The `#y' bytevector syntax is deprecated. Use `#s8' instead.")
- (let ((x (read port)))
- (cond
- ((list? x) (list->s8vector 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)
- (issue-deprecation-warning
- "`$asinh' is deprecated. Use `asinh' instead.")
- (asinh z))
-(define ($acosh z)
- (issue-deprecation-warning
- "`$acosh' is deprecated. Use `acosh' instead.")
- (acosh z))
-(define ($atanh z)
- (issue-deprecation-warning
- "`$atanh' is deprecated. Use `atanh' instead.")
- (atanh z))
-(define ($sqrt z)
- (issue-deprecation-warning
- "`$sqrt' is deprecated. Use `sqrt' instead.")
- (sqrt z))
-(define ($abs z)
- (issue-deprecation-warning
- "`$abs' is deprecated. Use `abs' instead.")
- (abs z))
-(define ($exp z)
- (issue-deprecation-warning
- "`$exp' is deprecated. Use `exp' instead.")
- (exp z))
-(define ($expt z1 z2)
- (issue-deprecation-warning
- "`$expt' is deprecated. Use `expt' instead.")
- (expt z1 z2))
-(define ($log z)
- (issue-deprecation-warning
- "`$log' is deprecated. Use `log' instead.")
- (log z))
-(define ($sin z)
- (issue-deprecation-warning
- "`$sin' is deprecated. Use `sin' instead.")
- (sin z))
-(define ($cos z)
- (issue-deprecation-warning
- "`$cos' is deprecated. Use `cos' instead.")
- (cos z))
-(define ($tan z)
- (issue-deprecation-warning
- "`$tan' is deprecated. Use `tan' instead.")
- (tan z))
-(define ($asin z)
- (issue-deprecation-warning
- "`$asin' is deprecated. Use `asin' instead.")
- (asin z))
-(define ($acos z)
- (issue-deprecation-warning
- "`$acos' is deprecated. Use `acos' instead.")
- (acos z))
-(define ($atan z)
- (issue-deprecation-warning
- "`$atan' is deprecated. Use `atan' instead.")
- (atan z))
-(define ($sinh z)
- (issue-deprecation-warning
- "`$sinh' is deprecated. Use `sinh' instead.")
- (sinh z))
-(define ($cosh z)
- (issue-deprecation-warning
- "`$cosh' is deprecated. Use `cosh' instead.")
- (cosh z))
-(define ($tanh z)
- (issue-deprecation-warning
- "`$tanh' is deprecated. Use `tanh' instead.")
- (tanh z))
-
-(define (closure? x)
- (issue-deprecation-warning
- "`closure?' is deprecated. Use `procedure?' instead.")
- (procedure? x))
-
-(define %nil #nil)
-
-;;; @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.
-;;;
-(define-syntax @bind
- (lambda (x)
- (define (bound-member id ids)
- (cond ((null? ids) #f)
- ((bound-identifier=? id (car ids)) #t)
- ((bound-member (car ids) (cdr ids)))))
-
- (issue-deprecation-warning
- "`@bind' is deprecated. Use `with-fluids' instead.")
-
- (syntax-case x ()
- ((_ () b0 b1 ...)
- #'(let () b0 b1 ...))
- ((_ ((id val) ...) b0 b1 ...)
- (and-map identifier? #'(id ...))
- (if (let lp ((ids #'(id ...)))
- (cond ((null? ids) #f)
- ((bound-member (car ids) (cdr ids)) #t)
- (else (lp (cdr ids)))))
- (syntax-violation '@bind "duplicate bound identifier" x)
- (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
- ((v ...) (generate-temporaries #'(id ...))))
- #'(let ((old-v id) ...
- (v val) ...)
- (dynamic-wind
- (lambda ()
- (set! id v) ...)
- (lambda () b0 b1 ...)
- (lambda ()
- (set! id old-v) ...)))))))))
-
-;; There are deprecated definitions for module-ref-submodule and
-;; module-define-submodule! in boot-9.scm.
-
-;; Define (%app) and (%app modules), and have (app) alias (%app). This
-;; side-effects the-root-module, both to the submodules table and (through
-;; module-define-submodule! above) the obarray.
-;;
-(let ((%app (make-module 31)))
- (set-module-name! %app '(%app))
- (module-define-submodule! the-root-module '%app %app)
- (module-define-submodule! the-root-module 'app %app)
- (module-define-submodule! %app 'modules (resolve-module '() #f)))
-
-;; Allow code that poked %module-public-interface to keep on working.
-;;
-(set! module-public-interface
- (let ((getter module-public-interface))
- (lambda (mod)
- (or (getter mod)
- (cond
- ((and=> (module-local-variable mod '%module-public-interface)
- variable-ref)
- => (lambda (iface)
- (issue-deprecation-warning
-"Setting a module's public interface via munging %module-public-interface is
-deprecated. Use set-module-public-interface! instead.")
- (set-module-public-interface! mod iface)
- iface))
- (else #f))))))
-
-(set! set-module-public-interface!
- (let ((setter set-module-public-interface!))
- (lambda (mod iface)
- (setter mod iface)
- (module-define! mod '%module-public-interface iface))))
-
-(define (bad-throw key . args)
- (issue-deprecation-warning
- "`bad-throw' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- (apply (@ (ice-9 scm-style-repl) bad-throw) key args))
-
-(define (error-catching-loop thunk)
- (issue-deprecation-warning
- "`error-catching-loop' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- ((@ (ice-9 scm-style-repl) error-catching-loop) thunk))
-
-(define (error-catching-repl r e p)
- (issue-deprecation-warning
- "`error-catching-repl' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- ((@ (ice-9 scm-style-repl) error-catching-repl) r e p))
-
-(define (scm-style-repl)
- (issue-deprecation-warning
- "`scm-style-repl' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead, or
-better yet, use the repl from `(system repl repl)'.")
- ((@ (ice-9 scm-style-repl) scm-style-repl)))
-
-
-;;; Apply-to-args had the following comment attached to it in boot-9, but it's
-;;; wrong-headed: in the mentioned case, a point should either be a record or
-;;; multiple values.
-;;;
-;;; apply-to-args is functionally redundant with apply and, worse,
-;;; is less general than apply since it only takes two arguments.
-;;;
-;;; On the other hand, apply-to-args is a syntacticly convenient way to
-;;; perform binding in many circumstances when the "let" family of
-;;; of forms don't cut it. E.g.:
-;;;
-;;; (apply-to-args (return-3d-mouse-coords)
-;;; (lambda (x y z)
-;;; ...))
-;;;
-
-(define (apply-to-args args fn)
- (issue-deprecation-warning
- "`apply-to-args' is deprecated. Include a local copy in your program.")
- (apply fn args))
-
-(define (has-suffix? str suffix)
- (issue-deprecation-warning
- "`has-suffix?' is deprecated. Use `string-suffix?' instead (args reversed).")
- (string-suffix? suffix str))
-
-(define scheme-file-suffix
- (lambda ()
- (issue-deprecation-warning
- "`scheme-file-suffix' is deprecated. Use `%load-extensions' instead.")
- ".scm"))
-
-\f
-
-;;; {Command Line Options}
-;;;
-
-(define (get-option argv kw-opts kw-args return)
- (issue-deprecation-warning
- "`get-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (cond
- ((null? argv)
- (return #f #f argv))
-
- ((or (not (eq? #\- (string-ref (car argv) 0)))
- (eq? (string-length (car argv)) 1))
- (return 'normal-arg (car argv) (cdr argv)))
-
- ((eq? #\- (string-ref (car argv) 1))
- (let* ((kw-arg-pos (or (string-index (car argv) #\=)
- (string-length (car argv))))
- (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
- (kw-opt? (member kw kw-opts))
- (kw-arg? (member kw kw-args))
- (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
- (substring (car argv)
- (+ kw-arg-pos 1)
- (string-length (car argv))))
- (and kw-arg?
- (begin (set! argv (cdr argv)) (car argv))))))
- (if (or kw-opt? kw-arg?)
- (return kw arg (cdr argv))
- (return 'usage-error kw (cdr argv)))))
-
- (else
- (let* ((char (substring (car argv) 1 2))
- (kw (symbol->keyword char)))
- (cond
-
- ((member kw kw-opts)
- (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
- (new-argv (if (= 0 (string-length rest-car))
- (cdr argv)
- (cons (string-append "-" rest-car) (cdr argv)))))
- (return kw #f new-argv)))
-
- ((member kw kw-args)
- (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
- (arg (if (= 0 (string-length rest-car))
- (cadr argv)
- rest-car))
- (new-argv (if (= 0 (string-length rest-car))
- (cddr argv)
- (cdr argv))))
- (return kw arg new-argv)))
-
- (else (return 'usage-error kw argv)))))))
-
-(define (for-next-option proc argv kw-opts kw-args)
- (issue-deprecation-warning
- "`for-next-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (let loop ((argv argv))
- (get-option argv kw-opts kw-args
- (lambda (opt opt-arg argv)
- (and opt (proc opt opt-arg argv loop))))))
-
-(define (display-usage-report kw-desc)
- (issue-deprecation-warning
- "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (for-each
- (lambda (kw)
- (or (eq? (car kw) #t)
- (eq? (car kw) 'else)
- (let* ((opt-desc kw)
- (help (cadr opt-desc))
- (opts (car opt-desc))
- (opts-proper (if (string? (car opts)) (cdr opts) opts))
- (arg-name (if (string? (car opts))
- (string-append "<" (car opts) ">")
- ""))
- (left-part (string-append
- (with-output-to-string
- (lambda ()
- (map (lambda (x) (display (keyword->symbol x)) (display " "))
- opts-proper)))
- arg-name))
- (middle-part (if (and (< (string-length left-part) 30)
- (< (string-length help) 40))
- (make-string (- 30 (string-length left-part)) #\ )
- "\n\t")))
- (display left-part)
- (display middle-part)
- (display help)
- (newline))))
- kw-desc))
-
-(define (transform-usage-lambda cases)
- (issue-deprecation-warning
- "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (let* ((raw-usage (delq! 'else (map car cases)))
- (usage-sans-specials (map (lambda (x)
- (or (and (not (list? x)) x)
- (and (symbol? (car x)) #t)
- (and (boolean? (car x)) #t)
- x))
- raw-usage))
- (usage-desc (delq! #t usage-sans-specials))
- (kw-desc (map car usage-desc))
- (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
- (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
- (transmogrified-cases (map (lambda (case)
- (cons (let ((opts (car case)))
- (if (or (boolean? opts) (eq? 'else opts))
- opts
- (cond
- ((symbol? (car opts)) opts)
- ((boolean? (car opts)) opts)
- ((string? (caar opts)) (cdar opts))
- (else (car opts)))))
- (cdr case)))
- cases)))
- `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
- (lambda (%argv)
- (let %next-arg ((%argv %argv))
- (get-option %argv
- ',kw-opts
- ',kw-args
- (lambda (%opt %arg %new-argv)
- (case %opt
- ,@ transmogrified-cases))))))))
-
-\f
-
-;;; {collect}
-;;;
-;;; Similar to `begin' but returns a list of the results of all constituent
-;;; forms instead of the result of the last form.
-;;;
-
-(define-syntax collect
- (lambda (x)
- (issue-deprecation-warning
- "`collect' is deprecated. Define it yourself.")
- (syntax-case x ()
- ((_) #''())
- ((_ x x* ...)
- #'(let ((val x))
- (cons val (collect x* ...)))))))
-
-
-\f
-
-(define (assert-repl-silence v)
- (issue-deprecation-warning
- "`assert-repl-silence' has moved to `(ice-9 scm-style-repl)'.")
- ((@ (ice-9 scm-style-repl) assert-repl-silence) v))
-
-(define (assert-repl-print-unspecified v)
- (issue-deprecation-warning
- "`assert-repl-print-unspecified' has moved to `(ice-9 scm-style-repl)'.")
- ((@ (ice-9 scm-style-repl) assert-repl-print-unspecified) v))
-
-(define (assert-repl-verbosity v)
- (issue-deprecation-warning
- "`assert-repl-verbosity' has moved to `(ice-9 scm-style-repl)'.")
- ((@ (ice-9 scm-style-repl) assert-repl-verbosity) v))
-
-(define (set-repl-prompt! v)
- (issue-deprecation-warning
- "`set-repl-prompt!' is deprecated. Use `repl-default-prompt-set!' from
-the `(system repl common)' module.")
- ;; Avoid @, as when bootstrapping it will cause the (system repl common)
- ;; module to be loaded at expansion time, which eventually loads srfi-1, but
- ;; that fails due to an unbuilt supporting lib... grrrrrrrrr.
- ((module-ref (resolve-interface '(system repl common))
- 'repl-default-prompt-set!)
- v))
-
-(define (set-batch-mode?! arg)
- (cond
- (arg
- (issue-deprecation-warning
- "`set-batch-mode?!' is deprecated. Use `ensure-batch-mode!' instead.")
- (ensure-batch-mode!))
- (else
- (issue-deprecation-warning
- "`set-batch-mode?!' with an argument of `#f' is deprecated. Use the
-`*repl-stack*' fluid instead.")
- #t)))
-
-(define (repl read evaler print)
- (issue-deprecation-warning
- "`repl' is deprecated. Define it yourself.")
- (let loop ((source (read (current-input-port))))
- (print (evaler source))
- (loop (read (current-input-port)))))
-
-(define (pre-unwind-handler-dispatch key . args)
- (issue-deprecation-warning
- "`pre-unwind-handler-dispatch' is deprecated. Use
-`default-pre-unwind-handler' from `(ice-9 scm-style-repl)' directly.")
- (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
-
-(define (default-pre-unwind-handler key . args)
- (issue-deprecation-warning
- "`default-pre-unwind-handler' is deprecated. Use it from
-`(ice-9 scm-style-repl)' if you need it.")
- (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
-
-(define (handle-system-error key . args)
- (issue-deprecation-warning
- "`handle-system-error' is deprecated. Use it from
-`(ice-9 scm-style-repl)' if you need it.")
- (apply (@ (ice-9 scm-style-repl) handle-system-error) key args))
-
-(define-syntax stack-saved?
- (make-variable-transformer
- (lambda (x)
- (issue-deprecation-warning
- "`stack-saved?' is deprecated. Use it from
-`(ice-9 save-stack)' if you need it.")
- (syntax-case x (set!)
- ((set! id val)
- (identifier? #'id)
- #'(set! (@ (ice-9 save-stack) stack-saved?) val))
- (id
- (identifier? #'id)
- #'(@ (ice-9 save-stack) stack-saved?))))))
-
-(define-syntax the-last-stack
- (lambda (x)
- (issue-deprecation-warning
- "`the-last-stack' is deprecated. Use it from `(ice-9 save-stack)'
-if you need it.")
- (syntax-case x ()
- (id
- (identifier? #'id)
- #'(@ (ice-9 save-stack) the-last-stack)))))
-
-(define (save-stack . args)
- (issue-deprecation-warning
- "`save-stack' is deprecated. Use it from `(ice-9 save-stack)' if you need
-it.")
- (apply (@ (ice-9 save-stack) save-stack) args))
-
-(define (named-module-use! user usee)
- (issue-deprecation-warning
- "`named-module-use!' is deprecated. Define it yourself if you need it.")
- (module-use! (resolve-module user) (resolve-interface usee)))
-
-(define (top-repl)
- (issue-deprecation-warning
- "`top-repl' has moved to the `(ice-9 top-repl)' module.")
- ((module-ref (resolve-module '(ice-9 top-repl)) 'top-repl)))
-
-(set! debug-enable
- (let ((debug-enable debug-enable))
- (lambda opts
- (if (memq 'debug opts)
- (begin
- (issue-deprecation-warning
- "`(debug-enable 'debug)' is obsolete and has no effect."
- "Remove it from your code.")
- (apply debug-enable (delq 'debug opts)))
- (apply debug-enable opts)))))
-
-(define (turn-on-debugging)
- (issue-deprecation-warning
- "`(turn-on-debugging)' is obsolete and usually has no effect."
- "Debugging capabilities are present by default.")
- (debug-enable 'backtrace)
- (read-enable 'positions))
-
-(define (read-hash-procedures-warning)
- (issue-deprecation-warning
- "`read-hash-procedures' is deprecated."
- "Use the fluid `%read-hash-procedures' instead."))
-
-(define-syntax read-hash-procedures
- (identifier-syntax
- (_
- (begin (read-hash-procedures-warning)
- (fluid-ref %read-hash-procedures)))
- ((set! _ expr)
- (begin (read-hash-procedures-warning)
- (fluid-set! %read-hash-procedures expr)))))
-
-(define (process-define-module args)
- (define (missing kw)
- (error "missing argument to define-module keyword" kw))
- (define (unrecognized arg)
- (error "unrecognized define-module argument" arg))
-
- (issue-deprecation-warning
- "`process-define-module' is deprecated. Use `define-module*' instead.")
-
- (let ((name (car args))
- (filename #f)
- (pure? #f)
- (version #f)
- (system? #f)
- (duplicates '())
- (transformer #f))
- (let loop ((kws (cdr args))
- (imports '())
- (exports '())
- (re-exports '())
- (replacements '())
- (autoloads '()))
- (if (null? kws)
- (define-module* name
- #:filename filename #:pure pure? #:version version
- #:duplicates duplicates #:transformer transformer
- #:imports (reverse! imports)
- #:exports exports
- #:re-exports re-exports
- #:replacements replacements
- #:autoloads autoloads)
- (case (car kws)
- ((#:use-module #:use-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (cond
- ((equal? (cadr kws) '(ice-9 syncase))
- (issue-deprecation-warning
- "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.")
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- (else
- (let ((iface-spec (cadr kws)))
- (if (eq? (car kws) #:use-syntax)
- (set! transformer iface-spec))
- (loop (cddr kws)
- (cons iface-spec imports) exports re-exports
- replacements autoloads)))))
- ((#:autoload)
- (or (and (pair? (cdr kws)) (pair? (cddr kws)))
- (missing (car kws)))
- (let ((name (cadr kws))
- (bindings (caddr kws)))
- (loop (cdddr kws)
- imports exports re-exports
- replacements (cons* name bindings autoloads))))
- ((#:no-backtrace)
- ;; FIXME: deprecate?
- (set! system? #t)
- (loop (cdr kws)
- imports exports re-exports replacements autoloads))
- ((#:pure)
- (set! pure? #t)
- (loop (cdr kws)
- imports exports re-exports replacements autoloads))
- ((#:version)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (set! version (cadr kws))
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- ((#:duplicates)
- (if (not (pair? (cdr kws)))
- (missing (car kws)))
- (set! duplicates (cadr kws))
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- ((#:export #:export-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (loop (cddr kws)
- imports (append exports (cadr kws)) re-exports
- replacements autoloads))
- ((#:re-export #:re-export-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (loop (cddr kws)
- imports exports (append re-exports (cadr kws))
- replacements autoloads))
- ((#:replace #:replace-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (loop (cddr kws)
- imports exports re-exports
- (append replacements (cadr kws)) autoloads))
- ((#:filename)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (set! filename (cadr kws))
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- (else
- (unrecognized kws)))))))
-
-(define-syntax fluid-let-syntax
- (lambda (x)
- (issue-deprecation-warning
- "`fluid-let-syntax' is deprecated. Use syntax parameters instead.")
- (syntax-case x ()
- ((_ ((k v) ...) body0 body ...)
- #'(syntax-parameterize ((k v) ...)
- body0 body ...)))))
-
-(define (close-io-port port)
- (issue-deprecation-warning
- "`close-io-port' is deprecated. Use `close-port' instead.")
- (close-port port))
-
-(define (set-system-module! m s)
- (issue-deprecation-warning
- "`set-system-module!' is deprecated. There is no need to use it.")
- (set-procedure-property! (module-eval-closure m) 'system-module s))
-
-(set! module-eval-closure
- (lambda (m)
- (issue-deprecation-warning
- "`module-eval-closure' is deprecated. Use module-variable or module-define! instead.")
- (standard-eval-closure m)))
-
-;; Legacy definition. We can't make it identifier-syntax yet though,
-;; because compiled code might rely on it.
-(define char-code-limit 256)
+;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010, 2011, 2012, 2013 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 (ice-9 deprecated)
+ #:export ())
#:use-module (system base compile)
#:use-module (system base language)
#:use-module (system vm program)
+ #:use-module (system vm loader)
#:replace (eval-string))
(define (ensure-language x)
(set-port-column! port line))
(if (or compile? (not (language-evaluator lang)))
- ((make-program (read-and-compile port #:from lang #:to 'objcode)))
+ ((load-thunk-from-memory
+ (read-and-compile port #:from lang #:to 'bytecode)))
(read-and-eval port #:lang lang))))))))
-;;; -*- mode: scheme; coding: utf-8; -*-
-
-;;;; Copyright (C) 2009, 2010, 2012, 2013 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 ()
- ((_ (exp ...))
- (let ((env (exp ...)))
- (capture-env env)))
- ((_ 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)))))
-
- ;; Fast case for procedures with fixed arities.
- (define-syntax make-fixed-closure
- (lambda (x)
- (define *max-static-argument-count* 8)
- (define (make-formals n)
- (map (lambda (i)
- (datum->syntax
- x
- (string->symbol
- (string (integer->char (+ (char->integer #\a) i))))))
- (iota n)))
- (syntax-case x ()
- ((_ eval nreq body env) (not (identifier? #'env))
- #'(let ((e env))
- (make-fixed-closure eval nreq body e)))
- ((_ eval nreq body env)
- #`(case nreq
- #,@(map (lambda (nreq)
- (let ((formals (make-formals nreq)))
- #`((#,nreq)
- (lambda (#,@formals)
- (eval body
- (cons* #,@(reverse formals) env))))))
- (iota *max-static-argument-count*))
- (else
- #,(let ((formals (make-formals *max-static-argument-count*)))
- #`(lambda (#,@formals . more)
- (let lp ((new-env (cons* #,@(reverse formals) env))
- (nreq (- nreq #,*max-static-argument-count*))
- (args more))
- (if (zero? nreq)
- (eval body
- (if (null? args)
- new-env
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of arguments"
- '() #f)))
- (if (null? args)
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of arguments"
- '() #f)
- (lp (cons (car args) new-env)
- (1- nreq)
- (cdr args)))))))))))))
-
- (define-syntax call
- (lambda (x)
- (define *max-static-call-count* 4)
- (syntax-case x ()
- ((_ eval proc nargs args env) (identifier? #'env)
- #`(case nargs
- #,@(map (lambda (nargs)
- #`((#,nargs)
- (proc
- #,@(map
- (lambda (n)
- (let lp ((n n) (args #'args))
- (if (zero? n)
- #`(eval (car #,args) env)
- (lp (1- n) #`(cdr #,args)))))
- (iota nargs)))))
- (iota *max-static-call-count*))
- (else
- (apply proc
- #,@(map
- (lambda (n)
- (let lp ((n n) (args #'args))
- (if (zero? n)
- #`(eval (car #,args) env)
- (lp (1- n) #`(cdr #,args)))))
- (iota *max-static-call-count*))
- (let lp ((exps #,(let lp ((n *max-static-call-count*)
- (args #'args))
- (if (zero? n)
- args
- (lp (1- n) #`(cdr #,args)))))
- (args '()))
- (if (null? exps)
- (reverse args)
- (lp (cdr exps)
- (cons (eval (car exps) env) args)))))))))))
-
- ;; 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 ...)))))))
-
-
-;;;
-;;; On 18 Feb 2010, I did a profile of how often the various memoized expression
-;;; types occur when getting to a prompt on a fresh build. Here are the numbers
-;;; I got:
-;;;
-;;; lexical-ref: 32933054
-;;; call: 20281547
-;;; toplevel-ref: 13228724
-;;; if: 9156156
-;;; quote: 6610137
-;;; let: 2619707
-;;; lambda: 1010921
-;;; begin: 948945
-;;; lexical-set: 509862
-;;; call-with-values: 139668
-;;; apply: 49402
-;;; module-ref: 14468
-;;; define: 1259
-;;; toplevel-set: 328
-;;; dynwind: 162
-;;; with-fluids: 0
-;;; call/cc: 0
-;;; module-set: 0
-;;;
-;;; So until we compile `case' into a computed goto, we'll order the clauses in
-;;; `eval' in this order, to put the most frequent cases first.
-;;;
-
-(define primitive-eval
- (let ()
- ;; We pre-generate procedures with fixed arities, up to some number of
- ;; arguments; see make-fixed-closure above.
-
- ;; A unique marker for unbound keywords.
- (define unbound-arg (list 'unbound-arg))
-
- ;; Procedures with rest, optional, or keyword arguments, potentially with
- ;; multiple arities, as with case-lambda.
- (define (make-general-closure env body nreq rest? nopt kw inits alt)
- (define alt-proc
- (and alt ; (body docstring nreq ...)
- (let* ((body (car alt))
- (spec (cddr alt))
- (nreq (car spec))
- (rest (if (null? (cdr spec)) #f (cadr spec)))
- (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
- (nopt (if tail (car tail) 0))
- (kw (and tail (cadr tail)))
- (inits (if tail (caddr tail) '()))
- (alt (and tail (cadddr tail))))
- (make-general-closure env body nreq rest nopt kw inits alt))))
- (define (set-procedure-arity! proc)
- (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
- (if (not alt)
- (begin
- (set-procedure-property! proc 'arglist
- (list nreq
- nopt
- (if kw (cdr kw) '())
- (and kw (car kw))
- (and rest? '_)))
- (set-procedure-minimum-arity! proc nreq nopt rest?))
- (let* ((spec (cddr alt))
- (nreq* (car spec))
- (rest?* (if (null? (cdr spec)) #f (cadr spec)))
- (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
- (nopt* (if tail (car tail) 0))
- (alt* (and tail (cadddr tail))))
- (if (or (< nreq* nreq)
- (and (= nreq* nreq)
- (if rest?
- (and rest?* (> nopt* nopt))
- (or rest?* (> nopt* nopt)))))
- (lp alt* nreq* nopt* rest?*)
- (lp alt* nreq nopt rest?)))))
- proc)
- (set-procedure-arity!
- (lambda %args
- (let lp ((env env)
- (nreq* nreq)
- (args %args))
- (if (> nreq* 0)
- ;; First, bind required arguments.
- (if (null? args)
- (if alt
- (apply alt-proc %args)
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of arguments"
- '() #f))
- (lp (cons (car args) env)
- (1- nreq*)
- (cdr args)))
- ;; Move on to optional arguments.
- (if (not kw)
- ;; Without keywords, bind optionals from arguments.
- (let lp ((env env)
- (nopt nopt)
- (args args)
- (inits inits))
- (if (zero? nopt)
- (if rest?
- (eval body (cons args env))
- (if (null? args)
- (eval body env)
- (if alt
- (apply alt-proc %args)
- (scm-error 'wrong-number-of-args
- "eval" "Wrong number of arguments"
- '() #f))))
- (if (null? args)
- (lp (cons (eval (car inits) env) env)
- (1- nopt) args (cdr inits))
- (lp (cons (car args) env)
- (1- nopt) (cdr args) (cdr inits)))))
- (let lp ((env env)
- (nopt* nopt)
- (args args)
- (inits inits))
- (cond
- ;; With keywords, we stop binding optionals at the
- ;; first keyword.
- ((> nopt* 0)
- (if (or (null? args) (keyword? (car args)))
- (lp (cons (eval (car inits) env) env)
- (1- nopt*) args (cdr inits))
- (lp (cons (car args) env)
- (1- nopt*) (cdr args) (cdr inits))))
- ;; Finished with optionals.
- ((and alt (pair? args) (not (keyword? (car args)))
- (not rest?))
- ;; Too many positional args, no #:rest arg,
- ;; and we have an alternate.
- (apply alt-proc %args))
- (else
- (let* ((aok (car kw))
- (kw (cdr kw))
- (kw-base (+ nopt nreq (if rest? 1 0)))
- (imax (let lp ((imax (1- kw-base)) (kw kw))
- (if (null? kw)
- imax
- (lp (max (cdar kw) imax)
- (cdr kw)))))
- ;; Fill in kwargs with "undefined" vals.
- (env (let lp ((i kw-base)
- ;; Also, here we bind the rest
- ;; arg, if any.
- (env (if rest?
- (cons args env)
- env)))
- (if (<= i imax)
- (lp (1+ i) (cons unbound-arg env))
- env))))
- ;; Now scan args for keywords.
- (let lp ((args args))
- (if (and (pair? args) (pair? (cdr args))
- (keyword? (car args)))
- (let ((kw-pair (assq (car args) kw))
- (v (cadr args)))
- (if kw-pair
- ;; Found a known keyword; set its value.
- (list-set! env
- (- imax (cdr kw-pair)) v)
- ;; Unknown keyword.
- (if (not aok)
- (scm-error
- 'keyword-argument-error
- "eval" "Unrecognized keyword"
- '() (list (car args)))))
- (lp (cddr args)))
- (if (pair? args)
- (if rest?
- ;; Be lenient parsing rest args.
- (lp (cdr args))
- (scm-error 'keyword-argument-error
- "eval" "Invalid keyword"
- '() (list (car args))))
- ;; Finished parsing keywords. Fill in
- ;; uninitialized kwargs by evalling init
- ;; expressions in their appropriate
- ;; environment.
- (let lp ((i (- imax kw-base))
- (inits inits))
- (if (pair? inits)
- (let ((tail (list-tail env i)))
- (if (eq? (car tail) unbound-arg)
- (set-car! tail
- (eval (car inits)
- (cdr tail))))
- (lp (1- i) (cdr inits)))
- ;; Finally, eval the body.
- (eval body env))))))))))))))))
-
- ;; The "engine". EXP is a memoized expression.
- (define (eval exp env)
- (memoized-expression-case exp
- (('lexical-ref n)
- (list-ref env n))
-
- (('call (f nargs . args))
- (let ((proc (eval f env)))
- (call eval proc nargs args env)))
-
- (('toplevel-ref var-or-sym)
- (variable-ref
- (if (variable? var-or-sym)
- var-or-sym
- (memoize-variable-access! exp
- (capture-env (if (pair? env)
- (cdr (last-pair env))
- env))))))
-
- (('if (test consequent . alternate))
- (if (eval test env)
- (eval consequent env)
- (eval alternate env)))
-
- (('quote x)
- x)
-
- (('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 (body docstring nreq . tail))
- (let ((proc
- (if (null? tail)
- (make-fixed-closure eval nreq body (capture-env env))
- (if (null? (cdr tail))
- (make-general-closure (capture-env env) body
- nreq (car tail)
- 0 #f '() #f)
- (apply make-general-closure (capture-env env)
- body nreq tail)))))
- (when docstring
- (set-procedure-property! proc 'documentation docstring))
- proc))
-
- (('begin (first . rest))
- (let lp ((first first) (rest rest))
- (if (null? rest)
- (eval first env)
- (begin
- (eval first env)
- (lp (car rest) (cdr rest))))))
-
- (('lexical-set! (n . x))
- (let ((val (eval x env)))
- (list-set! env n val)))
-
- (('call-with-values (producer . consumer))
- (call-with-values (eval producer env)
- (eval consumer env)))
-
- (('apply (f args))
- (apply (eval f env) (eval args env)))
-
- (('module-ref var-or-spec)
- (variable-ref
- (if (variable? var-or-spec)
- var-or-spec
- (memoize-variable-access! exp #f))))
-
- (('define (name . x))
- (let ((x (eval x env)))
- (if (and (procedure? x) (not (procedure-property x 'name)))
- (set-procedure-property! x 'name name))
- (define! name x)
- (if #f #f)))
-
- (('toplevel-set! (var-or-sym . x))
- (variable-set!
- (if (variable? var-or-sym)
- var-or-sym
- (memoize-variable-access! exp
- (capture-env (if (pair? env)
- (cdr (last-pair env))
- env))))
- (eval x env)))
-
- (('dynwind (in exp . out))
- (dynamic-wind (eval in env)
- (lambda () (eval exp env))
- (eval out env)))
-
- (('with-fluids (fluids vals . exp))
- (let* ((fluids (map (lambda (x) (eval x env)) fluids))
- (vals (map (lambda (x) (eval x env)) vals)))
- (let lp ((fluids fluids) (vals vals))
- (if (null? fluids)
- (eval exp env)
- (with-fluids (((car fluids) (car vals)))
- (lp (cdr fluids) (cdr vals)))))))
-
- (('prompt (tag exp . handler))
- (@prompt (eval tag env)
- (eval exp env)
- (eval handler env)))
-
- (('call/cc proc)
- (call/cc (eval proc env)))
-
- (('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
- (if (macroexpanded? exp)
- exp
- ((module-transformer (current-module)) exp)))
- '()))))
+;;; -*- mode: scheme; coding: utf-8; -*-
+
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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 a chain of vectors, linked through
+;;; their first elements. The terminal element of an environment is the
+;;; module that was current when the outer lexical environment was
+;;; entered.
+;;;
+
+;;; Code:
+
+\f
+
+(define (primitive-eval exp)
+ "Evaluate @var{exp} in the current module."
+ (define-syntax env-toplevel
+ (syntax-rules ()
+ ((_ env)
+ (let lp ((e env))
+ (if (vector? e)
+ (lp (vector-ref e 0))
+ e)))))
+
+ (define-syntax make-env
+ (syntax-rules ()
+ ((_ n init next)
+ (let ((v (make-vector (1+ n) init)))
+ (vector-set! v 0 next)
+ v))))
+
+ (define-syntax make-env*
+ (syntax-rules ()
+ ((_ next init ...)
+ (vector next init ...))))
+
+ (define-syntax env-ref
+ (syntax-rules ()
+ ((_ env depth width)
+ (let lp ((e env) (d depth))
+ (if (zero? d)
+ (vector-ref e (1+ width))
+ (lp (vector-ref e 0) (1- d)))))))
+
+ (define-syntax env-set!
+ (syntax-rules ()
+ ((_ env depth width val)
+ (let lp ((e env) (d depth))
+ (if (zero? d)
+ (vector-set! e (1+ width) val)
+ (lp (vector-ref e 0) (1- d)))))))
+
+ ;; This is a modified version of Oleg Kiselyov's "pmatch".
+ (define-syntax-rule (match e cs ...)
+ (let ((v e)) (expand-clauses v cs ...)))
+
+ (define-syntax expand-clauses
+ (syntax-rules ()
+ ((_ v) ((error "unreachable")))
+ ((_ v (pat e0 e ...) cs ...)
+ (let ((fk (lambda () (expand-clauses v cs ...))))
+ (expand-pattern v pat (let () e0 e ...) (fk))))))
+
+ (define-syntax expand-pattern
+ (syntax-rules (_ quote unquote)
+ ((_ v _ kt kf) kt)
+ ((_ v () kt kf) (if (null? v) kt kf))
+ ((_ v (quote lit) kt kf)
+ (if (equal? v (quote lit)) kt kf))
+ ((_ v (unquote exp) kt kf)
+ (if (equal? v exp) kt kf))
+ ((_ v (x . y) kt kf)
+ (if (pair? v)
+ (let ((vx (car v)) (vy (cdr v)))
+ (expand-pattern vx x (expand-pattern vy y kt kf) kf))
+ kf))
+ ((_ v #f kt kf) (if (eqv? v #f) kt kf))
+ ((_ v var kt kf) (let ((var v)) kt))))
+
+ (define-syntax typecode
+ (lambda (x)
+ (syntax-case x ()
+ ((_ type)
+ (or (memoized-typecode (syntax->datum #'type))
+ (error "not a typecode" (syntax->datum #'type)))))))
+
+ (define (compile-lexical-ref depth width)
+ (lambda (env)
+ (env-ref env depth width)))
+
+ (define (compile-call f nargs args)
+ (let ((f (compile f)))
+ (match args
+ (() (lambda (env) ((f env))))
+ ((a)
+ (let ((a (compile a)))
+ (lambda (env) ((f env) (a env)))))
+ ((a b)
+ (let ((a (compile a))
+ (b (compile b)))
+ (lambda (env) ((f env) (a env) (b env)))))
+ ((a b c)
+ (let ((a (compile a))
+ (b (compile b))
+ (c (compile c)))
+ (lambda (env) ((f env) (a env) (b env) (c env)))))
+ ((a b c . args)
+ (let ((a (compile a))
+ (b (compile b))
+ (c (compile c))
+ (args (let lp ((args args))
+ (if (null? args)
+ '()
+ (cons (compile (car args)) (lp (cdr args)))))))
+ (lambda (env)
+ (apply (f env) (a env) (b env) (c env)
+ (let lp ((args args))
+ (if (null? args)
+ '()
+ (cons ((car args) env) (lp (cdr args))))))))))))
+
+ (define (compile-box-ref box)
+ (match box
+ ((,(typecode resolve) . var-or-loc)
+ (lambda (env)
+ (cond
+ ((variable? var-or-loc) (variable-ref var-or-loc))
+ (else
+ (set! var-or-loc
+ (%resolve-variable var-or-loc (env-toplevel env)))
+ (variable-ref var-or-loc)))))
+ ((,(typecode lexical-ref) depth . width)
+ (lambda (env)
+ (variable-ref (env-ref env depth width))))
+ (_
+ (let ((box (compile box)))
+ (lambda (env)
+ (variable-ref (box env)))))))
+
+ (define (compile-resolve var-or-loc)
+ (lambda (env)
+ (cond
+ ((variable? var-or-loc) var-or-loc)
+ (else
+ (set! var-or-loc (%resolve-variable var-or-loc (env-toplevel env)))
+ var-or-loc))))
+
+ (define (compile-if test consequent alternate)
+ (let ((test (compile test))
+ (consequent (compile consequent))
+ (alternate (compile alternate)))
+ (lambda (env)
+ (if (test env) (consequent env) (alternate env)))))
+
+ (define (compile-quote x)
+ (lambda (env) x))
+
+ (define (compile-let inits body)
+ (let ((body (compile body))
+ (width (vector-length inits)))
+ (case width
+ ((0) (lambda (env)
+ (body (make-env* env))))
+ ((1)
+ (let ((a (compile (vector-ref inits 0))))
+ (lambda (env)
+ (body (make-env* env (a env))))))
+ ((2)
+ (let ((a (compile (vector-ref inits 0)))
+ (b (compile (vector-ref inits 1))))
+ (lambda (env)
+ (body (make-env* env (a env) (b env))))))
+ ((3)
+ (let ((a (compile (vector-ref inits 0)))
+ (b (compile (vector-ref inits 1)))
+ (c (compile (vector-ref inits 2))))
+ (lambda (env)
+ (body (make-env* env (a env) (b env) (c env))))))
+ ((4)
+ (let ((a (compile (vector-ref inits 0)))
+ (b (compile (vector-ref inits 1)))
+ (c (compile (vector-ref inits 2)))
+ (d (compile (vector-ref inits 3))))
+ (lambda (env)
+ (body (make-env* env (a env) (b env) (c env) (d env))))))
+ (else
+ (let lp ((n width)
+ (k (lambda (env)
+ (make-env width #f env))))
+ (if (zero? n)
+ (lambda (env)
+ (body (k env)))
+ (lp (1- n)
+ (let ((init (compile (vector-ref inits (1- n)))))
+ (lambda (env)
+ (let* ((x (init env))
+ (new-env (k env)))
+ (env-set! new-env 0 (1- n) x)
+ new-env))))))))))
+
+ (define (compile-fixed-lambda body nreq)
+ (case nreq
+ ((0) (lambda (env)
+ (lambda ()
+ (body (make-env* env)))))
+ ((1) (lambda (env)
+ (lambda (a)
+ (body (make-env* env a)))))
+ ((2) (lambda (env)
+ (lambda (a b)
+ (body (make-env* env a b)))))
+ ((3) (lambda (env)
+ (lambda (a b c)
+ (body (make-env* env a b c)))))
+ ((4) (lambda (env)
+ (lambda (a b c d)
+ (body (make-env* env a b c d)))))
+ ((5) (lambda (env)
+ (lambda (a b c d e)
+ (body (make-env* env a b c d e)))))
+ ((6) (lambda (env)
+ (lambda (a b c d e f)
+ (body (make-env* env a b c d e f)))))
+ ((7) (lambda (env)
+ (lambda (a b c d e f g)
+ (body (make-env* env a b c d e f g)))))
+ (else
+ (lambda (env)
+ (lambda (a b c d e f g . more)
+ (let ((env (make-env nreq #f env)))
+ (env-set! env 0 0 a)
+ (env-set! env 0 1 b)
+ (env-set! env 0 2 c)
+ (env-set! env 0 3 d)
+ (env-set! env 0 4 e)
+ (env-set! env 0 5 f)
+ (env-set! env 0 6 g)
+ (let lp ((n 7) (args more))
+ (cond
+ ((= n nreq)
+ (unless (null? args)
+ (scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f))
+ (body env))
+ ((null? args)
+ (scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f))
+ (else
+ (env-set! env 0 n (car args))
+ (lp (1+ n) (cdr args)))))))))))
+
+ (define (compile-rest-lambda body nreq rest?)
+ (case nreq
+ ((0) (lambda (env)
+ (lambda rest
+ (body (make-env* env rest)))))
+ ((1) (lambda (env)
+ (lambda (a . rest)
+ (body (make-env* env a rest)))))
+ ((2) (lambda (env)
+ (lambda (a b . rest)
+ (body (make-env* env a b rest)))))
+ ((3) (lambda (env)
+ (lambda (a b c . rest)
+ (body (make-env* env a b c rest)))))
+ (else
+ (lambda (env)
+ (lambda (a b c . more)
+ (let ((env (make-env (1+ nreq) #f env)))
+ (env-set! env 0 0 a)
+ (env-set! env 0 1 b)
+ (env-set! env 0 2 c)
+ (let lp ((n 3) (args more))
+ (cond
+ ((= n nreq)
+ (env-set! env 0 n args)
+ (body env))
+ ((null? args)
+ (scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f))
+ (else
+ (env-set! env 0 n (car args))
+ (lp (1+ n) (cdr args)))))))))))
+
+ (define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)
+ (lambda (env)
+ (define alt (and make-alt (make-alt env)))
+ (lambda args
+ (let ((nargs (length args)))
+ (cond
+ ((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt))))
+ (if alt
+ (apply alt args)
+ ((scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f))))
+ (else
+ (let* ((nvals (+ nreq (if rest? 1 0) ninits))
+ (env (make-env nvals unbound env)))
+ (define (bind-req args)
+ (let lp ((i 0) (args args))
+ (cond
+ ((< i nreq)
+ ;; Bind required arguments.
+ (env-set! env 0 i (car args))
+ (lp (1+ i) (cdr args)))
+ (else
+ (bind-opt args)))))
+ (define (bind-opt args)
+ (let lp ((i nreq) (args args))
+ (cond
+ ((and (< i (+ nreq nopt)) (< i nargs))
+ (env-set! env 0 i (car args))
+ (lp (1+ i) (cdr args)))
+ (else
+ (bind-rest args)))))
+ (define (bind-rest args)
+ (when rest?
+ (env-set! env 0 (+ nreq nopt) args))
+ (body env))
+ (bind-req args))))))))
+
+ (define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
+ (define allow-other-keys? (car kw))
+ (define keywords (cdr kw))
+ (lambda (env)
+ (define alt (and make-alt (make-alt env)))
+ (lambda args
+ (define (npositional args)
+ (let lp ((n 0) (args args))
+ (if (or (null? args)
+ (and (>= n nreq) (keyword? (car args))))
+ n
+ (lp (1+ n) (cdr args)))))
+ (let ((nargs (length args)))
+ (cond
+ ((or (< nargs nreq)
+ (and alt (not rest?) (> (npositional args) (+ nreq nopt))))
+ (if alt
+ (apply alt args)
+ ((scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f))))
+ (else
+ (let* ((nvals (+ nreq (if rest? 1 0) ninits))
+ (env (make-env nvals unbound env)))
+ (define (bind-req args)
+ (let lp ((i 0) (args args))
+ (cond
+ ((< i nreq)
+ ;; Bind required arguments.
+ (env-set! env 0 i (car args))
+ (lp (1+ i) (cdr args)))
+ (else
+ (bind-opt args)))))
+ (define (bind-opt args)
+ (let lp ((i nreq) (args args))
+ (cond
+ ((and (< i (+ nreq nopt)) (< i nargs)
+ (not (keyword? (car args))))
+ (env-set! env 0 i (car args))
+ (lp (1+ i) (cdr args)))
+ (else
+ (bind-rest args)))))
+ (define (bind-rest args)
+ (when rest?
+ (env-set! env 0 (+ nreq nopt) args))
+ (bind-kw args))
+ (define (bind-kw args)
+ (let lp ((args args))
+ (cond
+ ((and (pair? args) (pair? (cdr args))
+ (keyword? (car args)))
+ (let ((kw-pair (assq (car args) keywords))
+ (v (cadr args)))
+ (if kw-pair
+ ;; Found a known keyword; set its value.
+ (env-set! env 0 (cdr kw-pair) v)
+ ;; Unknown keyword.
+ (if (not allow-other-keys?)
+ ((scm-error
+ 'keyword-argument-error
+ "eval" "Unrecognized keyword"
+ '() (list (car args))))))
+ (lp (cddr args))))
+ ((pair? args)
+ (if rest?
+ ;; Be lenient parsing rest args.
+ (lp (cdr args))
+ ((scm-error 'keyword-argument-error
+ "eval" "Invalid keyword"
+ '() (list (car args))))))
+ (else
+ (body env)))))
+ (bind-req args))))))))
+
+ (define (compute-arity alt nreq rest? nopt kw)
+ (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
+ (if (not alt)
+ (let ((arglist (list nreq
+ nopt
+ (if kw (cdr kw) '())
+ (and kw (car kw))
+ (and rest? '_))))
+ (values arglist nreq nopt rest?))
+ (let* ((spec (cddr alt))
+ (nreq* (car spec))
+ (rest?* (if (null? (cdr spec)) #f (cadr spec)))
+ (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
+ (nopt* (if tail (car tail) 0))
+ (alt* (and tail (car (cddddr tail)))))
+ (if (or (< nreq* nreq)
+ (and (= nreq* nreq)
+ (if rest?
+ (and rest?* (> nopt* nopt))
+ (or rest?* (> nopt* nopt)))))
+ (lp alt* nreq* nopt* rest?*)
+ (lp alt* nreq nopt rest?))))))
+
+ (define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt)
+ (call-with-values
+ (lambda ()
+ (compute-arity alt nreq rest? nopt kw))
+ (lambda (arglist min-nreq min-nopt min-rest?)
+ (define make-alt
+ (match alt
+ (#f #f)
+ ((body meta nreq . tail)
+ (compile-lambda body meta nreq tail))))
+ (define make-closure
+ (if kw
+ (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
+ (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)))
+ (lambda (env)
+ (let ((proc (make-closure env)))
+ (set-procedure-property! proc 'arglist arglist)
+ (set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?)
+ proc)))))
+
+ (define (compile-lambda body meta nreq tail)
+ (define (set-procedure-meta meta proc)
+ (match meta
+ (() proc)
+ (((prop . val) . meta)
+ (set-procedure-meta meta
+ (lambda (env)
+ (let ((proc (proc env)))
+ (set-procedure-property! proc prop val)
+ proc))))))
+ (let ((body (compile body)))
+ (set-procedure-meta
+ meta
+ (match tail
+ (() (compile-fixed-lambda body nreq))
+ ((rest? . tail)
+ (match tail
+ (() (compile-rest-lambda body nreq rest?))
+ ((nopt kw ninits unbound alt)
+ (compile-general-lambda body nreq rest? nopt kw
+ ninits unbound alt))))))))
+
+ (define (compile-capture-env locs body)
+ (let ((body (compile body)))
+ (lambda (env)
+ (let* ((len (vector-length locs))
+ (new-env (make-env len #f (env-toplevel env))))
+ (let lp ((n 0))
+ (when (< n len)
+ (match (vector-ref locs n)
+ ((depth . width)
+ (env-set! new-env 0 n (env-ref env depth width))))
+ (lp (1+ n))))
+ (body new-env)))))
+
+ (define (compile-seq head tail)
+ (let ((head (compile head))
+ (tail (compile tail)))
+ (lambda (env)
+ (head env)
+ (tail env))))
+
+ (define (compile-box-set! box val)
+ (let ((box (compile box))
+ (val (compile val)))
+ (lambda (env)
+ (let ((val (val env)))
+ (variable-set! (box env) val)))))
+
+ (define (compile-lexical-set! depth width x)
+ (let ((x (compile x)))
+ (lambda (env)
+ (env-set! env depth width (x env)))))
+
+ (define (compile-call-with-values producer consumer)
+ (let ((producer (compile producer))
+ (consumer (compile consumer)))
+ (lambda (env)
+ (call-with-values (producer env)
+ (consumer env)))))
+
+ (define (compile-apply f args)
+ (let ((f (compile f))
+ (args (compile args)))
+ (lambda (env)
+ (apply (f env) (args env)))))
+
+ (define (compile-capture-module x)
+ (let ((x (compile x)))
+ (lambda (env)
+ (x (current-module)))))
+
+ (define (compile-call-with-prompt tag thunk handler)
+ (let ((tag (compile tag))
+ (thunk (compile thunk))
+ (handler (compile handler)))
+ (lambda (env)
+ (call-with-prompt (tag env) (thunk env) (handler env)))))
+
+ (define (compile-call/cc proc)
+ (let ((proc (compile proc)))
+ (lambda (env)
+ (call/cc (proc env)))))
+
+ (define (compile exp)
+ (match exp
+ ((,(typecode lexical-ref) depth . width)
+ (compile-lexical-ref depth width))
+
+ ((,(typecode call) f nargs . args)
+ (compile-call f nargs args))
+
+ ((,(typecode box-ref) . box)
+ (compile-box-ref box))
+
+ ((,(typecode resolve) . var-or-loc)
+ (compile-resolve var-or-loc))
+
+ ((,(typecode if) test consequent . alternate)
+ (compile-if test consequent alternate))
+
+ ((,(typecode quote) . x)
+ (compile-quote x))
+
+ ((,(typecode let) inits . body)
+ (compile-let inits body))
+
+ ((,(typecode lambda) body meta nreq . tail)
+ (compile-lambda body meta nreq tail))
+
+ ((,(typecode capture-env) locs . body)
+ (compile-capture-env locs body))
+
+ ((,(typecode seq) head . tail)
+ (compile-seq head tail))
+
+ ((,(typecode box-set!) box . val)
+ (compile-box-set! box val))
+
+ ((,(typecode lexical-set!) (depth . width) . x)
+ (compile-lexical-set! depth width x))
+
+ ((,(typecode call-with-values) producer . consumer)
+ (compile-call-with-values producer consumer))
+
+ ((,(typecode apply) f args)
+ (compile-apply f args))
+
+ ((,(typecode capture-module) . x)
+ (compile-capture-module x))
+
+ ((,(typecode call-with-prompt) tag thunk . handler)
+ (compile-call-with-prompt tag thunk handler))
+
+ ((,(typecode call/cc) . proc)
+ (compile-call/cc proc))))
+
+ (let ((proc (compile
+ (memoize-expression
+ (if (macroexpanded? exp)
+ exp
+ ((module-transformer (current-module)) exp)))))
+ (env #f))
+ (proc env)))
;;;; "format.scm" Common LISP text output formatter for SLIB
-;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011, 2012, 2013 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* ((port
(cond
- ((not destination)
- ;; Use a Unicode-capable output string port.
- (with-fluids ((%default-port-encoding "UTF-8"))
- (open-output-string)))
+ ((not destination) (open-output-string))
((boolean? destination) (current-output-port)) ; boolean but not false
((output-port? destination) destination)
((number? destination)
wrappers)
patterns))
(else
- (error "what" type val))))))))))
+ ;; Interestingly, this case can include globals (and
+ ;; global macros), now that Guile tracks which globals it
+ ;; introduces. Not sure what to do here! For now, punt.
+ ;;
+ (lp ids capture formals wrappers patterns))))))))))
(define-syntax the-environment
(lambda (x)
(syntax-rules (=>)
;; no more clauses, the match failed
((match-next v g+s)
- ;; Here we wrap error within a double set of parentheses, so that
- ;; the call to 'error' won't be in tail position. This allows the
- ;; backtrace to show the source location of the failing match form.
- ((error 'match "no matching pattern" v)))
+ ;; Here we call error in non-tail context, so that the backtrace
+ ;; can show the source location of the failing match form.
+ (begin
+ (error 'match "no matching pattern" v)
+ #f))
;; named failure continuation
((match-next v g+s (pat (=> failure) . body) . rest)
(let ((failure (lambda () (match-next v g+s . rest))))
--- /dev/null
+;;;; peg.scm --- Parsing Expression Grammar (PEG) parser generator
+;;;;
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; 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 (ice-9 peg)
+ #:use-module (ice-9 peg codegen)
+ #:use-module (ice-9 peg string-peg)
+ ;; Note: the most important effect of using string-peg is not whatever
+ ;; functions it exports, but the fact that it adds a new handler to
+ ;; peg-sexp-compile.
+ #:use-module (ice-9 peg simplify-tree)
+ #:use-module (ice-9 peg using-parsers)
+ #:use-module (ice-9 peg cache)
+ #:re-export (define-peg-pattern
+ define-peg-string-patterns
+ match-pattern
+ search-for-pattern
+ compile-peg-pattern
+ keyword-flatten
+ context-flatten
+ peg:start
+ peg:end
+ peg:string
+ peg:tree
+ peg:substring
+ peg-record?))
+
--- /dev/null
+;;;; cache.scm --- cache the results of parsing
+;;;;
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; 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 (ice-9 peg cache)
+ #:export (cg-cached-parser))
+
+;; The results of parsing using a nonterminal are cached. Think of it like a
+;; hash with no conflict resolution. Process for deciding on the cache size
+;; wasn't very scientific; just ran the benchmarks and stopped a little after
+;; the point of diminishing returns on my box.
+(define *cache-size* 512)
+
+(define (make-cache)
+ (make-vector *cache-size* #f))
+
+;; given a syntax object which is a parser function, returns syntax
+;; which, if evaluated, will become a parser function that uses a cache.
+(define (cg-cached-parser parser)
+ #`(let ((cache (make-cache)))
+ (lambda (str strlen at)
+ (let* ((vref (vector-ref cache (modulo at *cache-size*))))
+ ;; Check to see whether the value is cached.
+ (if (and vref (eq? (car vref) str) (= (cadr vref) at))
+ (caddr vref);; If it is return it.
+ (let ((fres ;; Else calculate it and cache it.
+ (#,parser str strlen at)))
+ (vector-set! cache (modulo at *cache-size*)
+ (list str at fres))
+ fres))))))
--- /dev/null
+;;;; codegen.scm --- code generation for composable parsers
+;;;;
+;;;; Copyright (C) 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; 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 (ice-9 peg codegen)
+ #:export (compile-peg-pattern wrap-parser-for-users add-peg-compiler!)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (system base pmatch))
+
+(define-syntax single?
+ (syntax-rules ()
+ "Return #t if X is a list of one element."
+ ((_ x)
+ (pmatch x
+ ((_) #t)
+ (else #f)))))
+
+(define-syntax single-filter
+ (syntax-rules ()
+ "If EXP is a list of one element, return the element. Otherwise
+return EXP."
+ ((_ exp)
+ (pmatch exp
+ ((,elt) elt)
+ (,elts elts)))))
+
+(define-syntax push-not-null!
+ (syntax-rules ()
+ "If OBJ is non-null, push it onto LST, otherwise do nothing."
+ ((_ lst obj)
+ (if (not (null? obj))
+ (push! lst obj)))))
+
+(define-syntax push!
+ (syntax-rules ()
+ "Push an object onto a list."
+ ((_ lst obj)
+ (set! lst (cons obj lst)))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; CODE GENERATORS
+;; These functions generate scheme code for parsing PEGs.
+;; Conventions:
+;; accum: (all name body none)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Code we generate will have a certain return structure depending on how we're
+;; accumulating (the ACCUM variable).
+(define (cg-generic-ret accum name body-uneval at)
+ ;; name, body-uneval and at are syntax
+ #`(let ((body #,body-uneval))
+ #,(cond
+ ((and (eq? accum 'all) name)
+ #`(list #,at
+ (cond
+ ((not (list? body)) (list '#,name body))
+ ((null? body) '#,name)
+ ((symbol? (car body)) (list '#,name body))
+ (else (cons '#,name body)))))
+ ((eq? accum 'name)
+ #`(list #,at '#,name))
+ ((eq? accum 'body)
+ #`(list #,at
+ (cond
+ ((single? body) (car body))
+ (else body))))
+ ((eq? accum 'none)
+ #`(list #,at '()))
+ (else
+ (begin
+ (pretty-print `(cg-generic-ret-error ,accum ,name ,body-uneval ,at))
+ (pretty-print "Defaulting to accum of none.\n")
+ #`(list #,at '()))))))
+
+;; The short name makes the formatting below much easier to read.
+(define cggr cg-generic-ret)
+
+;; Generates code that matches a particular string.
+;; E.g.: (cg-string syntax "abc" 'body)
+(define (cg-string pat accum)
+ (let ((plen (string-length pat)))
+ #`(lambda (str len pos)
+ (let ((end (+ pos #,plen)))
+ (and (<= end len)
+ (string= str #,pat pos end)
+ #,(case accum
+ ((all) #`(list end (list 'cg-string #,pat)))
+ ((name) #`(list end 'cg-string))
+ ((body) #`(list end #,pat))
+ ((none) #`(list end '()))
+ (else (error "bad accum" accum))))))))
+
+;; Generates code for matching any character.
+;; E.g.: (cg-peg-any syntax 'body)
+(define (cg-peg-any accum)
+ #`(lambda (str len pos)
+ (and (< pos len)
+ #,(case accum
+ ((all) #`(list (1+ pos)
+ (list 'cg-peg-any (substring str pos (1+ pos)))))
+ ((name) #`(list (1+ pos) 'cg-peg-any))
+ ((body) #`(list (1+ pos) (substring str pos (1+ pos))))
+ ((none) #`(list (1+ pos) '()))
+ (else (error "bad accum" accum))))))
+
+;; Generates code for matching a range of characters between start and end.
+;; E.g.: (cg-range syntax #\a #\z 'body)
+(define (cg-range pat accum)
+ (syntax-case pat ()
+ ((start end)
+ (if (not (and (char? (syntax->datum #'start))
+ (char? (syntax->datum #'end))))
+ (error "range PEG should have characters after it; instead got"
+ #'start #'end))
+ #`(lambda (str len pos)
+ (and (< pos len)
+ (let ((c (string-ref str pos)))
+ (and (char>=? c start)
+ (char<=? c end)
+ #,(case accum
+ ((all) #`(list (1+ pos) (list 'cg-range (string c))))
+ ((name) #`(list (1+ pos) 'cg-range))
+ ((body) #`(list (1+ pos) (string c)))
+ ((none) #`(list (1+ pos) '()))
+ (else (error "bad accum" accum))))))))))
+
+;; Generate code to match a pattern and do nothing with the result
+(define (cg-ignore pat accum)
+ (syntax-case pat ()
+ ((inner)
+ (compile-peg-pattern #'inner 'none))))
+
+(define (cg-capture pat accum)
+ (syntax-case pat ()
+ ((inner)
+ (compile-peg-pattern #'inner 'body))))
+
+;; Filters the accum argument to compile-peg-pattern for buildings like string
+;; literals (since we don't want to tag them with their name if we're doing an
+;; "all" accum).
+(define (builtin-accum-filter accum)
+ (cond
+ ((eq? accum 'all) 'body)
+ ((eq? accum 'name) 'name)
+ ((eq? accum 'body) 'body)
+ ((eq? accum 'none) 'none)))
+(define baf builtin-accum-filter)
+
+;; Top-level function builder for AND. Reduces to a call to CG-AND-INT.
+(define (cg-and clauses accum)
+ #`(lambda (str len pos)
+ (let ((body '()))
+ #,(cg-and-int clauses (baf accum) #'str #'len #'pos #'body))))
+
+;; Internal function builder for AND (calls itself).
+(define (cg-and-int clauses accum str strlen at body)
+ (syntax-case clauses ()
+ (()
+ (cggr accum 'cg-and #`(reverse #,body) at))
+ ((first rest ...)
+ #`(let ((res (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at)))
+ (and res
+ ;; update AT and BODY then recurse
+ (let ((newat (car res))
+ (newbody (cadr res)))
+ (set! #,at newat)
+ (push-not-null! #,body (single-filter newbody))
+ #,(cg-and-int #'(rest ...) accum str strlen at body)))))))
+
+;; Top-level function builder for OR. Reduces to a call to CG-OR-INT.
+(define (cg-or clauses accum)
+ #`(lambda (str len pos)
+ #,(cg-or-int clauses (baf accum) #'str #'len #'pos)))
+
+;; Internal function builder for OR (calls itself).
+(define (cg-or-int clauses accum str strlen at)
+ (syntax-case clauses ()
+ (()
+ #f)
+ ((first rest ...)
+ #`(or (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at)
+ #,(cg-or-int #'(rest ...) accum str strlen at)))))
+
+(define (cg-* args accum)
+ (syntax-case args ()
+ ((pat)
+ #`(lambda (str strlen at)
+ (let ((body '()))
+ (let lp ((end at) (count 0))
+ (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
+ str strlen end))
+ (new-end (if match (car match) end))
+ (count (if (> new-end end) (1+ count) count)))
+ (if (> new-end end)
+ (push-not-null! body (single-filter (cadr match))))
+ (if (and (> new-end end)
+ #,#t)
+ (lp new-end count)
+ (let ((success #,#t))
+ #,#`(and success
+ #,(cggr (baf accum) 'cg-body
+ #'(reverse body) #'new-end)))))))))))
+
+(define (cg-+ args accum)
+ (syntax-case args ()
+ ((pat)
+ #`(lambda (str strlen at)
+ (let ((body '()))
+ (let lp ((end at) (count 0))
+ (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
+ str strlen end))
+ (new-end (if match (car match) end))
+ (count (if (> new-end end) (1+ count) count)))
+ (if (> new-end end)
+ (push-not-null! body (single-filter (cadr match))))
+ (if (and (> new-end end)
+ #,#t)
+ (lp new-end count)
+ (let ((success #,#'(>= count 1)))
+ #,#`(and success
+ #,(cggr (baf accum) 'cg-body
+ #'(reverse body) #'new-end)))))))))))
+
+(define (cg-? args accum)
+ (syntax-case args ()
+ ((pat)
+ #`(lambda (str strlen at)
+ (let ((body '()))
+ (let lp ((end at) (count 0))
+ (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
+ str strlen end))
+ (new-end (if match (car match) end))
+ (count (if (> new-end end) (1+ count) count)))
+ (if (> new-end end)
+ (push-not-null! body (single-filter (cadr match))))
+ (if (and (> new-end end)
+ #,#'(< count 1))
+ (lp new-end count)
+ (let ((success #,#t))
+ #,#`(and success
+ #,(cggr (baf accum) 'cg-body
+ #'(reverse body) #'new-end)))))))))))
+
+(define (cg-followed-by args accum)
+ (syntax-case args ()
+ ((pat)
+ #`(lambda (str strlen at)
+ (let ((body '()))
+ (let lp ((end at) (count 0))
+ (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
+ str strlen end))
+ (new-end (if match (car match) end))
+ (count (if (> new-end end) (1+ count) count)))
+ (if (> new-end end)
+ (push-not-null! body (single-filter (cadr match))))
+ (if (and (> new-end end)
+ #,#'(< count 1))
+ (lp new-end count)
+ (let ((success #,#'(= count 1)))
+ #,#`(and success
+ #,(cggr (baf accum) 'cg-body #''() #'at)))))))))))
+
+(define (cg-not-followed-by args accum)
+ (syntax-case args ()
+ ((pat)
+ #`(lambda (str strlen at)
+ (let ((body '()))
+ (let lp ((end at) (count 0))
+ (let* ((match (#,(compile-peg-pattern #'pat (baf accum))
+ str strlen end))
+ (new-end (if match (car match) end))
+ (count (if (> new-end end) (1+ count) count)))
+ (if (> new-end end)
+ (push-not-null! body (single-filter (cadr match))))
+ (if (and (> new-end end)
+ #,#'(< count 1))
+ (lp new-end count)
+ (let ((success #,#'(= count 1)))
+ #,#`(if success
+ #f
+ #,(cggr (baf accum) 'cg-body #''() #'at)))))))))))
+
+;; Association list of functions to handle different expressions as PEGs
+(define peg-compiler-alist '())
+
+(define (add-peg-compiler! symbol function)
+ (set! peg-compiler-alist
+ (assq-set! peg-compiler-alist symbol function)))
+
+(add-peg-compiler! 'range cg-range)
+(add-peg-compiler! 'ignore cg-ignore)
+(add-peg-compiler! 'capture cg-capture)
+(add-peg-compiler! 'and cg-and)
+(add-peg-compiler! 'or cg-or)
+(add-peg-compiler! '* cg-*)
+(add-peg-compiler! '+ cg-+)
+(add-peg-compiler! '? cg-?)
+(add-peg-compiler! 'followed-by cg-followed-by)
+(add-peg-compiler! 'not-followed-by cg-not-followed-by)
+
+;; Takes an arbitrary expressions and accumulation variable, then parses it.
+;; E.g.: (compile-peg-pattern syntax '(and "abc" (or "-" (range #\a #\z))) 'all)
+(define (compile-peg-pattern pat accum)
+ (syntax-case pat (peg-any)
+ (peg-any
+ (cg-peg-any (baf accum)))
+ (sym (identifier? #'sym) ;; nonterminal
+ #'sym)
+ (str (string? (syntax->datum #'str)) ;; literal string
+ (cg-string (syntax->datum #'str) (baf accum)))
+ ((name . args) (let* ((nm (syntax->datum #'name))
+ (entry (assq-ref peg-compiler-alist nm)))
+ (if entry
+ (entry #'args accum)
+ (error "Bad peg form" nm #'args
+ "Not one of" (map car peg-compiler-alist)))))))
+
+;; Packages the results of a parser
+(define (wrap-parser-for-users for-syntax parser accumsym s-syn)
+ #`(lambda (str strlen at)
+ (let ((res (#,parser str strlen at)))
+ ;; Try to match the nonterminal.
+ (if res
+ ;; If we matched, do some post-processing to figure out
+ ;; what data to propagate upward.
+ (let ((at (car res))
+ (body (cadr res)))
+ #,(cond
+ ((eq? accumsym 'name)
+ #`(list at '#,s-syn))
+ ((eq? accumsym 'all)
+ #`(list (car res)
+ (cond
+ ((not (list? body))
+ (list '#,s-syn body))
+ ((null? body) '#,s-syn)
+ ((symbol? (car body))
+ (list '#,s-syn body))
+ (else (cons '#,s-syn body)))))
+ ((eq? accumsym 'none) #`(list (car res) '()))
+ (else #`(begin res))))
+ ;; If we didn't match, just return false.
+ #f))))
--- /dev/null
+;;;; simplify-tree.scm --- utility functions for the PEG parser
+;;;;
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; 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 (ice-9 peg simplify-tree)
+ #:export (keyword-flatten context-flatten string-collapse)
+ #:use-module (system base pmatch))
+
+(define-syntax single?
+ (syntax-rules ()
+ "Return #t if X is a list of one element."
+ ((_ x)
+ (pmatch x
+ ((_) #t)
+ (else #f)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Is everything in LST true?
+(define (andlst lst)
+ (or (null? lst)
+ (and (car lst) (andlst (cdr lst)))))
+
+;; Is LST a list of strings?
+(define (string-list? lst)
+ (and (list? lst) (not (null? lst))
+ (andlst (map string? lst))))
+
+;; Groups all strings that are next to each other in LST. Used in
+;; STRING-COLLAPSE.
+(define (string-group lst)
+ (if (not (list? lst))
+ lst
+ (if (null? lst)
+ '()
+ (let ((next (string-group (cdr lst))))
+ (if (not (string? (car lst)))
+ (cons (car lst) next)
+ (if (and (not (null? next))
+ (list? (car next))
+ (string? (caar next)))
+ (cons (cons (car lst) (car next)) (cdr next))
+ (cons (list (car lst)) next)))))))
+
+
+;; Collapses all the string in LST.
+;; ("a" "b" (c d) "e" "f") -> ("ab" (c d) "ef")
+(define (string-collapse lst)
+ (if (list? lst)
+ (let ((res (map (lambda (x) (if (string-list? x)
+ (apply string-append x)
+ x))
+ (string-group (map string-collapse lst)))))
+ (if (single? res) (car res) res))
+ lst))
+
+;; If LST is an atom, return (list LST), else return LST.
+(define (mklst lst)
+ (if (not (list? lst)) (list lst) lst))
+
+;; Takes a list and "flattens" it, using the predicate TST to know when to stop
+;; instead of terminating on atoms (see tutorial).
+(define (context-flatten tst lst)
+ (if (or (not (list? lst)) (null? lst))
+ lst
+ (if (tst lst)
+ (list lst)
+ (apply append
+ (map (lambda (x) (mklst (context-flatten tst x)))
+ lst)))))
+
+;; Takes a list and "flattens" it, using the list of keywords KEYWORD-LST to
+;; know when to stop at (see tutorial).
+(define (keyword-flatten keyword-lst lst)
+ (context-flatten
+ (lambda (x)
+ (if (or (not (list? x)) (null? x))
+ #t
+ (member (car x) keyword-lst)))
+ lst))
--- /dev/null
+;;;; string-peg.scm --- representing PEG grammars as strings
+;;;;
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; 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 (ice-9 peg string-peg)
+ #:export (peg-as-peg
+ define-peg-string-patterns
+ peg-grammar)
+ #:use-module (ice-9 peg using-parsers)
+ #:use-module (ice-9 peg codegen)
+ #:use-module (ice-9 peg simplify-tree))
+
+;; Gets the left-hand depth of a list.
+(define (depth lst)
+ (if (or (not (list? lst)) (null? lst))
+ 0
+ (+ 1 (depth (car lst)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; Parse string PEGs using sexp PEGs.
+;; See the variable PEG-AS-PEG for an easier-to-read syntax.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Grammar for PEGs in PEG grammar.
+(define peg-as-peg
+"grammar <-- (nonterminal ('<--' / '<-' / '<') sp pattern)+
+pattern <-- alternative (SLASH sp alternative)*
+alternative <-- ([!&]? sp suffix)+
+suffix <-- primary ([*+?] sp)*
+primary <-- '(' sp pattern ')' sp / '.' sp / literal / charclass / nonterminal !'<'
+literal <-- ['] (!['] .)* ['] sp
+charclass <-- LB (!']' (CCrange / CCsingle))* RB sp
+CCrange <-- . '-' .
+CCsingle <-- .
+nonterminal <-- [a-zA-Z0-9-]+ sp
+sp < [ \t\n]*
+SLASH < '/'
+LB < '['
+RB < ']'
+")
+
+(define-syntax define-sexp-parser
+ (lambda (x)
+ (syntax-case x ()
+ ((_ sym accum pat)
+ (let* ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum)))
+ (accumsym (syntax->datum #'accum))
+ (syn (wrap-parser-for-users x matchf accumsym #'sym)))
+ #`(define sym #,syn))))))
+
+(define-sexp-parser peg-grammar all
+ (+ (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern)))
+(define-sexp-parser peg-pattern all
+ (and peg-alternative
+ (* (and (ignore "/") peg-sp peg-alternative))))
+(define-sexp-parser peg-alternative all
+ (+ (and (? (or "!" "&")) peg-sp peg-suffix)))
+(define-sexp-parser peg-suffix all
+ (and peg-primary (* (and (or "*" "+" "?") peg-sp))))
+(define-sexp-parser peg-primary all
+ (or (and "(" peg-sp peg-pattern ")" peg-sp)
+ (and "." peg-sp)
+ peg-literal
+ peg-charclass
+ (and peg-nonterminal (not-followed-by "<"))))
+(define-sexp-parser peg-literal all
+ (and "'" (* (and (not-followed-by "'") peg-any)) "'" peg-sp))
+(define-sexp-parser peg-charclass all
+ (and (ignore "[")
+ (* (and (not-followed-by "]")
+ (or charclass-range charclass-single)))
+ (ignore "]")
+ peg-sp))
+(define-sexp-parser charclass-range all (and peg-any "-" peg-any))
+(define-sexp-parser charclass-single all peg-any)
+(define-sexp-parser peg-nonterminal all
+ (and (+ (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-")) peg-sp))
+(define-sexp-parser peg-sp none
+ (* (or " " "\t" "\n")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PARSE STRING PEGS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Takes a string representing a PEG grammar and returns syntax that
+;; will define all of the nonterminals in the grammar with equivalent
+;; PEG s-expressions.
+(define (peg-parser str for-syntax)
+ (let ((parsed (match-pattern peg-grammar str)))
+ (if (not parsed)
+ (begin
+ ;; (display "Invalid PEG grammar!\n")
+ #f)
+ (let ((lst (peg:tree parsed)))
+ (cond
+ ((or (not (list? lst)) (null? lst))
+ lst)
+ ((eq? (car lst) 'peg-grammar)
+ #`(begin
+ #,@(map (lambda (x) (peg-nonterm->defn x for-syntax))
+ (context-flatten (lambda (lst) (<= (depth lst) 2))
+ (cdr lst))))))))))
+
+;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and
+;; defines all the appropriate nonterminals.
+(define-syntax define-peg-string-patterns
+ (lambda (x)
+ (syntax-case x ()
+ ((_ str)
+ (peg-parser (syntax->datum #'str) x)))))
+
+;; lst has format (nonterm grabber pattern), where
+;; nonterm is a symbol (the name of the nonterminal),
+;; grabber is a string (either "<", "<-" or "<--"), and
+;; pattern is the parse of a PEG pattern expressed as as string.
+(define (peg-nonterm->defn lst for-syntax)
+ (let* ((nonterm (car lst))
+ (grabber (cadr lst))
+ (pattern (caddr lst))
+ (nonterm-name (datum->syntax for-syntax
+ (string->symbol (cadr nonterm)))))
+ #`(define-peg-pattern #,nonterm-name
+ #,(cond
+ ((string=? grabber "<--") (datum->syntax for-syntax 'all))
+ ((string=? grabber "<-") (datum->syntax for-syntax 'body))
+ (else (datum->syntax for-syntax 'none)))
+ #,(compressor (peg-pattern->defn pattern for-syntax) for-syntax))))
+
+;; lst has format ('peg-pattern ...).
+;; After the context-flatten, (cdr lst) has format
+;; (('peg-alternative ...) ...), where the outer list is a collection
+;; of elements from a '/' alternative.
+(define (peg-pattern->defn lst for-syntax)
+ #`(or #,@(map (lambda (x) (peg-alternative->defn x for-syntax))
+ (context-flatten (lambda (x) (eq? (car x) 'peg-alternative))
+ (cdr lst)))))
+
+;; lst has format ('peg-alternative ...).
+;; After the context-flatten, (cdr lst) has the format
+;; (item ...), where each item has format either ("!" ...), ("&" ...),
+;; or ('peg-suffix ...).
+(define (peg-alternative->defn lst for-syntax)
+ #`(and #,@(map (lambda (x) (peg-body->defn x for-syntax))
+ (context-flatten (lambda (x) (or (string? (car x))
+ (eq? (car x) 'peg-suffix)))
+ (cdr lst)))))
+
+;; lst has the format either
+;; ("!" ('peg-suffix ...)), ("&" ('peg-suffix ...)), or
+;; ('peg-suffix ...).
+(define (peg-body->defn lst for-syntax)
+ (cond
+ ((equal? (car lst) "&")
+ #`(followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
+ ((equal? (car lst) "!")
+ #`(not-followed-by #,(peg-suffix->defn (cadr lst) for-syntax)))
+ ((eq? (car lst) 'peg-suffix)
+ (peg-suffix->defn lst for-syntax))
+ (else `(peg-parse-body-fail ,lst))))
+
+;; lst has format ('peg-suffix <peg-primary> (? (/ "*" "?" "+")))
+(define (peg-suffix->defn lst for-syntax)
+ (let ((inner-defn (peg-primary->defn (cadr lst) for-syntax)))
+ (cond
+ ((null? (cddr lst))
+ inner-defn)
+ ((equal? (caddr lst) "*")
+ #`(* #,inner-defn))
+ ((equal? (caddr lst) "?")
+ #`(? #,inner-defn))
+ ((equal? (caddr lst) "+")
+ #`(+ #,inner-defn)))))
+
+;; Parse a primary.
+(define (peg-primary->defn lst for-syntax)
+ (let ((el (cadr lst)))
+ (cond
+ ((list? el)
+ (cond
+ ((eq? (car el) 'peg-literal)
+ (peg-literal->defn el for-syntax))
+ ((eq? (car el) 'peg-charclass)
+ (peg-charclass->defn el for-syntax))
+ ((eq? (car el) 'peg-nonterminal)
+ (datum->syntax for-syntax (string->symbol (cadr el))))))
+ ((string? el)
+ (cond
+ ((equal? el "(")
+ (peg-pattern->defn (caddr lst) for-syntax))
+ ((equal? el ".")
+ (datum->syntax for-syntax 'peg-any))
+ (else (datum->syntax for-syntax
+ `(peg-parse-any unknown-string ,lst)))))
+ (else (datum->syntax for-syntax
+ `(peg-parse-any unknown-el ,lst))))))
+
+;; Trims characters off the front and end of STR.
+;; (trim-1chars "'ab'") -> "ab"
+(define (trim-1chars str) (substring str 1 (- (string-length str) 1)))
+
+;; Parses a literal.
+(define (peg-literal->defn lst for-syntax)
+ (datum->syntax for-syntax (trim-1chars (cadr lst))))
+
+;; Parses a charclass.
+(define (peg-charclass->defn lst for-syntax)
+ #`(or
+ #,@(map
+ (lambda (cc)
+ (cond
+ ((eq? (car cc) 'charclass-range)
+ #`(range #,(datum->syntax
+ for-syntax
+ (string-ref (cadr cc) 0))
+ #,(datum->syntax
+ for-syntax
+ (string-ref (cadr cc) 2))))
+ ((eq? (car cc) 'charclass-single)
+ (datum->syntax for-syntax (cadr cc)))))
+ (context-flatten
+ (lambda (x) (or (eq? (car x) 'charclass-range)
+ (eq? (car x) 'charclass-single)))
+ (cdr lst)))))
+
+;; Compresses a list to save the optimizer work.
+;; e.g. (or (and a)) -> a
+(define (compressor-core lst)
+ (if (or (not (list? lst)) (null? lst))
+ lst
+ (cond
+ ((and (or (eq? (car lst) 'or) (eq? (car lst) 'and))
+ (null? (cddr lst)))
+ (compressor-core (cadr lst)))
+ ((and (eq? (car lst) 'body)
+ (eq? (cadr lst) 'lit)
+ (eq? (cadddr lst) 1))
+ (compressor-core (caddr lst)))
+ (else (map compressor-core lst)))))
+
+(define (compressor syn for-syntax)
+ (datum->syntax for-syntax
+ (compressor-core (syntax->datum syn))))
+
+;; Builds a lambda-expressions for the pattern STR using accum.
+(define (peg-string-compile args accum)
+ (syntax-case args ()
+ ((str-stx) (string? (syntax->datum #'str-stx))
+ (let ((string (syntax->datum #'str-stx)))
+ (compile-peg-pattern
+ (compressor
+ (peg-pattern->defn
+ (peg:tree (match-pattern peg-pattern string)) #'str-stx)
+ #'str-stx)
+ (if (eq? accum 'all) 'body accum))))
+ (else (error "Bad embedded PEG string" args))))
+
+(add-peg-compiler! 'peg peg-string-compile)
+
--- /dev/null
+;;;; using-parsers.scm --- utilities to make using parsers easier
+;;;;
+;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; 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 (ice-9 peg using-parsers)
+ #:use-module (ice-9 peg simplify-tree)
+ #:use-module (ice-9 peg codegen)
+ #:use-module (ice-9 peg cache)
+ #:export (match-pattern define-peg-pattern search-for-pattern
+ prec make-prec peg:start peg:end peg:string
+ peg:tree peg:substring peg-record?))
+
+;;;
+;;; Helper Macros
+;;;
+
+(define-syntax until
+ (syntax-rules ()
+ "Evaluate TEST. If it is true, return its value. Otherwise,
+execute the STMTs and try again."
+ ((_ test stmt stmt* ...)
+ (let lp ()
+ (or test
+ (begin stmt stmt* ... (lp)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; FOR DEFINING AND USING NONTERMINALS
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Parses STRING using NONTERM
+(define (match-pattern nonterm string)
+ ;; We copy the string before using it because it might have been modified
+ ;; in-place since the last time it was parsed, which would invalidate the
+ ;; cache. Guile uses copy-on-write for strings, so this is fast.
+ (let ((res (nonterm (string-copy string) (string-length string) 0)))
+ (if (not res)
+ #f
+ (make-prec 0 (car res) string (string-collapse (cadr res))))))
+
+;; Defines a new nonterminal symbol accumulating with ACCUM.
+(define-syntax define-peg-pattern
+ (lambda (x)
+ (syntax-case x ()
+ ((_ sym accum pat)
+ (let ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum)))
+ (accumsym (syntax->datum #'accum)))
+ ;; CODE is the code to parse the string if the result isn't cached.
+ (let ((syn (wrap-parser-for-users x matchf accumsym #'sym)))
+ #`(define sym #,(cg-cached-parser syn))))))))
+
+(define (peg-like->peg pat)
+ (syntax-case pat ()
+ (str (string? (syntax->datum #'str)) #'(peg str))
+ (else pat)))
+
+;; Searches through STRING for something that parses to PEG-MATCHER. Think
+;; regexp search.
+(define-syntax search-for-pattern
+ (lambda (x)
+ (syntax-case x ()
+ ((_ pattern string-uncopied)
+ (let ((pmsym (syntax->datum #'pattern)))
+ (let ((matcher (compile-peg-pattern (peg-like->peg #'pattern) 'body)))
+ ;; We copy the string before using it because it might have been
+ ;; modified in-place since the last time it was parsed, which would
+ ;; invalidate the cache. Guile uses copy-on-write for strings, so
+ ;; this is fast.
+ #`(let ((string (string-copy string-uncopied))
+ (strlen (string-length string-uncopied))
+ (at 0))
+ (let ((ret (until (or (>= at strlen)
+ (#,matcher string strlen at))
+ (set! at (+ at 1)))))
+ (if (eq? ret #t) ;; (>= at strlen) succeeded
+ #f
+ (let ((end (car ret))
+ (match (cadr ret)))
+ (make-prec
+ at end string
+ (string-collapse match))))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PMATCH STRUCTURE MUNGING
+;; Pretty self-explanatory.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define prec
+ (make-record-type "peg" '(start end string tree)))
+(define make-prec
+ (record-constructor prec '(start end string tree)))
+(define (peg:start pm)
+ (if pm ((record-accessor prec 'start) pm) #f))
+(define (peg:end pm)
+ (if pm ((record-accessor prec 'end) pm) #f))
+(define (peg:string pm)
+ (if pm ((record-accessor prec 'string) pm) #f))
+(define (peg:tree pm)
+ (if pm ((record-accessor prec 'tree) pm) #f))
+(define (peg:substring pm)
+ (if pm (substring (peg:string pm) (peg:start pm) (peg:end pm)) #f))
+(define peg-record? (record-predicate prec))
;; poll
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(off (pollfd-offset idx))
(fd (if (integer? fd-or-port)
fd-or-port
- (port->fdes fd-or-port))))
-
- (if (port? fd-or-port)
- ;; As we store the port in the fdset, there is no need to
- ;; increment the revealed count to prevent the fd from being
- ;; closed by a gc'd port.
- (release-port-handle fd-or-port))
+ (fileno fd-or-port))))
(ensure-pset-size! set (1+ idx))
(bytevector-s32-native-set! (pset-pollfds set) off fd)
;;;; -*- coding: utf-8; mode: scheme -*-
;;;;
;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010,
-;;;; 2012, 2014 Free Software Foundation, Inc.
+;;;; 2012, 2013, 2014 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
\"ration\" the available width, trying to allocate it equally to each
sub-expression, via the @var{breadth-first?} keyword argument."
- ;; Make sure string ports are created with the right encoding.
- (with-fluids ((%default-port-encoding (port-encoding port)))
-
- (define ellipsis
- ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
- ;; on the encoding of PORT.
- (let ((e "…"))
- (catch 'encoding-error
- (lambda ()
- (with-fluids ((%default-port-conversion-strategy 'error))
- (with-output-to-string
- (lambda ()
- (display e)))))
- (lambda (key . args)
- "..."))))
-
- (let ((ellipsis-width (string-length ellipsis)))
-
- (define (print-sequence x width len ref next)
- (let lp ((x x)
- (width width)
- (i 0))
- (if (> i 0)
- (display #\space))
- (cond
- ((= i len)) ; catches 0-length case
- ((and (= i (1- len)) (or (zero? i) (> width 1)))
- (print (ref x i) (if (zero? i) width (1- width))))
- ((<= width (+ 1 ellipsis-width))
- (display ellipsis))
- (else
- (let ((str
- (with-fluids ((%default-port-encoding (port-encoding port)))
- (with-output-to-string
- (lambda ()
- (print (ref x i)
- (if breadth-first?
- (max 1
- (1- (floor (/ width (- len i)))))
- (- width (+ 1 ellipsis-width)))))))))
- (display str)
- (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
-
- (define (print-tree x width)
- ;; width is >= the width of # . #, which is 5
- (let lp ((x x)
- (width width))
- (cond
- ((or (not (pair? x)) (<= width 4))
- (display ". ")
- (print x (- width 2)))
- (else
- ;; width >= 5
- (let ((str (with-output-to-string
- (lambda ()
- (print (car x)
- (if breadth-first?
- (floor (/ (- width 3) 2))
- (- width 4)))))))
- (display str)
- (display " ")
- (lp (cdr x) (- width 1 (string-length str))))))))
-
- (define (truncate-string str width)
- ;; width is < (string-length str)
- (let lp ((fixes '(("#<" . ">")
- ("#(" . ")")
- ("(" . ")")
- ("\"" . "\""))))
- (cond
- ((null? fixes)
- "#")
- ((and (string-prefix? (caar fixes) str)
- (string-suffix? (cdar fixes) str)
- (>= (string-length str)
- width
- (+ (string-length (caar fixes))
- (string-length (cdar fixes))
- ellipsis-width)))
- (format #f "~a~a~a~a"
- (caar fixes)
- (substring str (string-length (caar fixes))
- (- width (string-length (cdar fixes))
- ellipsis-width))
- ellipsis
- (cdar fixes)))
- (else
- (lp (cdr fixes))))))
-
- (define (print x width)
+ (define ellipsis
+ ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
+ ;; on the encoding of PORT.
+ (let ((e "…"))
+ (catch 'encoding-error
+ (lambda ()
+ (with-fluids ((%default-port-conversion-strategy 'error))
+ (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p (port-encoding port))
+ (display e p)))))
+ (lambda (key . args)
+ "..."))))
+
+ (let ((ellipsis-width (string-length ellipsis)))
+
+ (define (print-sequence x width len ref next)
+ (let lp ((x x)
+ (width width)
+ (i 0))
+ (if (> i 0)
+ (display #\space))
(cond
- ((<= width 0)
- (error "expected a positive width" width))
- ((list? x)
- (cond
- ((>= width (+ 2 ellipsis-width))
- (display "(")
- (print-sequence x (- width 2) (length x)
- (lambda (x i) (car x)) cdr)
- (display ")"))
- (else
- (display "#"))))
- ((vector? x)
- (cond
- ((>= width (+ 3 ellipsis-width))
- (display "#(")
- (print-sequence x (- width 3) (vector-length x)
- vector-ref identity)
- (display ")"))
- (else
- (display "#"))))
- ((bytevector? x)
- (cond
- ((>= width 9)
- (format #t "#~a(" (array-type x))
- (print-sequence x (- width 6) (array-length x)
- array-ref identity)
- (display ")"))
- (else
- (display "#"))))
- ((pair? x)
- (cond
- ((>= width (+ 4 ellipsis-width))
- (display "(")
- (print-tree x (- width 2))
- (display ")"))
- (else
- (display "#"))))
+ ((= i len)) ; catches 0-length case
+ ((and (= i (1- len)) (or (zero? i) (> width 1)))
+ (print (ref x i) (if (zero? i) width (1- width))))
+ ((<= width (+ 1 ellipsis-width))
+ (display ellipsis))
(else
- (let* ((str (with-output-to-string
- (lambda () (if display? (display x) (write x)))))
- (len (string-length str)))
- (display (if (<= (string-length str) width)
- str
- (truncate-string str width)))))))
-
- (with-output-to-port port
- (lambda ()
- (print x width))))))
+ (let ((str (with-output-to-string
+ (lambda ()
+ (print (ref x i)
+ (if breadth-first?
+ (max 1
+ (1- (floor (/ width (- len i)))))
+ (- width (+ 1 ellipsis-width))))))))
+ (display str)
+ (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
+
+ (define (print-tree x width)
+ ;; width is >= the width of # . #, which is 5
+ (let lp ((x x)
+ (width width))
+ (cond
+ ((or (not (pair? x)) (<= width 4))
+ (display ". ")
+ (print x (- width 2)))
+ (else
+ ;; width >= 5
+ (let ((str (with-output-to-string
+ (lambda ()
+ (print (car x)
+ (if breadth-first?
+ (floor (/ (- width 3) 2))
+ (- width 4)))))))
+ (display str)
+ (display " ")
+ (lp (cdr x) (- width 1 (string-length str))))))))
+
+ (define (truncate-string str width)
+ ;; width is < (string-length str)
+ (let lp ((fixes '(("#<" . ">")
+ ("#(" . ")")
+ ("(" . ")")
+ ("\"" . "\""))))
+ (cond
+ ((null? fixes)
+ "#")
+ ((and (string-prefix? (caar fixes) str)
+ (string-suffix? (cdar fixes) str)
+ (>= (string-length str)
+ width
+ (+ (string-length (caar fixes))
+ (string-length (cdar fixes))
+ ellipsis-width)))
+ (format #f "~a~a~a~a"
+ (caar fixes)
+ (substring str (string-length (caar fixes))
+ (- width (string-length (cdar fixes))
+ ellipsis-width))
+ ellipsis
+ (cdar fixes)))
+ (else
+ (lp (cdr fixes))))))
+
+ (define (print x width)
+ (cond
+ ((<= width 0)
+ (error "expected a positive width" width))
+ ((list? x)
+ (cond
+ ((>= width (+ 2 ellipsis-width))
+ (display "(")
+ (print-sequence x (- width 2) (length x)
+ (lambda (x i) (car x)) cdr)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((vector? x)
+ (cond
+ ((>= width (+ 3 ellipsis-width))
+ (display "#(")
+ (print-sequence x (- width 3) (vector-length x)
+ vector-ref identity)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((bytevector? x)
+ (cond
+ ((>= width 9)
+ (format #t "#~a(" (array-type x))
+ (print-sequence x (- width 6) (array-length x)
+ array-ref identity)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((pair? x)
+ (cond
+ ((>= width (+ 4 ellipsis-width))
+ (display "(")
+ (print-tree x (- width 2))
+ (display ")"))
+ (else
+ (display "#"))))
+ (else
+ (let* ((str (with-output-to-string
+ (lambda () (if display? (display x) (write x)))))
+ (len (string-length str)))
+ (display (if (<= (string-length str) width)
+ str
+ (truncate-string str width)))))))
+
+ (with-output-to-port port
+ (lambda ()
+ (print x width)))))
test
consequent
alternate)))
- (make-application
+ (make-call
(lambda (src proc args)
(make-struct (vector-ref %expanded-vtables 11) 0 src proc args)))
- (make-sequence
- (lambda (src exps)
- (make-struct (vector-ref %expanded-vtables 12) 0 src exps)))
+ (make-primcall
+ (lambda (src name args)
+ (make-struct (vector-ref %expanded-vtables 12) 0 src name args)))
+ (make-seq
+ (lambda (src head tail)
+ (make-struct (vector-ref %expanded-vtables 13) 0 src head tail)))
(make-lambda
(lambda (src meta body)
- (make-struct (vector-ref %expanded-vtables 13) 0 src meta body)))
+ (make-struct (vector-ref %expanded-vtables 14) 0 src meta body)))
(make-lambda-case
(lambda (src req opt rest kw inits gensyms body alternate)
(make-struct
- (vector-ref %expanded-vtables 14)
+ (vector-ref %expanded-vtables 15)
0
src
req
(make-let
(lambda (src names gensyms vals body)
(make-struct
- (vector-ref %expanded-vtables 15)
+ (vector-ref %expanded-vtables 16)
0
src
names
(make-letrec
(lambda (src in-order? names gensyms vals body)
(make-struct
- (vector-ref %expanded-vtables 16)
+ (vector-ref %expanded-vtables 17)
0
src
in-order?
gensyms
vals
body)))
- (make-dynlet
- (lambda (src fluids vals body)
- (make-struct
- (vector-ref %expanded-vtables 17)
- 0
- src
- fluids
- vals
- body)))
(lambda?
(lambda (x)
(and (struct? x)
- (eq? (struct-vtable x) (vector-ref %expanded-vtables 13)))))
+ (eq? (struct-vtable x) (vector-ref %expanded-vtables 14)))))
(lambda-meta (lambda (x) (struct-ref x 1)))
(set-lambda-meta! (lambda (x v) (struct-set! x 1 v)))
(top-level-eval-hook (lambda (x mod) (primitive-eval x)))
(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)
- (macro-type val)
- (cons (macro-type val) (macro-binding val))))))))
+ (and (not (equal? module '(primitive)))
+ (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)
+ (macro-type val)
+ (cons (macro-type val) (macro-binding val)))))))))
(decorate-source
(lambda (e s)
(if (and s (supports-source-properties? e))
(if (not (assq 'name meta))
(set-lambda-meta! val (acons 'name name meta)))))))
(build-void (lambda (source) (make-void source)))
- (build-application
+ (build-call
(lambda (source fun-exp arg-exps)
- (make-application source fun-exp arg-exps)))
+ (make-call source fun-exp arg-exps)))
(build-conditional
(lambda (source test-exp then-exp else-exp)
(make-conditional source test-exp then-exp else-exp)))
- (build-dynlet
- (lambda (source fluids vals body)
- (make-dynlet source fluids vals body)))
(build-lexical-reference
(lambda (type source name var) (make-lexical-ref source name var)))
(build-lexical-assignment
(module-variable (resolve-module mod) var))
(modref-cont mod var #f)
(bare-cont var)))
+ ((memv key '(primitive))
+ (syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod))))))))
(build-global-reference
(lambda (source var mod)
(build-lambda-case
(lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case src req opt rest kw inits vars body else-case)))
- (build-primref
- (lambda (src name)
- (if (equal? (module-name (current-module)) '(guile))
- (make-toplevel-ref src name)
- (make-module-ref src '(guile) name #f))))
+ (build-primcall
+ (lambda (src name args) (make-primcall src name args)))
+ (build-primref (lambda (src name) (make-primitive-ref src name)))
(build-data (lambda (src exp) (make-const src exp)))
(build-sequence
(lambda (src exps)
- (if (null? (cdr exps)) (car exps) (make-sequence src exps))))
+ (if (null? (cdr exps))
+ (car exps)
+ (make-seq src (car exps) (build-sequence #f (cdr exps))))))
(build-let
(lambda (src ids vars val-exps body-exp)
(for-each maybe-name-value! ids val-exps)
(list f-name)
(list f)
(list proc)
- (build-application
- src
- (build-lexical-reference 'fun src f-name f)
- val-exps))))))
+ (build-call src (build-lexical-reference 'fun src f-name f) val-exps))))))
(build-letrec
(lambda (src in-order? ids vars val-exps body-exp)
(if (null? vars)
(if (null? r)
'()
(let ((a (car r)))
- (if (memq (cadr a) '(macro ellipsis))
+ (if (memq (cadr a) '(macro syntax-parameter ellipsis))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
- (lookup
- (lambda (x r mod)
- (let ((t (assq x r)))
- (cond (t (cdr t))
- ((symbol? x) (or (get-global-definition-hook x mod) '(global)))
- (else '(displaced-lexical))))))
(global-extend
(lambda (type sym val) (put-global-definition-hook sym type val)))
(nonsymbol-id?
(eq? (car x) (car y))
(same-marks? (cdr x) (cdr y))))))
(id-var-name
- (lambda (id w)
+ (lambda (id w mod)
(letrec*
((search
- (lambda (sym subst marks)
+ (lambda (sym subst marks mod)
(if (null? subst)
(values #f marks)
(let ((fst (car subst)))
(if (eq? fst 'shift)
- (search sym (cdr subst) (cdr marks))
+ (search sym (cdr subst) (cdr marks) mod)
(let ((symnames (ribcage-symnames fst)))
(if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))))))
+ (search-vector-rib sym subst marks symnames fst mod)
+ (search-list-rib sym subst marks symnames fst mod))))))))
(search-list-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let f ((symnames symnames) (i 0))
- (cond ((null? symnames) (search sym (cdr subst) marks))
+ (cond ((null? symnames) (search sym (cdr subst) marks mod))
((and (eq? (car symnames) sym)
(same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (list-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (cdr symnames) (+ i 1)))
+ (values n marks))))
(else (f (cdr symnames) (+ i 1)))))))
(search-vector-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let ((n (vector-length symnames)))
(let f ((i 0))
- (cond ((= i n) (search sym (cdr subst) marks))
+ (cond ((= i n) (search sym (cdr subst) marks mod))
((and (eq? (vector-ref symnames i) sym)
(same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (vector-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1)))
+ (values n marks))))
(else (f (+ i 1)))))))))
- (cond ((symbol? id) (or (search id (cdr w) (car w)) id))
+ (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id))
((syntax-object? id)
- (let ((id (syntax-object-expression id)) (w1 (syntax-object-wrap id)))
+ (let ((id (syntax-object-expression id))
+ (w1 (syntax-object-wrap id))
+ (mod (syntax-object-module id)))
(let ((marks (join-marks (car w) (car w1))))
(call-with-values
- (lambda () (search id (cdr w) marks))
- (lambda (new-id marks) (or new-id (search id (cdr w1) marks) id))))))
+ (lambda () (search id (cdr w) marks mod))
+ (lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id))))))
(else (syntax-violation 'id-var-name "invalid id" id))))))
(locally-bound-identifiers
(lambda (w mod)
results))))))))
(scan (cdr w) '()))))
(resolve-identifier
- (lambda (id w r mod)
+ (lambda (id w r mod resolve-syntax-parameters?)
(letrec*
- ((resolve-global
+ ((resolve-syntax-parameters
+ (lambda (b)
+ (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter))
+ (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b))))
+ b)))
+ (resolve-global
(lambda (var mod)
- (let ((b (or (get-global-definition-hook var mod) '(global))))
+ (let ((b (resolve-syntax-parameters
+ (or (get-global-definition-hook var mod) '(global)))))
(if (eq? (car b) 'global)
(values 'global var mod)
(values (car b) (cdr b) mod)))))
(resolve-lexical
(lambda (label mod)
- (let ((b (or (assq-ref r label) '(displaced-lexical))))
+ (let ((b (resolve-syntax-parameters
+ (or (assq-ref r label) '(displaced-lexical)))))
(values (car b) (cdr b) mod)))))
- (let ((n (id-var-name id w)))
- (cond ((symbol? n)
+ (let ((n (id-var-name id w mod)))
+ (cond ((syntax-object? n)
+ (resolve-identifier n w r mod resolve-syntax-parameters?))
+ ((symbol? n)
(resolve-global
n
(if (syntax-object? id) (syntax-object-module id) mod)))
(lambda (k) ((fluid-ref transformer-environment) k)))
(free-id=?
(lambda (i j)
- (and (eq? (let ((x i)) (if (syntax-object? x) (syntax-object-expression x) x))
- (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x)))
- (eq? (id-var-name i '(())) (id-var-name j '(()))))))
+ (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
+ (mj (and (syntax-object? j) (syntax-object-module j)))
+ (ni (id-var-name i '(()) mi))
+ (nj (id-var-name j '(()) mj)))
+ (letrec*
+ ((id-module-binding
+ (lambda (id mod)
+ (module-variable
+ (if mod (resolve-module (cdr mod)) (current-module))
+ (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x))))))
+ (cond ((syntax-object? ni) (free-id=? ni j))
+ ((syntax-object? nj) (free-id=? i nj))
+ ((symbol? ni)
+ (and (eq? nj
+ (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x)))
+ (let ((bi (id-module-binding i mi)))
+ (if bi
+ (eq? bi (id-module-binding j mj))
+ (and (not (id-module-binding j mj)) (eq? ni nj))))
+ (eq? (id-module-binding i mi) (id-module-binding j mj))))
+ (else (equal? ni nj)))))))
(bound-id=?
(lambda (i j)
(if (and (syntax-object? i) (syntax-object? j))
(cons first (dobody (cdr body) r w mod))))))))
(expand-top-sequence
(lambda (body r w s m esew mod)
- (letrec*
- ((scan (lambda (body r w s m esew mod exps)
- (if (null? body)
- exps
- (call-with-values
- (lambda ()
- (call-with-values
- (lambda ()
- (let ((e (car body)))
- (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
- (lambda (type value form e w s mod)
- (let ((key type))
- (cond ((memv key '(begin-form))
- (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_))))
- (if tmp-1
- (apply (lambda () exps) tmp-1)
- (let ((tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
- (if tmp-1
- (apply (lambda (e1 e2) (scan (cons e1 e2) r w s m esew mod exps))
- tmp-1)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp))))))
- ((memv key '(local-syntax-form))
- (expand-local-syntax
- value
- e
- r
- w
- s
- mod
- (lambda (body r w s mod) (scan body r w s m esew mod exps))))
- ((memv key '(eval-when-form))
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
- (if tmp
- (apply (lambda (x e1 e2)
- (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
- (cond ((eq? m 'e)
- (if (memq 'eval when-list)
- (scan body
- r
- w
- s
- (if (memq 'expand when-list) 'c&e 'e)
- '(eval)
- mod
- exps)
- (begin
- (if (memq 'expand when-list)
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod))
- (values exps))))
- ((memq 'load when-list)
- (cond ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (scan body r w s 'c&e '(compile load) mod exps))
- ((memq m '(c c&e))
- (scan body r w s 'c '(load) mod exps))
- (else (values exps))))
- ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
+ (let* ((r (cons '("placeholder" placeholder) r))
+ (ribcage (make-ribcage '() '() '()))
+ (w (cons (car w) (cons ribcage (cdr w)))))
+ (letrec*
+ ((record-definition!
+ (lambda (id var)
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ (extend-ribcage!
+ ribcage
+ id
+ (cons (syntax-object-module id) (wrap var '((top)) mod))))))
+ (macro-introduced-identifier?
+ (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top)))))
+ (fresh-derived-name
+ (lambda (id orig-form)
+ (symbol-append
+ (syntax-object-expression id)
+ '-
+ (string->symbol
+ (number->string
+ (hash (syntax->datum orig-form) most-positive-fixnum)
+ 16)))))
+ (parse (lambda (body r w s m esew mod)
+ (let lp ((body body) (exps '()))
+ (if (null? body)
+ exps
+ (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps))))))
+ (parse1
+ (lambda (x r w s m esew mod)
+ (call-with-values
+ (lambda () (syntax-type x r w (source-annotation x) ribcage mod #f))
+ (lambda (type value form e w s mod)
+ (let ((key type))
+ (cond ((memv key '(define-form))
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (list (if (eq? m 'c&e)
+ (let ((x (build-global-definition s var (expand e r w mod))))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (call-with-values
+ (lambda () (resolve-identifier id '(()) r mod #t))
+ (lambda (type* value* mod*)
+ (if (eq? type* 'macro)
+ (top-level-eval-hook
+ (build-global-definition s var (build-void s))
+ mod))
+ (lambda () (build-global-definition s var (expand e r w mod)))))))))
+ ((memv key '(define-syntax-form define-syntax-parameter-form))
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (let ((key m))
+ (cond ((memv key '(c))
+ (cond ((memq 'compile esew)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (if (memq 'load esew) (list (lambda () e)) '())))
+ ((memq 'load esew)
+ (list (lambda () (expand-install-global var type (expand e r w mod)))))
+ (else '())))
+ ((memv key '(c&e))
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (list (lambda () e))))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (expand-install-global var type (expand e r w mod))
+ mod))
+ '())))))
+ ((memv key '(begin-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
+ (if tmp
+ (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
+ ((memv key '(local-syntax-form))
+ (expand-local-syntax
+ value
+ e
+ r
+ w
+ s
+ mod
+ (lambda (forms r w s mod) (parse forms r w s m esew mod))))
+ ((memv key '(eval-when-form))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
+ (if tmp
+ (apply (lambda (x e1 e2)
+ (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
+ (letrec*
+ ((recurse (lambda (m esew) (parse body r w s m esew mod))))
+ (cond ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval))
+ (begin
+ (if (memq 'expand when-list)
(top-level-eval-hook
(expand-top-sequence body r w s 'e '(eval) mod)
- mod)
- (values exps))
- (else (values exps)))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))
- ((memv key '(define-syntax-form define-syntax-parameter-form))
- (let ((n (id-var-name value w)) (r (macros-only-env r)))
- (let ((key m))
- (cond ((memv key '(c))
- (cond ((memq 'compile esew)
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (if (memq 'load esew) (values (cons e exps)) (values exps))))
- ((memq 'load esew)
- (values
- (cons (expand-install-global n (expand e r w mod)) exps)))
- (else (values exps))))
- ((memv key '(c&e))
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (values (cons e exps))))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (expand-install-global n (expand e r w mod))
- mod))
- (values exps))))))
- ((memv key '(define-form))
- (let* ((n (id-var-name value w)) (type (car (lookup n r mod))) (key type))
- (cond ((memv key '(global core macro module-ref))
- (if (and (memq m '(c c&e))
- (not (module-local-variable (current-module) n))
- (current-module))
- (let ((old (module-variable (current-module) n)))
- (if (and (variable? old)
- (variable-bound? old)
- (not (macro? (variable-ref old))))
- (module-define! (current-module) n (variable-ref old))
- (module-add! (current-module) n (make-undefined-variable)))))
- (values
- (cons (if (eq? m 'c&e)
- (let ((x (build-global-definition s n (expand e r w mod))))
- (top-level-eval-hook x mod)
- x)
- (lambda () (build-global-definition s n (expand e r w mod))))
- exps)))
- ((memv key '(displaced-lexical))
- (syntax-violation
- #f
- "identifier out of context"
- (source-wrap form w s mod)
- (wrap value w mod)))
- (else
- (syntax-violation
- #f
- "cannot define keyword at top level"
- (source-wrap form w s mod)
- (wrap value w mod))))))
- (else
- (values
- (cons (if (eq? m 'c&e)
- (let ((x (expand-expr type value form e r w s mod)))
- (top-level-eval-hook x mod)
- x)
- (lambda () (expand-expr type value form e r w s mod)))
- exps))))))))
- (lambda (exps) (scan (cdr body) r w s m esew mod exps)))))))
- (call-with-values
- (lambda () (scan body r w s m esew mod '()))
- (lambda (exps)
- (if (null? exps)
- (build-void s)
- (build-sequence
- s
- (let lp ((in exps) (out '()))
- (if (null? in)
- out
- (let ((e (car in)))
- (lp (cdr in) (cons (if (procedure? e) (e) e) out))))))))))))
+ mod))
+ '())))
+ ((memq 'load when-list)
+ (cond ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (recurse 'c&e '(compile load)))
+ ((memq m '(c c&e)) (recurse 'c '(load)))
+ (else '())))
+ ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod)
+ '())
+ (else '())))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
+ (else
+ (list (if (eq? m 'c&e)
+ (let ((x (expand-expr type value form e r w s mod)))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda () (expand-expr type value form e r w s mod))))))))))))
+ (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod)))))
+ (if (null? exps) (build-void s) (build-sequence s exps)))))))
(expand-install-global
- (lambda (name e)
+ (lambda (name type e)
(build-global-definition
#f
name
- (build-application
+ (build-primcall
#f
- (build-primref #f 'make-syntax-transformer)
- (list (build-data #f name) (build-data #f 'macro) e)))))
+ 'make-syntax-transformer
+ (if (eq? type 'define-syntax-parameter-form)
+ (list (build-data #f name)
+ (build-data #f 'syntax-parameter)
+ (build-primcall #f 'list (list e)))
+ (list (build-data #f name) (build-data #f 'macro) e))))))
(parse-when-list
(lambda (e when-list)
(let ((result (strip when-list '(()))))
(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 (car b))
- (key type))
- (cond ((memv key '(lexical)) (values type (cdr b) e e w s mod))
- ((memv key '(global)) (values type n e e w s mod))
- ((memv key '(macro))
- (if for-car?
- (values type (cdr b) e e w s mod)
- (syntax-type
- (expand-macro (cdr b) e r w s rib mod)
- r
- '(())
- s
- rib
- mod
- #f)))
- (else (values type (cdr b) e e w s mod)))))
+ (call-with-values
+ (lambda () (resolve-identifier e w r mod #t))
+ (lambda (type value mod*)
+ (let ((key type))
+ (cond ((memv key '(macro))
+ (if for-car?
+ (values type value e e w s mod)
+ (syntax-type
+ (expand-macro value e r w s rib mod)
+ r
+ '(())
+ s
+ rib
+ mod
+ #f)))
+ ((memv key '(global)) (values type value e value w s mod*))
+ (else (values type value e e w s mod)))))))
((pair? e)
(let ((first (car e)))
(call-with-values
(let ((key ftype))
(cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod))
((memv key '(global))
- (values 'global-call (make-syntax-object fval w fmod) e e w s mod))
+ (if (equal? fmod '(primitive))
+ (values 'primitive-call fval e e w s mod)
+ (values 'global-call (make-syntax-object fval w fmod) e e w s mod)))
((memv key '(macro))
(syntax-type
(expand-macro fval e r w s rib mod)
for-car?))
((memv key '(module-ref))
(call-with-values
- (lambda () (fval e r w))
+ (lambda () (fval e r w mod))
(lambda (e r w s mod) (syntax-type e r w s rib mod for-car?))))
((memv key '(core)) (values 'core-form fval e e w s mod))
((memv key '(local-syntax))
((memv key '(core core-form)) (value e r w s mod))
((memv key '(module-ref))
(call-with-values
- (lambda () (value e r w))
+ (lambda () (value e r w mod))
(lambda (e r w s mod) (expand e r w mod))))
((memv key '(lexical-call))
- (expand-application
+ (expand-call
(let ((id (car e)))
(build-lexical-reference
'fun
s
mod))
((memv key '(global-call))
- (expand-application
+ (expand-call
(build-global-reference
(source-annotation (car e))
(if (syntax-object? value) (syntax-object-expression value) value)
w
s
mod))
+ ((memv key '(primitive-call))
+ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
+ (if tmp
+ (apply (lambda (e)
+ (build-primcall s value (map (lambda (e) (expand e r w mod)) e)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))
((memv key '(constant))
(build-data s (strip (source-wrap e w s mod) '(()))))
((memv key '(global)) (build-global-reference s value mod))
((memv key '(call))
- (expand-application (expand (car e) r w mod) e r w s mod))
+ (expand-call (expand (car e) r w mod) e r w s mod))
((memv key '(begin-form))
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
(if tmp-1
(let ((tmp-1 ($sc-dispatch tmp '(_))))
(if tmp-1
(apply (lambda ()
- (if (include-deprecated-features)
- (begin
- (issue-deprecation-warning
- "Sequences of zero expressions are deprecated. Use *unspecified*.")
- (expand-void))
- (syntax-violation
- #f
- "sequence of zero expressions"
- (source-wrap e w s mod))))
+ (syntax-violation
+ #f
+ "sequence of zero expressions"
+ (source-wrap e w s mod)))
tmp-1)
(syntax-violation
#f
(source-wrap e w s mod)))
(else
(syntax-violation #f "unexpected syntax" (source-wrap e w s mod)))))))
- (expand-application
+ (expand-call
(lambda (x e r w s mod)
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any))))
(if tmp
(apply (lambda (e0 e1)
- (build-application s x (map (lambda (e) (expand e r w mod)) e1)))
+ (build-call s x (map (lambda (e) (expand e r w mod)) e1)))
tmp)
(syntax-violation
#f
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x s))))))
- (with-fluids
- ((transformer-environment (lambda (k) (k e r w s rib mod))))
- (rebuild-macro-output
- (p (source-wrap e (anti-mark w) s mod))
- (gensym (string-append "m-" (session-id) "-")))))))
+ (let* ((t-1 transformer-environment) (t (lambda (k) (k e r w s rib mod))))
+ (with-fluid*
+ t-1
+ t
+ (lambda ()
+ (rebuild-macro-output
+ (p (source-wrap e (anti-mark w) s mod))
+ (gensym (string-append "m-" (session-id) "-")))))))))
(expand-body
(lambda (body outer-form r w mod)
(let* ((r (cons '("placeholder" placeholder) r))
(cons var vars)
(cons (cons er (wrap e w mod)) vals)
(cons (cons 'lexical var) bindings)))))
- ((memv key '(define-syntax-form define-syntax-parameter-form))
+ ((memv key '(define-syntax-form))
(let ((id (wrap value w mod))
(label (gen-label))
(trans-r (macros-only-env er)))
(list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod)))
(cdr r)))
(parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
+ ((memv key '(define-syntax-parameter-form))
+ (let ((id (wrap value w mod))
+ (label (gen-label))
+ (trans-r (macros-only-env er)))
+ (extend-ribcage! ribcage id label)
+ (set-cdr!
+ r
+ (extend-env
+ (list label)
+ (list (cons 'syntax-parameter
+ (list (eval-local-transformer (expand e trans-r w mod) mod))))
+ (cdr r)))
+ (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
((memv key '(begin-form))
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
(if tmp
(ellipsis?
(lambda (e r mod)
(and (nonsymbol-id? e)
- (let* ((id (make-syntax-object
- '#{ $sc-ellipsis }#
- (syntax-object-wrap e)
- (syntax-object-module e)))
- (n (id-var-name id '(())))
- (b (lookup n r mod)))
- (if (eq? (car b) 'ellipsis)
- (bound-id=? e (cdr b))
- (free-id=? e '#(syntax-object ... ((top)) (hygiene guile))))))))
+ (call-with-values
+ (lambda ()
+ (resolve-identifier
+ (make-syntax-object
+ '#{ $sc-ellipsis }#
+ (syntax-object-wrap e)
+ (syntax-object-module e))
+ '(())
+ r
+ mod
+ #f))
+ (lambda (type value mod)
+ (if (eq? type 'ellipsis)
+ (bound-id=? e value)
+ (free-id=? e '#(syntax-object ... ((top)) (hygiene guile)))))))))
(lambda-formals
(lambda (orig-args)
(letrec*
(tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
(if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp))
(apply (lambda (var val e1 e2)
- (let ((names (map (lambda (x) (id-var-name x w)) var)))
- (for-each
- (lambda (id n)
- (let ((key (car (lookup n r mod))))
- (if (memv key '(displaced-lexical))
- (syntax-violation
- 'syntax-parameterize
- "identifier out of context"
- e
- (source-wrap id w s mod)))))
- var
- names)
+ (let ((names (map (lambda (x)
+ (call-with-values
+ (lambda () (resolve-identifier x w r mod #f))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond ((memv key '(displaced-lexical))
+ (syntax-violation
+ 'syntax-parameterize
+ "identifier out of context"
+ e
+ (source-wrap x w s mod)))
+ ((memv key '(syntax-parameter)) value)
+ (else
+ (syntax-violation
+ 'syntax-parameterize
+ "invalid syntax parameter"
+ e
+ (source-wrap x w s mod))))))))
+ var))
+ (bindings
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
+ val))))
(expand-body
(cons e1 e2)
(source-wrap e w s mod)
- (extend-env
- names
- (let ((trans-r (macros-only-env r)))
- (map (lambda (x)
- (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
- val))
- r)
+ (extend-env names bindings r)
w
mod)))
tmp)
((gen-syntax
(lambda (src e r maps ellipsis? mod)
(if (id? e)
- (let* ((label (id-var-name e '(()))) (b (lookup label r mod)))
- (cond ((eq? (car b) 'syntax)
- (call-with-values
- (lambda ()
- (let ((var.lev (cdr b)))
- (gen-ref src (car var.lev) (cdr var.lev) maps)))
- (lambda (var maps) (values (list 'ref var) maps))))
- ((ellipsis? e r mod)
- (syntax-violation 'syntax "misplaced ellipsis" src))
- (else (values (list 'quote e) maps))))
+ (call-with-values
+ (lambda () (resolve-identifier e '(()) r mod #f))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond ((memv key '(syntax))
+ (call-with-values
+ (lambda () (gen-ref src (car value) (cdr value) maps))
+ (lambda (var maps) (values (list 'ref var) maps))))
+ ((ellipsis? e r mod)
+ (syntax-violation 'syntax "misplaced ellipsis" src))
+ (else (values (list 'quote e) maps))))))
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
(if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1))
(apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod))
(if (list? (cadr x))
(build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x)))
- (else
- (build-application #f (build-primref #f (car x)) (map regen (cdr x)))))))))
+ (else (build-primcall #f (car x) (map regen (cdr x)))))))))
(lambda (e r w s mod)
(let* ((e (source-wrap e w s mod))
(tmp e)
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
(if (and tmp (apply (lambda (id val) (id? id)) tmp))
(apply (lambda (id val)
- (let ((n (id-var-name id w))
- (id-mod (if (syntax-object? id) (syntax-object-module id) mod)))
- (let* ((b (lookup n r id-mod)) (key (car b)))
- (cond ((memv key '(lexical))
- (build-lexical-assignment
- s
- (syntax->datum id)
- (cdr b)
- (expand val r w mod)))
- ((memv key '(global))
- (build-global-assignment s n (expand val r w mod) id-mod))
- ((memv key '(macro))
- (let ((p (cdr b)))
- (if (procedure-property p 'variable-transformer)
- (expand (expand-macro p e r w s #f mod) r '(()) mod)
+ (call-with-values
+ (lambda () (resolve-identifier id w r mod #t))
+ (lambda (type value id-mod)
+ (let ((key type))
+ (cond ((memv key '(lexical))
+ (build-lexical-assignment
+ s
+ (syntax->datum id)
+ value
+ (expand val r w mod)))
+ ((memv key '(global))
+ (build-global-assignment s value (expand val r w mod) id-mod))
+ ((memv key '(macro))
+ (if (procedure-property value 'variable-transformer)
+ (expand (expand-macro value e r w s #f mod) r '(()) mod)
(syntax-violation
'set!
"not a variable transformer"
(wrap e w mod)
- (wrap id w id-mod)))))
- ((memv key '(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)))))))
+ (wrap id w id-mod))))
+ ((memv key '(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))))))))
tmp)
(let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any))))
(if tmp
(apply (lambda (head tail val)
(call-with-values
(lambda () (syntax-type head r '(()) #f #f mod #t))
- (lambda (type value formform ee ww ss modmod)
+ (lambda (type value ee* ee ww ss modmod)
(let ((key type))
(if (memv key '(module-ref))
(let ((val (expand val r w mod)))
(call-with-values
- (lambda () (value (cons head tail) r w))
+ (lambda () (value (cons head tail) r w mod))
(lambda (e r w s* mod)
(let* ((tmp-1 e) (tmp (list tmp-1)))
(if (and tmp (apply (lambda (e) (id? e)) tmp))
#f
"source expression failed to match any pattern"
tmp-1))))))
- (build-application
+ (build-call
s
(expand
(list '#(syntax-object setter ((top)) (hygiene guile)) head)
(global-extend
'module-ref
'@
- (lambda (e r w)
+ (lambda (e r w mod)
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
(if (and tmp
(apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
(global-extend
'module-ref
'@@
- (lambda (e r w)
+ (lambda (e r w mod)
(letrec*
((remodulate
(lambda (x mod)
(vector-set! v i (remodulate (vector-ref x i) mod))
(loop (+ i 1)))))))
(else x)))))
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
- (if (and tmp
- (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
- (apply (lambda (mod id)
- (values
- (syntax->datum id)
- r
- '((top))
- #f
- (syntax->datum
- (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
- tmp)
- (let ((tmp ($sc-dispatch
- tmp-1
- '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile)))
- each-any
- any))))
- (if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp))
- (apply (lambda (mod exp)
- (let ((mod (syntax->datum
- (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
- (values (remodulate exp mod) r w (source-annotation exp) mod)))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1))))))))
+ (let* ((tmp e)
+ (tmp-1 ($sc-dispatch
+ tmp
+ '(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any))))
+ (if (and tmp-1
+ (apply (lambda (id)
+ (and (id? id)
+ (equal?
+ (cdr (if (syntax-object? id) (syntax-object-module id) mod))
+ '(guile))))
+ tmp-1))
+ (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any))))
+ (if (and tmp-1
+ (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1))
+ (apply (lambda (mod id)
+ (values
+ (syntax->datum id)
+ r
+ '((top))
+ #f
+ (syntax->datum
+ (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch
+ tmp
+ '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile)))
+ each-any
+ any))))
+ (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1))
+ (apply (lambda (mod exp)
+ (let ((mod (syntax->datum
+ (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
+ (values (remodulate exp mod) r w (source-annotation exp) mod)))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))))
(global-extend
'core
'if
#f
"source expression failed to match any pattern"
tmp)))))))
- (global-extend
- 'core
- 'with-fluids
- (lambda (e r w s mod)
- (let* ((tmp-1 e)
- (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
- (if tmp
- (apply (lambda (fluid val b b*)
- (build-dynlet
- s
- (map (lambda (x) (expand x r w mod)) fluid)
- (map (lambda (x) (expand x r w mod)) val)
- (expand-body (cons b b*) (source-wrap e w s mod) r w mod)))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())
(global-extend 'define-syntax 'define-syntax '())
(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
+ (build-primcall
#f
- (build-primref #f 'apply)
+ 'apply
(list (build-simple-lambda
#f
(map syntax->datum ids)
(syntax-violation 'syntax-case "duplicate pattern variable" pat))
(else
(let ((y (gen-var 'tmp)))
- (build-application
+ (build-call
#f
(build-simple-lambda
#f
(build-dispatch-call pvars exp y r mod)
(gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any)
- (build-application #f (build-primref #f 'list) (list x))
- (build-application
- #f
- (build-primref #f '$sc-dispatch)
- (list x (build-data #f p)))))))))))))
+ (build-primcall #f 'list (list x))
+ (build-primcall #f '$sc-dispatch (list x (build-data #f p)))))))))))))
(gen-syntax-case
(lambda (x keys clauses r mod)
(if (null? clauses)
- (build-application
+ (build-primcall
#f
- (build-primref #f 'syntax-violation)
+ 'syntax-violation
(list (build-data #f #f)
(build-data #f "source expression failed to match any pattern")
x))
(if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile)))
(expand exp r '(()) mod)
(let ((labels (list (gen-label))) (var (gen-var pat)))
- (build-application
+ (build-call
#f
(build-simple-lambda
#f
(apply (lambda (val key m)
(if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key)
(let ((x (gen-var 'tmp)))
- (build-application
+ (build-call
s
(build-simple-lambda
#f
(let ((x id))
(if (not (nonsymbol-id? x))
(syntax-violation 'syntax-module "invalid argument" x)))
- (cdr (syntax-object-module id))))
+ (let ((mod (syntax-object-module id)))
+ (and (not (equal? mod '(primitive))) (cdr mod)))))
(syntax-local-binding
- (lambda (id)
+ (lambda* (id
+ #:key
+ (resolve-syntax-parameters? #t #:resolve-syntax-parameters?))
(let ((x id))
(if (not (nonsymbol-id? x))
(syntax-violation 'syntax-local-binding "invalid argument" x)))
(syntax-object-expression id)
(strip-anti-mark (syntax-object-wrap id))
r
- (syntax-object-module id)))
+ (syntax-object-module id)
+ resolve-syntax-parameters?))
(lambda (type value mod)
(let ((key type))
(cond ((memv key '(lexical)) (values 'lexical value))
((memv key '(macro)) (values 'macro value))
+ ((memv key '(syntax-parameter))
+ (values 'syntax-parameter (car value)))
((memv key '(syntax)) (values 'pattern-variable value))
((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
- ((memv key '(global)) (values 'global (cons value (cdr mod))))
+ ((memv key '(global))
+ (if (equal? mod '(primitive))
+ (values 'primitive value)
+ (values 'global (cons value (cdr mod)))))
((memv key '(ellipsis))
(values
'ellipsis
(apply (lambda (message arg) (string? (syntax->datum message))) tmp)
#f)
(apply (lambda (message arg)
- (cons '#(syntax-object syntax-error ((top)) (hygiene guile))
+ (cons '#(syntax-object
+ syntax-error
+ ((top)
+ #(ribcage
+ #(syntax-error)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object syntax-error ((top)) (hygiene guile))))))
+ (hygiene guile))
(cons '(#f) (cons message arg))))
tmp)
(syntax-violation
(list (vector
'(#(syntax-object macro-type ((top)) (hygiene guile))
.
- #(syntax-object syntax-rules ((top)) (hygiene guile)))
+ #(syntax-object
+ syntax-rules
+ ((top)
+ #(ribcage
+ #(syntax-rules)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
+ (hygiene guile)))
(cons '#(syntax-object patterns ((top)) (hygiene guile))
pattern))
(cons '#(syntax-object syntax-case ((top)) (hygiene guile))
tmp-1)
(let ((tmp-1 ($sc-dispatch
tmp
- '(#(free-id #(syntax-object quasiquote ((top)) (hygiene guile))) any))))
+ '(#(free-id
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage
+ #(quasiquote)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object quasiquote ((top)) (hygiene guile))))))
+ (hygiene guile)))
+ any))))
(if tmp-1
(apply (lambda (p)
(quasicons
- '("quote" #(syntax-object quasiquote ((top)) (hygiene guile)))
+ '("quote"
+ #(syntax-object
+ quasiquote
+ ((top)
+ #(ribcage
+ #(quasiquote)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object quasiquote ((top)) (hygiene guile))))))
+ (hygiene guile)))
(quasi (list p) (+ lev 1))))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(any . any))))
'(#(syntax-object x ((top)) (hygiene guile)))
'#((#(syntax-object macro-type ((top)) (hygiene guile))
.
- #(syntax-object identifier-syntax ((top)) (hygiene guile))))
+ #(syntax-object
+ identifier-syntax
+ ((top)
+ #(ribcage
+ #(identifier-syntax)
+ #((top))
+ #(((hygiene guile)
+ .
+ #(syntax-object identifier-syntax ((top)) (hygiene guile))))))
+ (hygiene guile))))
(list '#(syntax-object syntax-case ((top)) (hygiene guile))
'#(syntax-object x ((top)) (hygiene guile))
'()
(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) (macro-type val)
- (cons (macro-type val)
- (macro-binding val)))))))))
+ (and (not (equal? module '(primitive)))
+ (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) (macro-type val)
+ (cons (macro-type val)
+ (macro-binding val))))))))))
(define (decorate-source e s)
(lambda (source)
(make-void source)))
- (define build-application
+ (define build-call
(lambda (source fun-exp arg-exps)
- (make-application source fun-exp arg-exps)))
+ (make-call source fun-exp arg-exps)))
(define build-conditional
(lambda (source test-exp then-exp else-exp)
(make-conditional source test-exp then-exp else-exp)))
- (define build-dynlet
- (lambda (source fluids vals body)
- (make-dynlet source fluids vals body)))
-
(define build-lexical-reference
(lambda (type source name var)
(make-lexical-ref source name var)))
(module-variable (resolve-module mod) var))
(modref-cont mod var #f)
(bare-cont var)))
+ ((primitive)
+ (syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod))))))
(define build-global-reference
(lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case src req opt rest kw inits vars body else-case)))
+ (define build-primcall
+ (lambda (src name args)
+ (make-primcall src name args)))
+
(define build-primref
(lambda (src name)
- (if (equal? (module-name (current-module)) '(guile))
- (make-toplevel-ref src name)
- (make-module-ref src '(guile) name #f))))
-
+ (make-primitive-ref src name)))
+
(define (build-data src exp)
(make-const src exp))
(lambda (src exps)
(if (null? (cdr exps))
(car exps)
- (make-sequence src exps))))
+ (make-seq src (car exps) (build-sequence #f (cdr exps))))))
(define build-let
(lambda (src ids vars val-exps body-exp)
(make-letrec
src #f
(list f-name) (list f) (list proc)
- (build-application src (build-lexical-reference 'fun src f-name f)
- val-exps))))))
+ (build-call src (build-lexical-reference 'fun src f-name f)
+ val-exps))))))
(define build-letrec
(lambda (src in-order? ids vars val-exps body-exp)
;; 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.
+ ;; resolve-identifier when it finds no other bindings.
;; <environment> ::= ((<label> . <binding>)*)
;; identifier bindings include a type and a value
;; <binding> ::= (macro . <procedure>) macros
+ ;; (syntax-parameter . (<procedure>)) syntax parameters
;; (core . <procedure>) core forms
;; (module-ref . <procedure>) @ or @@
;; (begin) begin
(if (null? r)
'()
(let ((a (car r)))
- (if (memq (cadr a) '(macro ellipsis))
+ (if (memq (cadr a) '(macro syntax-parameter ellipsis))
(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)))
(same-marks? (cdr x) (cdr y))))))
(define id-var-name
- (lambda (id w)
+ ;; Syntax objects use wraps to associate names with marked
+ ;; identifiers. This function returns the name corresponding to
+ ;; the given identifier and wrap, or the original identifier if no
+ ;; corresponding name was found.
+ ;;
+ ;; The name may be a string created by gen-label, indicating a
+ ;; lexical binding, or another syntax object, indicating a
+ ;; reference to a top-level definition created during a previous
+ ;; macroexpansion.
+ ;;
+ ;; For lexical variables, finding a label simply amounts to
+ ;; looking for an entry with the same symbolic name and the same
+ ;; marks. Finding a toplevel definition is the same, except we
+ ;; also have to compare modules, hence the `mod' parameter.
+ ;; Instead of adding a separate entry in the ribcage for modules,
+ ;; which wouldn't be used for lexicals, we arrange for the entry
+ ;; for the name entry to be a pair with the module in its car, and
+ ;; the name itself in the cdr. So if the name that we find is a
+ ;; pair, we have to check modules.
+ ;;
+ ;; The identifer may be passed in wrapped or unwrapped. In any
+ ;; case, this routine returns either a symbol, a syntax object, or
+ ;; a string label.
+ ;;
+ (lambda (id w mod)
(define-syntax-rule (first e)
;; Rely on Guile's multiple-values truncation.
e)
(define search
- (lambda (sym subst marks)
+ (lambda (sym subst marks mod)
(if (null? subst)
(values #f marks)
(let ((fst (car subst)))
(if (eq? fst 'shift)
- (search sym (cdr subst) (cdr marks))
+ (search sym (cdr subst) (cdr marks) mod)
(let ((symnames (ribcage-symnames fst)))
(if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))))))
+ (search-vector-rib sym subst marks symnames fst mod)
+ (search-list-rib sym subst marks symnames fst mod))))))))
(define search-list-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let f ((symnames symnames) (i 0))
(cond
- ((null? symnames) (search sym (cdr subst) marks))
+ ((null? symnames) (search sym (cdr subst) marks mod))
((and (eq? (car symnames) sym)
(same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (list-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (cdr symnames) (fx+ i 1)))
+ (values n marks))))
(else (f (cdr symnames) (fx+ i 1)))))))
(define search-vector-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let ((n (vector-length symnames)))
(let f ((i 0))
(cond
- ((fx= i n) (search sym (cdr subst) marks))
+ ((fx= i n) (search sym (cdr subst) marks mod))
((and (eq? (vector-ref symnames i) sym)
(same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (vector-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (fx+ i 1)))
+ (values n marks))))
(else (f (fx+ i 1))))))))
(cond
((symbol? id)
- (or (first (search id (wrap-subst w) (wrap-marks w))) id))
+ (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id))
((syntax-object? id)
(let ((id (syntax-object-expression id))
- (w1 (syntax-object-wrap id)))
+ (w1 (syntax-object-wrap id))
+ (mod (syntax-object-module id)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
- (call-with-values (lambda () (search id (wrap-subst w) marks))
+ (call-with-values (lambda () (search id (wrap-subst w) marks mod))
(lambda (new-id marks)
(or new-id
- (first (search id (wrap-subst w1) marks))
+ (first (search id (wrap-subst w1) marks mod))
id))))))
(else (syntax-violation 'id-var-name "invalid id" id)))))
;; Returns three values: binding type, binding value, the module (for
;; resolving toplevel vars).
- (define (resolve-identifier id w r mod)
+ (define (resolve-identifier id w r mod resolve-syntax-parameters?)
+ (define (resolve-syntax-parameters b)
+ (if (and resolve-syntax-parameters?
+ (eq? (binding-type b) 'syntax-parameter))
+ (or (assq-ref r (binding-value b))
+ (make-binding 'macro (car (binding-value b))))
+ b))
(define (resolve-global var mod)
- (let ((b (or (get-global-definition-hook var mod)
- (make-binding 'global))))
+ (let ((b (resolve-syntax-parameters
+ (or (get-global-definition-hook var mod)
+ (make-binding 'global)))))
(if (eq? (binding-type b) 'global)
(values 'global var mod)
(values (binding-type b) (binding-value b) mod))))
(define (resolve-lexical label mod)
- (let ((b (or (assq-ref r label)
- (make-binding 'displaced-lexical))))
+ (let ((b (resolve-syntax-parameters
+ (or (assq-ref r label)
+ (make-binding 'displaced-lexical)))))
(values (binding-type b) (binding-value b) mod)))
- (let ((n (id-var-name id w)))
+ (let ((n (id-var-name id w mod)))
(cond
+ ((syntax-object? n)
+ ;; Recursing allows syntax-parameterize to override
+ ;; macro-introduced syntax parameters.
+ (resolve-identifier n w r mod resolve-syntax-parameters?))
((symbol? n)
(resolve-global n (if (syntax-object? id)
(syntax-object-module id)
(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)))))
-
+ (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
+ (mj (and (syntax-object? j) (syntax-object-module j)))
+ (ni (id-var-name i empty-wrap mi))
+ (nj (id-var-name j empty-wrap mj)))
+ (define (id-module-binding id mod)
+ (module-variable
+ (if mod
+ ;; The normal case.
+ (resolve-module (cdr mod))
+ ;; Either modules have not been booted, or we have a
+ ;; raw symbol coming in, which is possible.
+ (current-module))
+ (id-sym-name id)))
+ (cond
+ ((syntax-object? ni) (free-id=? ni j))
+ ((syntax-object? nj) (free-id=? i nj))
+ ((symbol? ni)
+ ;; `i' is not lexically bound. Assert that `j' is free,
+ ;; and if so, compare their bindings, that they are either
+ ;; bound to the same variable, or both unbound and have
+ ;; the same name.
+ (and (eq? nj (id-sym-name j))
+ (let ((bi (id-module-binding i mi)))
+ (if bi
+ (eq? bi (id-module-binding j mj))
+ (and (not (id-module-binding j mj))
+ (eq? ni nj))))
+ (eq? (id-module-binding i mi) (id-module-binding j mj))))
+ (else
+ ;; Otherwise `i' is bound, so check that `j' is bound, and
+ ;; bound to the same thing.
+ (equal? ni nj))))))
+
;; 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 expand-top-sequence
(lambda (body r w s m esew mod)
- (define (scan body r w s m esew mod exps)
- (cond
- ((null? body)
- ;; in reversed order
- exps)
- (else
+ (let* ((r (cons '("placeholder" . (placeholder)) r))
+ (ribcage (make-empty-ribcage))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
+ (define (record-definition! id var)
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ ;; Ribcages map symbol+marks to names, mostly for
+ ;; resolving lexicals. Here to add a mapping for toplevel
+ ;; definitions we also need to match the module. So, we
+ ;; put it in the name instead, and make id-var-name handle
+ ;; the special case of names that are pairs. See the
+ ;; comments in id-var-name for more.
+ (extend-ribcage! ribcage id
+ (cons (syntax-object-module id)
+ (wrap var top-wrap mod)))))
+ (define (macro-introduced-identifier? id)
+ (not (equal? (wrap-marks (syntax-object-wrap id)) '(top))))
+ (define (fresh-derived-name id orig-form)
+ (symbol-append
+ (syntax-object-expression id)
+ '-
+ (string->symbol
+ ;; FIXME: `hash' currently stops descending into nested
+ ;; data at some point, so it's less unique than we would
+ ;; like. Also this encodes hash values into the ABI of
+ ;; compiled modules; a problem?
+ (number->string
+ (hash (syntax->datum orig-form) most-positive-fixnum)
+ 16))))
+ (define (parse body r w s m esew mod)
+ (let lp ((body body) (exps '()))
+ (if (null? body)
+ exps
+ (lp (cdr body)
+ (append (parse1 (car body) r w s m esew mod)
+ exps)))))
+ (define (parse1 x r w s m esew mod)
(call-with-values
(lambda ()
- (call-with-values
- (lambda ()
- (let ((e (car body)))
- (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
- (lambda (type value form e w s mod)
- (case type
- ((begin-form)
- (syntax-case e ()
- ((_) exps)
- ((_ e1 e2 ...)
- (scan #'(e1 e2 ...) r w s m esew mod exps))))
- ((local-syntax-form)
- (expand-local-syntax value e r w s mod
- (lambda (body r w s mod)
- (scan body r w s m esew mod exps))))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (parse-when-list e #'(x ...)))
- (body #'(e1 e2 ...)))
- (cond
- ((eq? m 'e)
- (if (memq 'eval when-list)
- (scan body r w s
- (if (memq 'expand when-list) 'c&e 'e)
- '(eval)
- mod exps)
- (begin
- (if (memq 'expand when-list)
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod))
- (values exps))))
- ((memq 'load when-list)
- (if (or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (scan body r w s 'c&e '(compile load) mod exps)
- (if (memq m '(c c&e))
- (scan body r w s 'c '(load) mod exps)
- (values exps))))
- ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod)
- (values exps))
- (else
- (values exps)))))))
- ((define-syntax-form define-syntax-parameter-form)
- (let ((n (id-var-name value w)) (r (macros-only-env r)))
- (case m
- ((c)
- (if (memq 'compile esew)
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (if (memq 'load esew)
- (values (cons e exps))
- (values exps)))
- (if (memq 'load esew)
- (values (cons (expand-install-global n (expand e r w mod))
- exps))
- (values exps))))
- ((c&e)
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (values (cons e exps))))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (expand-install-global n (expand e r w mod))
- mod))
- (values exps)))))
- ((define-form)
- (let* ((n (id-var-name value w))
- ;; Lookup the name in the module of the define form.
- (type (binding-type (lookup n r mod))))
- (case type
- ((global core macro module-ref)
- ;; affect compile-time environment (once we have booted)
- (if (and (memq m '(c c&e))
- (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
- (if (and (variable? old)
- (variable-bound? old)
- (not (macro? (variable-ref old))))
- (module-define! (current-module) n (variable-ref old))
- (module-add! (current-module) n (make-undefined-variable)))))
- (values
- (cons
- (if (eq? m 'c&e)
- (let ((x (build-global-definition s n (expand e r w mod))))
- (top-level-eval-hook x mod)
- x)
- (lambda ()
- (build-global-definition s n (expand e r w mod))))
- exps)))
- ((displaced-lexical)
- (syntax-violation #f "identifier out of context"
- (source-wrap form w s mod)
- (wrap value w mod)))
- (else
- (syntax-violation #f "cannot define keyword at top level"
- (source-wrap form w s mod)
- (wrap value w mod))))))
- (else
- (values (cons
- (if (eq? m 'c&e)
- (let ((x (expand-expr type value form e r w s mod)))
- (top-level-eval-hook x mod)
- x)
- (lambda ()
- (expand-expr type value form e r w s mod)))
- exps)))))))
- (lambda (exps)
- (scan (cdr body) r w s m esew mod exps))))))
-
- (call-with-values (lambda ()
- (scan body r w s m esew mod '()))
- (lambda (exps)
+ (syntax-type x r w (source-annotation x) ribcage mod #f))
+ (lambda (type value form e w s mod)
+ (case type
+ ((define-form)
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (list
+ (if (eq? m 'c&e)
+ (let ((x (build-global-definition s var (expand e r w mod))))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (call-with-values
+ (lambda () (resolve-identifier id empty-wrap r mod #t))
+ (lambda (type* value* mod*)
+ ;; If the identifier to be bound is currently bound to a
+ ;; macro, then immediately discard that binding.
+ (if (eq? type* 'macro)
+ (top-level-eval-hook (build-global-definition
+ s var (build-void s))
+ mod))
+ (lambda ()
+ (build-global-definition s var (expand e r w mod)))))))))
+ ((define-syntax-form define-syntax-parameter-form)
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (case m
+ ((c)
+ (cond
+ ((memq 'compile esew)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (if (memq 'load esew)
+ (list (lambda () e))
+ '())))
+ ((memq 'load esew)
+ (list (lambda ()
+ (expand-install-global var type (expand e r w mod)))))
+ (else '())))
+ ((c&e)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (list (lambda () e))))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (expand-install-global var type (expand e r w mod))
+ mod))
+ '()))))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 ...)
+ (parse #'(e1 ...) r w s m esew mod))))
+ ((local-syntax-form)
+ (expand-local-syntax value e r w s mod
+ (lambda (forms r w s mod)
+ (parse forms r w s m esew mod))))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (parse-when-list e #'(x ...)))
+ (body #'(e1 e2 ...)))
+ (define (recurse m esew)
+ (parse body r w s m esew mod))
+ (cond
+ ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (recurse (if (memq 'expand when-list) 'c&e 'e)
+ '(eval))
+ (begin
+ (if (memq 'expand when-list)
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod))
+ '())))
+ ((memq 'load when-list)
+ (if (or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (recurse 'c&e '(compile load))
+ (if (memq m '(c c&e))
+ (recurse 'c '(load))
+ '())))
+ ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod)
+ '())
+ (else
+ '()))))))
+ (else
+ (list
+ (if (eq? m 'c&e)
+ (let ((x (expand-expr type value form e r w s mod)))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda ()
+ (expand-expr type value form e r w s mod)))))))))
+ (let ((exps (map (lambda (x) (x))
+ (reverse (parse body r w s m esew mod)))))
(if (null? exps)
(build-void s)
- (build-sequence
- s
- (let lp ((in exps) (out '()))
- (if (null? in) out
- (let ((e (car in)))
- (lp (cdr in)
- (cons (if (procedure? e) (e) e) out)))))))))))
+ (build-sequence s exps))))))
(define expand-install-global
- (lambda (name e)
+ (lambda (name type e)
(build-global-definition
no-source
name
- (build-application
+ (build-primcall
no-source
- (build-primref no-source 'make-syntax-transformer)
- (list (build-data no-source name)
- (build-data no-source 'macro)
- e)))))
-
+ 'make-syntax-transformer
+ (if (eq? type 'define-syntax-parameter-form)
+ (list (build-data no-source name)
+ (build-data no-source 'syntax-parameter)
+ (build-primcall no-source 'list (list e)))
+ (list (build-data no-source name)
+ (build-data no-source 'macro)
+ e))))))
+
(define parse-when-list
(lambda (e when-list)
- ;; when-list is syntax'd version of list of situations
+ ;; `when-list' is syntax'd version of list of situations. We
+ ;; could match these keywords lexically, via free-id=?, but then
+ ;; we twingle the definition of eval-when to the bindings of
+ ;; eval, load, expand, and compile, which is totally unintended.
+ ;; So do a symbolic match instead.
(let ((result (strip when-list empty-wrap)))
(let lp ((l result))
(if (null? l)
;; displaced-lexical none displaced lexical identifier
;; lexical-call name call to lexical variable
;; global-call name call to global variable
+ ;; primitive-call name call to primitive
;; call none any other call
;; begin-form none begin expression
;; define-form id variable definition
(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 e w s mod))
- ((global) (values type n e e w s mod))
- ((macro)
- (if for-car?
- (values type (binding-value b) e e w s mod)
- (syntax-type (expand-macro (binding-value b) e r w s rib mod)
- r empty-wrap s rib mod #f)))
- (else (values type (binding-value b) e e w s mod)))))
+ (call-with-values (lambda () (resolve-identifier e w r mod #t))
+ (lambda (type value mod*)
+ (case type
+ ((macro)
+ (if for-car?
+ (values type value e e w s mod)
+ (syntax-type (expand-macro value e r w s rib mod)
+ r empty-wrap s rib mod #f)))
+ ((global)
+ ;; Toplevel definitions may resolve to bindings with
+ ;; different names or in different modules.
+ (values type value e value w s mod*))
+ (else (values type value e e w s mod))))))
((pair? e)
(let ((first (car e)))
(call-with-values
((lexical)
(values 'lexical-call fval e 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 e w s mod))
+ (if (equal? fmod '(primitive))
+ (values 'primitive-call fval e e w s mod)
+ ;; 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 e w s mod)))
((macro)
(syntax-type (expand-macro fval e r w s rib mod)
r empty-wrap s rib mod for-car?))
((module-ref)
- (call-with-values (lambda () (fval e r w))
+ (call-with-values (lambda () (fval e r w mod))
(lambda (e r w s mod)
(syntax-type e r w s rib mod for-car?))))
((core)
;; apply transformer
(value e r w s mod))
((module-ref)
- (call-with-values (lambda () (value e r w))
+ (call-with-values (lambda () (value e r w mod))
(lambda (e r w s mod)
(expand e r w mod))))
((lexical-call)
- (expand-application
+ (expand-call
(let ((id (car e)))
(build-lexical-reference 'fun (source-annotation id)
(if (syntax-object? id)
value))
e r w s mod))
((global-call)
- (expand-application
+ (expand-call
(build-global-reference (source-annotation (car e))
(if (syntax-object? value)
(syntax-object-expression value)
(syntax-object-module value)
mod))
e r w s mod))
+ ((primitive-call)
+ (syntax-case e ()
+ ((_ e ...)
+ (build-primcall s
+ value
+ (map (lambda (e) (expand e r w mod))
+ #'(e ...))))))
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value mod))
- ((call) (expand-application (expand (car e) r w mod) e r w s mod))
+ ((call) (expand-call (expand (car e) r w mod) e r w s mod))
((begin-form)
(syntax-case e ()
((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))
((_)
- (if (include-deprecated-features)
- (begin
- (issue-deprecation-warning
- "Sequences of zero expressions are deprecated. Use *unspecified*.")
- (expand-void))
- (syntax-violation #f "sequence of zero expressions"
- (source-wrap e w s mod))))))
+ (syntax-violation #f "sequence of zero expressions"
+ (source-wrap e w s mod)))))
((local-syntax-form)
(expand-local-syntax value e r w s mod expand-sequence))
((eval-when-form)
(else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod))))))
- (define expand-application
+ (define expand-call
(lambda (x e r w s mod)
(syntax-case e ()
((e0 e1 ...)
- (build-application s x
- (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
+ (build-call s x
+ (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
;; (What follows is my interpretation of what's going on here -- Andy)
;;
;;
;; The only wrinkle is when we want a macro to expand to code in another
;; module, as is the case for the r6rs `library' form -- the body expressions
- ;; should be scoped relative the new module, the one defined by the macro.
+ ;; should be scoped relative the the new module, the one defined by the macro.
;; For that, use `(@@ mod-name body)'.
;;
;; Part of the macro output will be from the site of the macro use and part
(cons id var-ids)
(cons var vars) (cons (cons er (wrap e w mod)) vals)
(cons (make-binding 'lexical var) bindings)))))
- ((define-syntax-form define-syntax-parameter-form)
+ ((define-syntax-form)
(let ((id (wrap value w mod))
(label (gen-label))
(trans-r (macros-only-env er)))
;; compile-time environment immediately, so that the newly-defined
;; keywords may be used in definition context within the same
;; lexical contour.
- (set-cdr! r (extend-env (list label)
- (list (make-binding 'macro
- (eval-local-transformer
- (expand e trans-r w mod)
- mod)))
- (cdr r)))
+ (set-cdr! r (extend-env
+ (list label)
+ (list (make-binding
+ 'macro
+ (eval-local-transformer
+ (expand e trans-r w mod)
+ mod)))
+ (cdr r)))
+ (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
+ ((define-syntax-parameter-form)
+ ;; Same as define-syntax-form, but different format of the binding.
+ (let ((id (wrap value w mod))
+ (label (gen-label))
+ (trans-r (macros-only-env er)))
+ (extend-ribcage! ribcage id label)
+ (set-cdr! r (extend-env
+ (list label)
+ (list (make-binding
+ 'syntax-parameter
+ (list (eval-local-transformer
+ (expand e trans-r w mod)
+ mod))))
+ (cdr r)))
(parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
((begin-form)
(syntax-case e ()
;; then the binding's value specifies the custom ellipsis
;; identifier within that lexical environment, and the
;; comparison is done using 'bound-id=?'.
- (let* ((id (make-syntax-object '#{ $sc-ellipsis }#
- (syntax-object-wrap e)
- (syntax-object-module e)))
- (n (id-var-name id empty-wrap))
- (b (lookup n r mod)))
- (if (eq? (binding-type b) 'ellipsis)
- (bound-id=? e (binding-value b))
- (free-id=? e #'(... ...)))))))
+ (call-with-values
+ (lambda () (resolve-identifier
+ (make-syntax-object '#{ $sc-ellipsis }#
+ (syntax-object-wrap e)
+ (syntax-object-module e))
+ empty-wrap r mod #f))
+ (lambda (type value mod)
+ (if (eq? type 'ellipsis)
+ (bound-id=? e value)
+ (free-id=? e #'(... ...))))))))
(define lambda-formals
(lambda (orig-args)
(global-extend 'local-syntax 'letrec-syntax #t)
(global-extend 'local-syntax 'let-syntax #f)
- (global-extend 'core 'syntax-parameterize
- (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 'syntax-parameterize
- "identifier out of context"
- e
- (source-wrap id w s mod)))))
- #'(var ...)
- names)
- (expand-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 (expand x trans-r w mod)
- mod)))
- #'(val ...)))
- r)
- w
- mod)))
- (_ (syntax-violation 'syntax-parameterize "bad syntax"
- (source-wrap e w s mod))))))
+ (global-extend
+ 'core 'syntax-parameterize
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ ((var val) ...) e1 e2 ...)
+ (valid-bound-ids? #'(var ...))
+ (let ((names
+ (map (lambda (x)
+ (call-with-values
+ (lambda () (resolve-identifier x w r mod #f))
+ (lambda (type value mod)
+ (case type
+ ((displaced-lexical)
+ (syntax-violation 'syntax-parameterize
+ "identifier out of context"
+ e
+ (source-wrap x w s mod)))
+ ((syntax-parameter)
+ value)
+ (else
+ (syntax-violation 'syntax-parameterize
+ "invalid syntax parameter"
+ e
+ (source-wrap x w s mod)))))))
+ #'(var ...)))
+ (bindings
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (make-binding
+ 'macro
+ (eval-local-transformer (expand x trans-r w mod) mod)))
+ #'(val ...)))))
+ (expand-body #'(e1 e2 ...)
+ (source-wrap e w s mod)
+ (extend-env names bindings r)
+ w
+ mod)))
+ (_ (syntax-violation 'syntax-parameterize "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'quote
(lambda (e r w s mod)
(_ (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)))
- ;; Mod does not matter, we are looking to see if
- ;; the id is lexical syntax.
- (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 r mod)
- (syntax-violation 'syntax "misplaced ellipsis" src)
- (values `(quote ,e) maps)))))
- (syntax-case e ()
- ((dots e)
- (ellipsis? #'dots r mod)
- (gen-syntax src #'e r maps (lambda (e r mod) #f) mod))
- ((x dots . y)
- ;; this could be about a dozen lines of code, except that we
- ;; choose to handle #'(x ... ...) forms
- (ellipsis? #'dots r mod)
- (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 r mod)
- (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) '() (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)
+ (global-extend
+ 'core 'syntax
+ (let ()
+ (define gen-syntax
+ (lambda (src e r maps ellipsis? mod)
+ (if (id? e)
+ (call-with-values (lambda ()
+ (resolve-identifier e empty-wrap r mod #f))
+ (lambda (type value mod)
+ (case type
+ ((syntax)
+ (call-with-values
+ (lambda () (gen-ref src (car value) (cdr value) maps))
+ (lambda (var maps)
+ (values `(ref ,var) maps))))
+ (else
+ (if (ellipsis? e r mod)
+ (syntax-violation 'syntax "misplaced ellipsis" src)
+ (values `(quote ,e) maps))))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? #'dots r mod)
+ (gen-syntax src #'e r maps (lambda (e r mod) #f) mod))
+ ((x dots . y)
+ ;; this could be about a dozen lines of code, except that we
+ ;; choose to handle #'(x ... ...) forms
+ (ellipsis? #'dots r mod)
+ (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 r mod)
+ (f #'y
+ (lambda (maps)
(call-with-values
- (lambda () (gen-syntax e #'x r '() ellipsis? mod))
- (lambda (e maps) (regen e))))
- (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
+ (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) '() (regen (caddr x)))
+ (error "how did we get here" x)))
+ (else (build-primcall 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-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 ((n (id-var-name #'id w))
- ;; Lookup id in its module
- (id-mod (if (syntax-object? #'id)
- (syntax-object-module #'id)
- mod)))
- (let ((b (lookup n r id-mod)))
- (case (binding-type b)
- ((lexical)
- (build-lexical-assignment s
- (syntax->datum #'id)
- (binding-value b)
- (expand #'val r w mod)))
- ((global)
- (build-global-assignment s n (expand #'val r w mod) id-mod))
- ((macro)
- (let ((p (binding-value b)))
- (if (procedure-property p 'variable-transformer)
- ;; As syntax-type does, call expand-macro with
- ;; the mod of the expression. Hmm.
- (expand (expand-macro p e r w s #f mod) r empty-wrap mod)
- (syntax-violation 'set! "not a variable transformer"
- (wrap e w mod)
- (wrap #'id w id-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 formform ee ww ss modmod)
- (case type
- ((module-ref)
- (let ((val (expand #'val r w mod)))
- (call-with-values (lambda () (value #'(head tail ...) r w))
- (lambda (e r w s* mod)
- (syntax-case e ()
- (e (id? #'e)
- (build-global-assignment s (syntax->datum #'e)
- val mod)))))))
- (else
- (build-application s
- (expand #'(setter head) r w mod)
- (map (lambda (e) (expand e r w mod))
- #'(tail ... val))))))))
- (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
+ (global-extend
+ 'core 'set!
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ id val)
+ (id? #'id)
+ (call-with-values
+ (lambda () (resolve-identifier #'id w r mod #t))
+ (lambda (type value id-mod)
+ (case type
+ ((lexical)
+ (build-lexical-assignment s (syntax->datum #'id) value
+ (expand #'val r w mod)))
+ ((global)
+ (build-global-assignment s value (expand #'val r w mod) id-mod))
+ ((macro)
+ (if (procedure-property value 'variable-transformer)
+ ;; As syntax-type does, call expand-macro with
+ ;; the mod of the expression. Hmm.
+ (expand (expand-macro value e r w s #f mod) r empty-wrap mod)
+ (syntax-violation 'set! "not a variable transformer"
+ (wrap e w mod)
+ (wrap #'id w id-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* ee ww ss modmod)
+ (case type
+ ((module-ref)
+ (let ((val (expand #'val r w mod)))
+ (call-with-values (lambda () (value #'(head tail ...) r w mod))
+ (lambda (e r w s* mod)
+ (syntax-case e ()
+ (e (id? #'e)
+ (build-global-assignment s (syntax->datum #'e)
+ val mod)))))))
+ (else
+ (build-call s
+ (expand #'(setter head) r w mod)
+ (map (lambda (e) (expand e r w mod))
+ #'(tail ... val))))))))
+ (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@
- (lambda (e r w)
+ (lambda (e r w mod)
(syntax-case e ()
((_ (mod ...) id)
(and (and-map id? #'(mod ...)) (id? #'id))
#'(public mod ...)))))))
(global-extend 'module-ref '@@
- (lambda (e r w)
+ (lambda (e r w mod)
(define remodulate
(lambda (x mod)
(cond ((pair? x)
((fx= i n) v)
(vector-set! v i (remodulate (vector-ref x i) mod)))))
(else x))))
- (syntax-case e (@@)
+ (syntax-case e (@@ primitive)
+ ((_ primitive id)
+ (and (id? #'id)
+ (equal? (cdr (if (syntax-object? #'id)
+ (syntax-object-module #'id)
+ mod))
+ '(guile)))
+ ;; Strip the wrap from the identifier and return top-wrap
+ ;; so that the identifier will not be captured by lexicals.
+ (values (syntax->datum #'id) r top-wrap #f '(primitive)))
((_ (mod ...) id)
(and (and-map id? #'(mod ...)) (id? #'id))
;; Strip the wrap from the identifier and return top-wrap
(expand #'then r w mod)
(expand #'else r w mod))))))
- (global-extend 'core 'with-fluids
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((fluid val) ...) b b* ...)
- (build-dynlet
- s
- (map (lambda (x) (expand x r w mod)) #'(fluid ...))
- (map (lambda (x) (expand x r w mod)) #'(val ...))
- (expand-body #'(b b* ...)
- (source-wrap e w s mod) r w mod))))))
-
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())
(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 '()
- (expand 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))))))
+ (build-primcall
+ no-source
+ 'apply
+ (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
+ (expand 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)
(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) '()
- (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)))))))))))))
+ (build-call no-source
+ (build-simple-lambda no-source (list 'tmp) #f (list y) '()
+ (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-primcall no-source 'list (list x))
+ (build-primcall 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))
+ (build-primcall 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)
(expand #'exp r empty-wrap mod)
(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)
- '()
- (expand #'exp
- (extend-env labels
- (list (make-binding 'syntax `(,var . 0)))
- r)
- (make-binding-wrap #'(pat)
- labels empty-wrap)
- mod))
- (list x))))
+ (build-call no-source
+ (build-simple-lambda
+ no-source (list (syntax->datum #'pat)) #f (list var)
+ '()
+ (expand #'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)
#'(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) '()
- (gen-syntax-case (build-lexical-reference 'value no-source
- 'tmp x)
- #'(key ...) #'(m ...)
- r
- mod))
- (list (expand #'val r empty-wrap mod))))
+ (build-call s
+ (build-simple-lambda no-source (list 'tmp) #f (list x) '()
+ (gen-syntax-case (build-lexical-reference 'value no-source
+ 'tmp x)
+ #'(key ...) #'(m ...)
+ r
+ mod))
+ (list (expand #'val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e))))))))
;; The portable macroexpand seeds expand-top's mode m with 'e (for
(let ()
(define (syntax-module id)
(arg-check nonsymbol-id? id 'syntax-module)
- (cdr (syntax-object-module id)))
+ (let ((mod (syntax-object-module id)))
+ (and (not (equal? mod '(primitive)))
+ (cdr mod))))
- (define (syntax-local-binding id)
+ (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t))
(arg-check nonsymbol-id? id 'syntax-local-binding)
(with-transformer-environment
(lambda (e r w s rib mod)
(syntax-object-expression id)
(strip-anti-mark (syntax-object-wrap id))
r
- (syntax-object-module id)))
+ (syntax-object-module id)
+ resolve-syntax-parameters?))
(lambda (type value mod)
(case type
((lexical) (values 'lexical value))
((macro) (values 'macro value))
+ ((syntax-parameter) (values 'syntax-parameter (car value)))
((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f))
- ((global) (values 'global (cons value (cdr mod))))
+ ((global)
+ (if (equal? mod '(primitive))
+ (values 'primitive value)
+ (values 'global (cons value (cdr mod)))))
((ellipsis)
(values 'ellipsis
(make-syntax-object (syntax-object-expression value)
+++ /dev/null
-;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
-;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
-
-;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 2010, 2011, 2012 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License 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
-
-(eval-when (compile)
- (set-current-module (resolve-module '(guile))))
-
-\f
-;;;; apply and call-with-current-continuation
-
-;;; The deal with these is that they are the procedural wrappers around the
-;;; primitives of Guile's language. There are about 20 different kinds of
-;;; expression in Guile, and e.g. @apply is one of them. (It has to be that way
-;;; to preserve tail recursion.)
-;;;
-;;; Usually we recognize (apply foo bar) to be an instance of @apply, but in the
-;;; case that apply is passed to apply, or we're bootstrapping, we need a
-;;; trampoline -- and here they are.
-(define (apply fun . args)
- (@apply fun (apply:nconc2last args)))
-(define (call-with-current-continuation proc)
- (@call-with-current-continuation proc))
-(define (call-with-values producer consumer)
- (@call-with-values producer consumer))
-(define (dynamic-wind in thunk out)
- "All three arguments must be 0-argument procedures.
-Guard @var{in} is called, then @var{thunk}, then
-guard @var{out}.
-
-If, any time during the execution of @var{thunk}, the
-continuation of the @code{dynamic_wind} expression is escaped
-non-locally, @var{out} is called. If the continuation of
-the dynamic-wind is re-entered, @var{in} is called. Thus
-@var{in} and @var{out} may be called any number of
-times.
-@lisp
- (define x 'normal-binding)
-@result{} x
- (define a-cont
- (call-with-current-continuation
- (lambda (escape)
- (let ((old-x x))
- (dynamic-wind
- ;; in-guard:
- ;;
- (lambda () (set! x 'special-binding))
-
- ;; thunk
- ;;
- (lambda () (display x) (newline)
- (call-with-current-continuation escape)
- (display x) (newline)
- x)
-
- ;; out-guard:
- ;;
- (lambda () (set! x old-x)))))))
-
-;; Prints:
-special-binding
-;; Evaluates to:
-@result{} a-cont
-x
-@result{} normal-binding
- (a-cont #f)
-;; Prints:
-special-binding
-;; Evaluates to:
-@result{} a-cont ;; the value of the (define a-cont...)
-x
-@result{} normal-binding
-a-cont
-@result{} special-binding
-@end lisp"
- (@dynamic-wind in (thunk) out))
-
-\f
-;;;; Basic Port Code
-
-;;; Specifically, the parts of the low-level port code that are written in
-;;; Scheme rather than C.
-;;;
-;;; WARNING: the parts of this interface that refer to file ports
-;;; are going away. It would be gone already except that it is used
-;;; "internally" in a few places.
-
-
-;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the
-;;; proper mode to open files in.
-;;;
-;;; If we want to support systems that do CRLF->LF translation, like
-;;; Windows, then we should have a symbol in scmconfig.h made visible
-;;; to the Scheme level that we can test here, and autoconf magic to
-;;; #define it when appropriate. Windows will probably just have a
-;;; hand-generated scmconfig.h file.
-(define OPEN_READ "r")
-(define OPEN_WRITE "w")
-(define OPEN_BOTH "r+")
-
-(define *null-device* "/dev/null")
-
-(define (open-input-file str)
- "Takes a string naming an existing file and returns an input port
-capable of delivering characters from the file. If the file
-cannot be opened, an error is signalled."
- (open-file str OPEN_READ))
-
-(define (open-output-file str)
- "Takes a string naming an output file to be created and returns an
-output port capable of writing characters to a new file by that
-name. If the file cannot be opened, an error is signalled. If a
-file with the given name already exists, the effect is unspecified."
- (open-file str OPEN_WRITE))
-
-(define (open-io-file str)
- "Open file with name STR for both input and output."
- (open-file str OPEN_BOTH))
-
-(define (call-with-input-file str proc)
- "PROC should be a procedure of one argument, and STR should be a
-string naming a file. The file must
-already exist. These procedures call PROC
-with one argument: the port obtained by opening the named file for
-input or output. If the file cannot be opened, an error is
-signalled. If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned.
-If the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will
-never again be used for a read or write operation."
- (let ((p (open-input-file str)))
- (call-with-values
- (lambda () (proc p))
- (lambda vals
- (close-input-port p)
- (apply values vals)))))
-
-(define (call-with-output-file str proc)
- "PROC should be a procedure of one argument, and STR should be a
-string naming a file. The behaviour is unspecified if the file
-already exists. These procedures call PROC
-with one argument: the port obtained by opening the named file for
-input or output. If the file cannot be opened, an error is
-signalled. If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned.
-If the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will
-never again be used for a read or write operation."
- (let ((p (open-output-file str)))
- (call-with-values
- (lambda () (proc p))
- (lambda vals
- (close-output-port p)
- (apply values vals)))))
-
-(define (with-input-from-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-output-to-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-error-to-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-input-from-file file thunk)
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The file must already exist. The file is opened for
-input, an input port connected to it is made
-the default value returned by `current-input-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-input-file file
- (lambda (p) (with-input-from-port p thunk))))
-
-(define (with-output-to-file file thunk)
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
-The file is opened for output, an output port connected to it is made
-the default value returned by `current-output-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-output-file file
- (lambda (p) (with-output-to-port p thunk))))
-
-(define (with-error-to-file file thunk)
- "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file. The effect is unspecified if the file already exists.
-The file is opened for output, an output port connected to it is made
-the default value returned by `current-error-port',
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed and the previous
-default is restored. Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-output-file file
- (lambda (p) (with-error-to-port p thunk))))
-
-(define (with-input-from-string string thunk)
- "THUNK must be a procedure of no arguments.
-The test of STRING is opened for
-input, an input port connected to it is made,
-and the THUNK is called with no arguments.
-When the THUNK returns, the port is closed.
-Returns the values yielded by THUNK. If an
-escape procedure is used to escape from the continuation of these
-procedures, their behavior is implementation dependent."
- (call-with-input-string string
- (lambda (p) (with-input-from-port p thunk))))
-
-(define (with-output-to-string thunk)
- "Calls THUNK and returns its output as a string."
- (call-with-output-string
- (lambda (p) (with-output-to-port p thunk))))
-
-(define (with-error-to-string thunk)
- "Calls THUNK and returns its error output as a string."
- (call-with-output-string
- (lambda (p) (with-error-to-port p thunk))))
-
-(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2014
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
(define-module (ice-9 save-stack)
;; Replace deprecated root-module bindings, if present.
- #:replace (stack-saved?
- the-last-stack
- save-stack))
+ #:export (stack-saved?
+ the-last-stack
+ save-stack))
;; FIXME: stack-saved? is broken in the presence of threads.
(define stack-saved? #f)
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2014
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
#:export (scm-repl-silent
scm-repl-print-unspecified
scm-repl-verbose
- scm-repl-prompt)
-
- ;; #:replace, as with deprecated code enabled these will be in the root env
- #:replace (assert-repl-silence
- assert-repl-print-unspecified
- assert-repl-verbosity
-
- default-pre-unwind-handler
- bad-throw
- error-catching-loop
- error-catching-repl
- scm-style-repl
- handle-system-error))
+ scm-repl-prompt
+ assert-repl-silence
+ assert-repl-print-unspecified
+ assert-repl-verbosity
+
+ default-pre-unwind-handler
+ bad-throw
+ error-catching-loop
+ error-catching-repl
+ scm-style-repl
+ handle-system-error))
(define scm-repl-silent #f)
(define (assert-repl-silence v) (set! scm-repl-silent v))
;;;; Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010, 2011,
-;;;; 2012 Free Software Foundation, Inc.
+;;;; 2012, 2013 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
;;; installed-scm-file
-;;;; Copyright (C) 2003, 2006, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2011, 2014 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
(define-module (ice-9 weak-vector)
- :export (make-weak-vector list->weak-vector weak-vector weak-vector?
- weak-vector-length weak-vector-ref weak-vector-set!
- make-weak-key-alist-vector
- make-weak-value-alist-vector
- make-doubly-weak-alist-vector
- weak-key-alist-vector?
- weak-value-alist-vector?
- doubly-weak-alist-vector?) ; C
- )
+ #:export (make-weak-vector
+ list->weak-vector
+ weak-vector
+ weak-vector?
+ weak-vector-ref
+ weak-vector-set!))
-(%init-weaks-builtins) ; defined in libguile/weaks.c
+(eval-when (load eval compile)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_weak_vector_builtins"))
+++ /dev/null
-;;; Guile Virtual Machine Assembly
-
-;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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 assembly)
- #:use-module (rnrs bytevectors)
- #:use-module (system base pmatch)
- #:use-module (system vm instruction)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:export (byte-length
- addr+ align-program align-code align-block
- assembly-pack assembly-unpack
- object->assembly assembly->object))
-
-;; len, metalen
-(define *program-header-len* (+ 4 4))
-
-;; lengths are encoded in 3 bytes
-(define *len-len* 3)
-
-
-(define (byte-length assembly)
- (pmatch assembly
- ((,inst . _) (guard (>= (instruction-length inst) 0))
- (+ 1 (instruction-length inst)))
- ((load-number ,str)
- (+ 1 *len-len* (string-length str)))
- ((load-string ,str)
- (+ 1 *len-len* (string-length str)))
- ((load-wide-string ,str)
- (+ 1 *len-len* (* 4 (string-length str))))
- ((load-symbol ,str)
- (+ 1 *len-len* (string-length str)))
- ((load-array ,bv)
- (+ 1 *len-len* (bytevector-length bv)))
- ((load-program ,labels ,len ,meta . ,code)
- (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
- (,label (guard (not (pair? label)))
- 0)
- (else (error "unknown instruction" assembly))))
-
-
-(define *program-alignment* 8)
-
-(define (addr+ addr code)
- (fold (lambda (x len) (+ (byte-length x) len))
- addr
- code))
-
-(define (code-alignment addr alignment header-len)
- (make-list (modulo (- alignment
- (modulo (+ addr header-len) alignment))
- alignment)
- '(nop)))
-
-(define (align-block addr)
- '())
-
-(define (align-code code addr alignment header-len)
- `(,@(code-alignment addr alignment header-len)
- ,code))
-
-(define (align-program prog addr)
- (align-code prog addr *program-alignment* 1))
-
-;;;
-;;; Code compress/decompression
-;;;
-
-(define *abbreviations*
- '(((make-int8 0) . (make-int8:0))
- ((make-int8 1) . (make-int8:1))))
-
-(define *expansions*
- (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*))
-
-(define (assembly-pack code)
- (or (assoc-ref *abbreviations* code)
- code))
-
-(define (assembly-unpack code)
- (or (assoc-ref *expansions* code)
- code))
-
-\f
-;;;
-;;; Encoder/decoder
-;;;
-
-(define (object->assembly x)
- (cond ((eq? x #t) `(make-true))
- ((eq? x #f) `(make-false))
- ((eq? x #nil) `(make-nil))
- ((null? x) `(make-eol))
- ((and (integer? x) (exact? x))
- (cond ((and (<= -128 x) (< x 128))
- (assembly-pack `(make-int8 ,(modulo x 256))))
- ((and (<= -32768 x) (< x 32768))
- (let ((n (if (< x 0) (+ x 65536) x)))
- `(make-int16 ,(quotient n 256) ,(modulo n 256))))
- ((and (<= 0 x #xffffffffffffffff))
- `(make-uint64 ,@(bytevector->u8-list
- (let ((bv (make-bytevector 8)))
- (bytevector-u64-set! bv 0 x (endianness big))
- bv))))
- ((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff))
- `(make-int64 ,@(bytevector->u8-list
- (let ((bv (make-bytevector 8)))
- (bytevector-s64-set! bv 0 x (endianness big))
- bv))))
- (else #f)))
- ((char? x)
- (cond ((<= (char->integer x) #xff)
- `(make-char8 ,(char->integer x)))
- (else
- `(make-char32 ,(char->integer x)))))
- (else #f)))
-
-(define (assembly->object code)
- (pmatch code
- ((make-true) #t)
- ((make-false) #f) ;; FIXME: Same as the `else' case!
- ((make-nil) #nil)
- ((make-eol) '())
- ((make-int8 ,n)
- (if (< n 128) n (- n 256)))
- ((make-int16 ,n1 ,n2)
- (let ((n (+ (* n1 256) n2)))
- (if (< n 32768) n (- n 65536))))
- ((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
- (bytevector-u64-ref
- (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
- 0
- (endianness big)))
- ((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
- (bytevector-s64-ref
- (u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
- 0
- (endianness big)))
- ((make-char8 ,n)
- (integer->char n))
- ((make-char32 ,n1 ,n2 ,n3 ,n4)
- (integer->char (+ (* n1 #x1000000)
- (* n2 #x10000)
- (* n3 #x100)
- n4)))
- ((load-string ,s) s)
- ((load-symbol ,s) (string->symbol s))
- (else #f)))
+++ /dev/null
-;;; Guile VM assembler
-
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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 assembly compile-bytecode)
- #:use-module (system base pmatch)
- #:use-module (system base target)
- #:use-module (language assembly)
- #:use-module (system vm instruction)
- #:use-module (rnrs bytevectors)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:export (compile-bytecode))
-
-(define (compile-bytecode assembly env . opts)
- (define-syntax-rule (define-inline1 (proc arg) body body* ...)
- (define-syntax proc
- (syntax-rules ()
- ((_ (arg-expr (... ...)))
- (let ((x (arg-expr (... ...))))
- (proc x)))
- ((_ arg)
- (begin body body* ...)))))
-
- (define (fill-bytecode bv target-endianness)
- (let ((pos 0))
- (define-inline1 (write-byte b)
- (bytevector-u8-set! bv pos b)
- (set! pos (1+ pos)))
- (define u32-bv (make-bytevector 4))
- (define-inline1 (write-int24-be x)
- (bytevector-s32-set! u32-bv 0 x (endianness big))
- (bytevector-u8-set! bv pos (bytevector-u8-ref u32-bv 1))
- (bytevector-u8-set! bv (+ pos 1) (bytevector-u8-ref u32-bv 2))
- (bytevector-u8-set! bv (+ pos 2) (bytevector-u8-ref u32-bv 3))
- (set! pos (+ pos 3)))
- (define-inline1 (write-uint32-be x)
- (bytevector-u32-set! bv pos x (endianness big))
- (set! pos (+ pos 4)))
- (define-inline1 (write-uint32 x)
- (bytevector-u32-set! bv pos x target-endianness)
- (set! pos (+ pos 4)))
- (define-inline1 (write-loader-len len)
- (bytevector-u8-set! bv pos (ash len -16))
- (bytevector-u8-set! bv (+ pos 1) (logand (ash len -8) 255))
- (bytevector-u8-set! bv (+ pos 2) (logand len 255))
- (set! pos (+ pos 3)))
- (define-inline1 (write-latin1-string s)
- (let ((len (string-length s)))
- (write-loader-len len)
- (let lp ((i 0))
- (if (< i len)
- (begin
- (bytevector-u8-set! bv (+ pos i)
- (char->integer (string-ref s i)))
- (lp (1+ i)))))
- (set! pos (+ pos len))))
- (define-inline1 (write-bytevector bv*)
- (let ((len (bytevector-length bv*)))
- (write-loader-len len)
- (bytevector-copy! bv* 0 bv pos len)
- (set! pos (+ pos len))))
- (define-inline1 (write-wide-string s)
- (write-bytevector (string->utf32 s target-endianness)))
- (define-inline1 (write-break label)
- (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-int24-be offset)))))
-
- (define (write-bytecode asm labels address emit-opcode?)
- ;; Write ASM's bytecode to BV. If EMIT-OPCODE? is false, don't
- ;; emit bytecode for the first opcode encountered. Assume code
- ;; starts at ADDRESS (an integer). LABELS is assumed to be an
- ;; alist mapping labels to addresses.
- (define get-addr
- (let ((start pos))
- (lambda ()
- (+ address (- pos start)))))
- (define (write-break label)
- (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-int24-be offset)))))
-
- (let ((inst (car asm))
- (args (cdr asm)))
- (let ((opcode (instruction->opcode inst))
- (len (instruction-length inst)))
- (if emit-opcode?
- (write-byte opcode))
- (pmatch asm
- ((load-program ,labels ,length ,meta . ,code)
- (write-uint32 length)
- (write-uint32 (if meta (1- (byte-length meta)) 0))
- (fold (lambda (asm address)
- (let ((start pos))
- (write-bytecode asm labels address #t)
- (+ address (- pos start))))
- 0
- code)
- (if meta
- ;; Don't emit the `load-program' byte for metadata. Note that
- ;; META's bytecode meets the alignment requirements of
- ;; `scm_objcode', thanks to the alignment computed in `(language
- ;; assembly)'.
- (write-bytecode meta '() 0 #f)))
- ((make-char32 ,x) (write-uint32-be x))
- ((load-number ,str) (write-latin1-string str))
- ((load-string ,str) (write-latin1-string str))
- ((load-wide-string ,str) (write-wide-string str))
- ((load-symbol ,str) (write-latin1-string str))
- ((load-array ,bv) (write-bytevector bv))
- ((br ,l) (write-break l))
- ((br-if ,l) (write-break l))
- ((br-if-not ,l) (write-break l))
- ((br-if-eq ,l) (write-break l))
- ((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))
- ((bind-optionals/shuffle-or-br ,nreq-hi ,nreq-lo
- ,nreq-and-nopt-hi ,nreq-and-nopt-lo
- ,ntotal-hi ,ntotal-lo
- ,l)
- (write-byte nreq-hi)
- (write-byte nreq-lo)
- (write-byte nreq-and-nopt-hi)
- (write-byte nreq-and-nopt-lo)
- (write-byte ntotal-hi)
- (write-byte ntotal-lo)
- (write-break l))
- ((mv-call ,n ,l) (write-byte n) (write-break l))
- ((prompt ,escape-only? ,l) (write-byte escape-only?) (write-break l))
- (else
- (cond
- ((< len 0)
- (error "unhanded variable-length instruction" asm))
- ((not (= (length args) len))
- (error "bad number of args to instruction" asm len))
- (else
- (for-each (lambda (x) (write-byte x)) args))))))))
-
- ;; Don't emit the `load-program' byte.
- (write-bytecode assembly '() 0 #f)
- (if (= pos (bytevector-length bv))
- (values bv env env)
- (error "failed to fill bytevector" bv pos
- (bytevector-length bv)))))
-
- (pmatch assembly
- ((load-program ,labels ,length ,meta . ,code)
- (fill-bytecode (make-bytevector (+ 4 4 length
- (if meta
- (1- (byte-length meta))
- 0)))
- (target-endianness)))
-
- (else (error "bad assembly" assembly))))
+++ /dev/null
-;;; Guile VM code converters
-
-;; Copyright (C) 2001, 2009, 2010, 2013 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 assembly decompile-bytecode)
- #:use-module (system vm instruction)
- #:use-module (system base pmatch)
- #:use-module (srfi srfi-4)
- #:use-module (rnrs bytevectors)
- #:use-module (language assembly)
- #:use-module ((system vm objcode) #:select (byte-order))
- #:export (decompile-bytecode))
-
-(define (decompile-bytecode x env opts)
- (let ((i 0) (size (u8vector-length x)))
- (define (pop)
- (let ((b (cond ((< i size) (u8vector-ref x i))
- ((= i size) #f)
- (else (error "tried to decode too many bytes")))))
- (if b (set! i (1+ i)))
- b))
- (let ((ret (decode-load-program pop)))
- (if (= i size)
- (values ret env)
- (error "bad bytecode: only decoded ~a out of ~a bytes" i size)))))
-
-(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 br-if-nargs-lt/non-kw)))
-
-(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 24)))))
-
-;; FIXME: this is a little-endian disassembly!!!
-(define (decode-load-program 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)))
- (labels '())
- (i 0))
- (define (ensure-label rel1 rel2 rel3)
- (let ((where (+ i (bytes->s24 rel1 rel2 rel3))))
- (or (assv-ref labels where)
- (begin
- (let ((l (gensym ":L")))
- (set! labels (acons where l labels))
- l)))))
- (define (sub-pop) ;; ...records. ha. ha.
- (let ((b (cond ((< i len) (pop))
- ((= i len) #f)
- (else (error "tried to decode too many bytes")))))
- (if b (set! i (1+ i)))
- b))
- (let lp ((out '()))
- (cond ((> i len)
- (error "error decoding program -- read too many bytes" out))
- ((= i len)
- `(load-program ,(map (lambda (x) (cons (cdr x) (car x)))
- (reverse labels))
- ,len
- ,(if (zero? metalen) #f (decode-load-program pop))
- ,@(reverse! out)))
- (else
- (let ((exp (decode-bytecode sub-pop)))
- (pmatch exp
- ((,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)))
- ((bind-optionals/shuffle-or-br ,nreq-hi ,nreq-lo
- ,nreq-and-nopt-hi ,nreq-and-nopt-lo
- ,ntotal-hi ,ntotal-lo
- ,rel1 ,rel2 ,rel3)
- (lp (cons `(bind-optionals/shuffle-or-br
- ,nreq-hi ,nreq-lo
- ,nreq-and-nopt-hi ,nreq-and-nopt-lo
- ,ntotal-hi ,ntotal-lo
- ,(ensure-label rel1 rel2 rel3))
- out)))
- ((mv-call ,n ,rel1 ,rel2 ,rel3)
- (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2 rel3)) out)))
- ((prompt ,n0 ,rel1 ,rel2 ,rel3)
- (lp (cons `(prompt ,n0 ,(ensure-label rel1 rel2 rel3)) out)))
- (else
- (lp (cons exp out))))))))))
-
-(define (decode-bytecode pop)
- (and=> (pop)
- (lambda (opcode)
- (let ((inst (opcode->instruction opcode)))
- (cond
- ((eq? inst 'load-program)
- (decode-load-program pop))
-
- ((< (instruction-length inst) 0)
- ;; the negative length indicates a variable length
- ;; instruction
- (let* ((make-sequence
- (if (or (memq inst '(load-array load-wide-string)))
- make-bytevector
- make-string))
- (sequence-set!
- (if (or (memq inst '(load-array load-wide-string)))
- bytevector-u8-set!
- (lambda (str pos value)
- (string-set! str pos (integer->char value)))))
- (len (let* ((a (pop)) (b (pop)) (c (pop)))
- (+ (ash a 16) (ash b 8) c)))
- (seq (make-sequence len)))
- (let lp ((i 0))
- (if (= i len)
- `(,inst ,(if (eq? inst 'load-wide-string)
- (utf32->string seq (native-endianness))
- seq))
- (begin
- (sequence-set! seq i (pop))
- (lp (1+ i)))))))
- (else
- ;; fixed length
- (let lp ((n (instruction-length inst)) (out (list inst)))
- (if (zero? n)
- (reverse! out)
- (lp (1- n) (cons (pop) out))))))))))
+++ /dev/null
-;;; Guile VM code converters
-
-;; Copyright (C) 2001, 2009, 2010, 2012, 2013 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 assembly disassemble)
- #:use-module (ice-9 format)
- #:use-module (srfi srfi-1)
- #:use-module (system vm instruction)
- #:use-module (system vm program)
- #:use-module (system base pmatch)
- #:use-module (language assembly)
- #:use-module (system base compile)
- #:export (disassemble))
-
-(define (disassemble x)
- (format #t "Disassembly of ~A:\n\n" x)
- (call-with-values
- (lambda () (decompile x #:from 'value #:to 'assembly))
- disassemble-load-program))
-
-(define (disassemble-load-program asm env)
- (pmatch asm
- ((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)))
- (blocs (and env (assq-ref env 'blocs)))
- (srcs (and env (assq-ref env 'sources))))
- (let lp ((pos 0) (code code) (programs '()))
- (cond
- ((null? code)
- (newline)
- (for-each
- (lambda (sym+asm)
- (format #t "Embedded program ~A:\n\n" (car sym+asm))
- (disassemble-load-program (cdr sym+asm) '()))
- (reverse! programs)))
- (else
- (let* ((asm (car code))
- (len (byte-length asm))
- (end (+ pos len)))
- (pmatch asm
- ((load-program . _)
- (let ((sym (gensym "")))
- (print-info pos `(load-program ,sym) #f #f)
- (lp (+ pos (byte-length asm)) (cdr code)
- (acons sym asm programs))))
- ((nop)
- (lp (+ pos (byte-length asm)) (cdr code) programs))
- (else
- (print-info pos asm
- ;; 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)))))))
-
- (if (pair? free-vars)
- (disassemble-free-vars free-vars))
- (if meta
- (disassemble-meta meta))
-
- ;; Disassemble other bytecode in it
- ;; FIXME: something about the module.
- (if objs
- (for-each
- (lambda (x)
- (if (program? x)
- (begin (display "----------------------------------------\n")
- (disassemble x))))
- (cdr (vector->list objs))))))
- (else
- (error "bad load-program form" asm))))
-
-(define (disassemble-free-vars free-vars)
- (display "Free variables:\n\n")
- (fold (lambda (free-var i)
- (print-info i free-var #f #f)
- (+ 1 i))
- 0
- free-vars))
-
-(define-macro (unless test . body)
- `(if (not ,test) (begin ,@body)))
-
-(define *uninteresting-props* '(name))
-
-(define (disassemble-meta meta)
- (let ((props (filter (lambda (x)
- (not (memq (car x) *uninteresting-props*)))
- (cdddr meta))))
- (unless (null? props)
- (display "Properties:\n\n")
- (for-each (lambda (x) (print-info #f x #f #f)) props)
- (newline))))
-
-(define (source->string src)
- (format #f "~a:~a:~a" (or (source:file src) "(unknown file)")
- (source:line-for-user src) (source:column src)))
-
-(define (make-int16 byte1 byte2)
- (+ (* byte1 256) byte2))
-
-(define (code-annotation end-addr code objs nargs blocs labels)
- (let* ((code (assembly-unpack code))
- (inst (car code))
- (args (cdr code)))
- (case inst
- ((list vector)
- (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))))
- ((bind-optionals/shuffle-or-br)
- (list "-> ~A" (assq-ref labels (car (last-pair args)))))
- ((object-ref)
- (and objs (list "~s" (vector-ref objs (car args)))))
- ((local-ref local-boxed-ref local-set local-boxed-set)
- (and blocs
- (let lp ((bindings (list-ref blocs (car args))))
- (and (pair? bindings)
- (let ((b (car bindings)))
- (if (and (< (binding:start (car bindings)) end-addr)
- (>= (binding:end (car bindings)) end-addr))
- (list "`~a'~@[ (arg)~]"
- (binding:name b) (< (binding:index b) nargs))
- (lp (cdr bindings))))))))
- ((assert-nargs-ee/locals assert-nargs-ge/locals)
- (list "~a arg~:p, ~a local~:p"
- (logand (car args) #x7) (ash (car args) -3)))
- ((free-ref free-boxed-ref free-boxed-set)
- ;; FIXME: we can do better than this
- (list "(closure variable)"))
- ((toplevel-ref toplevel-set)
- (and objs
- (let ((v (vector-ref objs (car args))))
- (if (and (variable? v) (variable-bound? v))
- (list "~s" (variable-ref v))
- (list "`~s'" v)))))
- ((mv-call)
- (list "MV -> ~A" (assq-ref labels (cadr args))))
- ((prompt)
- ;; the H is for handler
- (list "H -> ~A" (assq-ref labels (cadr args))))
- (else
- (and=> (assembly->object code)
- (lambda (obj) (list "~s" obj)))))))
-
-;; i am format's daddy.
-(define (print-info addr info extra src)
- (format #t "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src))
;;; Brainfuck for GNU Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
(parse-tree-il
`(let (pointer tape) (pointer tape)
((const 0)
- (apply (primitive make-vector) (const ,tape-size) (const 0)))
+ (call (primitive make-vector) (const ,tape-size) (const 0)))
,(compile-body exp)))
env
env))
(cond
((null? in)
;; No more input, build our output.
- (cond
- ((null? out) '(void)) ; no output
- ((null? (cdr out)) (car out)) ; single expression
- (else `(begin ,@(reverse out)))) ; sequence
- )
+ (cond
+ ((null? out) '(void)) ; no output
+ ((null? (cdr out)) (car out)) ; single expression
+ (else `(begin ,@(reverse out)))) ; sequence
+ )
(else
(pmatch (car in)
;; (set! pointer (+ pointer +-1))
((<bf-move> ,dir)
(emit `(set! (lexical pointer)
- (apply (primitive +) (lexical pointer) (const ,dir)))))
+ (call (primitive +) (lexical pointer) (const ,dir)))))
;; Cell increment +- is done as:
;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
((<bf-increment> ,inc)
- (emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer)
- (apply (primitive +)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const ,inc)))))
+ (emit `(call (primitive vector-set!) (lexical tape) (lexical pointer)
+ (call (primitive +)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const ,inc)))))
;; Output . is done by converting the cell's integer value to a
;; character first and then printing out this character:
;; (write-char (integer->char (vector-ref tape pointer)))
((<bf-print>)
- (emit `(apply (primitive write-char)
- (apply (primitive integer->char)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))))))
+ (emit `(call (primitive write-char)
+ (call (primitive integer->char)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))))))
;; Input , is done similarly, read in a character, get its ASCII
;; code and store it into the current cell:
;; (vector-set! tape pointer (char->integer (read-char)))
((<bf-read>)
- (emit `(apply (primitive vector-set!)
- (lexical tape) (lexical pointer)
- (apply (primitive char->integer)
- (apply (primitive read-char))))))
+ (emit `(call (primitive vector-set!)
+ (lexical tape) (lexical pointer)
+ (call (primitive char->integer)
+ (call (primitive read-char))))))
;; For loops [...] we use a letrec construction to execute the body until
;; the current cell gets zero. The body is compiled via a recursive call
((lambda ()
(lambda-case
((() #f #f #f () ())
- (if (apply (primitive =)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const 0))
+ (if (call (primitive =)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const 0))
(void)
(begin ,(compile-body body)
- (apply (lexical ,iterate)))))
+ (call (lexical ,iterate)))))
#f)))
- (apply (lexical ,iterate))))))
+ (call (lexical ,iterate))))))
(else (error "unknown brainfuck instruction" (car in))))))))
--- /dev/null
+;;; Bytecode
+
+;; Copyright (C) 2013 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 bytecode)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:export (instruction-list
+ instruction-arity
+ builtin-name->index
+ builtin-index->name))
+
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_instructions")
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_vm_builtins")
+
+(define (compute-instruction-arity name args)
+ (define (first-word-arity word)
+ (case word
+ ((U8_X24) 0)
+ ((U8_U24) 1)
+ ((U8_L24) 1)
+ ((U8_U8_I16) 2)
+ ((U8_U12_U12) 2)
+ ((U8_U8_U8_U8) 3)))
+ (define (tail-word-arity word)
+ (case word
+ ((U8_U24) 2)
+ ((U8_L24) 2)
+ ((U8_U8_I16) 3)
+ ((U8_U12_U12) 3)
+ ((U8_U8_U8_U8) 4)
+ ((U32) 1)
+ ((I32) 1)
+ ((A32) 1)
+ ((B32) 0)
+ ((N32) 1)
+ ((S32) 1)
+ ((L32) 1)
+ ((LO32) 1)
+ ((X8_U24) 1)
+ ((X8_U12_U12) 2)
+ ((X8_L24) 1)
+ ((B1_X7_L24) 2)
+ ((B1_U7_L24) 3)
+ ((B1_X31) 1)
+ ((B1_X7_U24) 2)))
+ (match args
+ ((arg0 . args)
+ (fold (lambda (arg arity)
+ (+ (tail-word-arity arg) arity))
+ (first-word-arity arg0)
+ args))))
+
+(define *macro-instruction-arities*
+ '((cache-current-module! . (0 . 2))
+ (cached-toplevel-box . (1 . 3))
+ (cached-module-box . (1 . 4))))
+
+(define (compute-instruction-arities)
+ (let ((table (make-hash-table)))
+ (for-each
+ (match-lambda
+ ;; Put special cases here.
+ ((name op '! . args)
+ (hashq-set! table name
+ (cons 0 (compute-instruction-arity name args))))
+ ((name op '<- . args)
+ (hashq-set! table name
+ (cons 1 (1- (compute-instruction-arity name args))))))
+ (instruction-list))
+ (for-each (match-lambda
+ ((name . arity)
+ (hashq-set! table name arity)))
+ *macro-instruction-arities*)
+ table))
+
+(define *instruction-arities* (delay (compute-instruction-arities)))
+
+(define (instruction-arity name)
+ (hashq-ref (force *instruction-arities*) name))
-;;; Guile Lowlevel Intermediate Language
+;;; Bytecode
-;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013 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 (language glil spec)
+(define-module (language bytecode spec)
#:use-module (system base language)
- #:use-module (language glil)
- #:use-module (language glil compile-assembly)
- #:export (glil))
+ #:use-module (system vm loader)
+ #:use-module (ice-9 binary-ports)
+ #:export (bytecode))
-(define (write-glil exp . port)
- (apply write (unparse-glil exp) port))
+(define (bytecode->value x e opts)
+ (let ((thunk (load-thunk-from-memory x)))
+ (if (eq? e (current-module))
+ ;; save a cons in this case
+ (values (thunk) e e)
+ (save-module-excursion
+ (lambda ()
+ (set-current-module e)
+ (values (thunk) e e))))))
-(define (compile-asm x e opts)
- (values (compile-assembly x) e e))
-
-(define-language glil
- #:title "Guile Lowlevel Intermediate Language (GLIL)"
- #:reader (lambda (port env) (read port))
- #:printer write-glil
- #:parser parse-glil
- #:compilers `((assembly . ,compile-asm))
- #:for-humans? #f
- )
+(define-language bytecode
+ #:title "Bytecode"
+ #:compilers `((value . ,bytecode->value))
+ #:printer (lambda (bytecode port) (put-bytevector port bytecode))
+ #:reader get-bytevector-all
+ #:for-humans? #f)
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; This is the continuation-passing style (CPS) intermediate language
+;;; (IL) for Guile.
+;;;
+;;; There are two kinds of terms in CPS: terms that bind continuations,
+;;; and terms that call continuations.
+;;;
+;;; $letk binds a set of mutually recursive continuations, each one an
+;;; instance of $cont. A $cont declares the name of a continuation, and
+;;; then contains as a subterm the particular continuation instance:
+;;; $kargs for continuations that bind values, $ktail for the tail
+;;; continuation, etc.
+;;;
+;;; $continue nodes call continuations. The expression contained in the
+;;; $continue node determines the value or values that are passed to the
+;;; target continuation: $const to pass a constant value, $values to
+;;; pass multiple named values, etc. $continue nodes also record the source at which
+;;;
+;;; Additionally there is $letrec, a term that binds mutually recursive
+;;; functions. The contification pass will turn $letrec into $letk if
+;;; it can do so. Otherwise, the closure conversion pass will desugar
+;;; $letrec into an equivalent sequence of make-closure primcalls and
+;;; subsequent initializations of the captured variables of the
+;;; closures. You can think of $letrec as pertaining to "high CPS",
+;;; whereas later passes will only see "low CPS", which does not have
+;;; $letrec.
+;;;
+;;; This particular formulation of CPS was inspired by Andrew Kennedy's
+;;; 2007 paper, "Compiling with Continuations, Continued". All Guile
+;;; hackers should read that excellent paper! As in Kennedy's paper,
+;;; continuations are second-class, and may be thought of as basic block
+;;; labels. All values are bound to variables using continuation calls:
+;;; even constants!
+;;;
+;;; There are some Guile-specific quirks as well:
+;;;
+;;; - $kreceive represents a continuation that receives multiple values,
+;;; but which truncates them to some number of required values,
+;;; possibly with a rest list.
+;;;
+;;; - $kfun labels an entry point for a $fun (a function), and
+;;; contains a $ktail representing the formal argument which is the
+;;; function's continuation.
+;;;
+;;; - $kfun also contain a $kclause continuation, corresponding to
+;;; the first case-lambda clause of the function. $kclause actually
+;;; contains the clause body, and the subsequent clause (if any).
+;;; This is because the $kclause logically matches or doesn't match
+;;; a given set of actual arguments against a formal arity, then
+;;; proceeds to a "body" continuation (which is a $kargs).
+;;;
+;;; That's to say that a $fun can be matched like this:
+;;;
+;;; (match f
+;;; (($ $fun free
+;;; ($ $cont kfun
+;;; ($ $kfun src meta self ($ $cont ktail ($ $ktail))
+;;; ($ $kclause arity
+;;; ($ $cont kbody ($ $kargs names syms body))
+;;; alternate))))
+;;; #t))
+;;;
+;;; A $continue to ktail is in tail position. $kfun, $kclause,
+;;; and $ktail will never be seen elsewhere in a CPS term.
+;;;
+;;; - $prompt continues to the body of the prompt, having pushed on a
+;;; prompt whose handler will continue at its "handler"
+;;; continuation. The continuation of the prompt is responsible for
+;;; popping the prompt.
+;;;
+;;; In summary:
+;;;
+;;; - $letk, $letrec, and $continue are terms.
+;;;
+;;; - $cont is a continuation, containing a continuation body ($kargs,
+;;; $ktail, etc).
+;;;
+;;; - $continue terms contain an expression ($call, $const, $fun,
+;;; etc).
+;;;
+;;; See (language tree-il compile-cps) for details on how Tree-IL
+;;; converts to CPS.
+;;;
+;;; Code:
+
+(define-module (language cps)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
+ #:export (;; Helper.
+ $arity
+ make-$arity
+
+ ;; Terms.
+ $letk $continue $letrec
+
+ ;; Continuations.
+ $cont
+
+ ;; Continuation bodies.
+ $kreceive $kargs $kfun $ktail $kclause
+
+ ;; Expressions.
+ $void $const $prim $fun $closure $branch
+ $call $callk $primcall $values $prompt
+
+ ;; First-order CPS root.
+ $program
+
+ ;; Fresh names.
+ label-counter var-counter
+ fresh-label fresh-var
+ with-fresh-name-state compute-max-label-and-var
+ let-fresh
+
+ ;; Building macros.
+ build-cps-term build-cps-cont build-cps-exp
+ rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
+
+ ;; Misc.
+ parse-cps unparse-cps
+ make-global-cont-folder make-local-cont-folder
+ fold-conts fold-local-conts
+ visit-cont-successors))
+
+;; FIXME: Use SRFI-99, when Guile adds it.
+(define-syntax define-record-type*
+ (lambda (x)
+ (define (id-append ctx . syms)
+ (datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
+ (syntax-case x ()
+ ((_ name field ...)
+ (and (identifier? #'name) (and-map identifier? #'(field ...)))
+ (with-syntax ((cons (id-append #'name #'make- #'name))
+ (pred (id-append #'name #'name #'?))
+ ((getter ...) (map (lambda (f)
+ (id-append f #'name #'- f))
+ #'(field ...))))
+ #'(define-record-type name
+ (cons field ...)
+ pred
+ (field getter)
+ ...))))))
+
+(define-syntax-rule (define-cps-type name field ...)
+ (begin
+ (define-record-type* name field ...)
+ (set-record-type-printer! name print-cps)))
+
+(define (print-cps exp port)
+ (format port "#<cps ~S>" (unparse-cps exp)))
+
+;; Helper.
+(define-record-type* $arity req opt rest kw allow-other-keys?)
+
+;; Terms.
+(define-cps-type $letk conts body)
+(define-cps-type $continue k src exp)
+(define-cps-type $letrec names syms funs body) ; Higher-order.
+
+;; Continuations
+(define-cps-type $cont k cont)
+(define-cps-type $kreceive arity k)
+(define-cps-type $kargs names syms body)
+(define-cps-type $kfun src meta self tail clause)
+(define-cps-type $ktail)
+(define-cps-type $kclause arity cont alternate)
+
+;; Expressions.
+(define-cps-type $void)
+(define-cps-type $const val)
+(define-cps-type $prim name)
+(define-cps-type $fun free body) ; Higher-order.
+(define-cps-type $closure label nfree) ; First-order.
+(define-cps-type $branch k exp)
+(define-cps-type $call proc args)
+(define-cps-type $callk k proc args) ; First-order.
+(define-cps-type $primcall name args)
+(define-cps-type $values args)
+(define-cps-type $prompt escape? tag handler)
+
+;; The root of a higher-order CPS term is $cont containing a $kfun. The
+;; root of a first-order CPS term is a $program.
+(define-cps-type $program funs)
+
+(define label-counter (make-parameter #f))
+(define var-counter (make-parameter #f))
+
+(define (fresh-label)
+ (let ((count (or (label-counter)
+ (error "fresh-label outside with-fresh-name-state"))))
+ (label-counter (1+ count))
+ count))
+
+(define (fresh-var)
+ (let ((count (or (var-counter)
+ (error "fresh-var outside with-fresh-name-state"))))
+ (var-counter (1+ count))
+ count))
+
+(define-syntax-rule (let-fresh (label ...) (var ...) body ...)
+ (let ((label (fresh-label)) ...
+ (var (fresh-var)) ...)
+ body ...))
+
+(define-syntax-rule (with-fresh-name-state fun body ...)
+ (call-with-values (lambda () (compute-max-label-and-var fun))
+ (lambda (max-label max-var)
+ (parameterize ((label-counter (1+ max-label))
+ (var-counter (1+ max-var)))
+ body ...))))
+
+(define-syntax build-arity
+ (syntax-rules (unquote)
+ ((_ (unquote exp)) exp)
+ ((_ (req opt rest kw allow-other-keys?))
+ (make-$arity req opt rest kw allow-other-keys?))))
+
+(define-syntax build-cont-body
+ (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($kreceive req rest kargs))
+ (make-$kreceive (make-$arity req '() rest '() #f) kargs))
+ ((_ ($kargs (name ...) (unquote syms) body))
+ (make-$kargs (list name ...) syms (build-cps-term body)))
+ ((_ ($kargs (name ...) (sym ...) body))
+ (make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
+ ((_ ($kargs names syms body))
+ (make-$kargs names syms (build-cps-term body)))
+ ((_ ($kfun src meta self tail clause))
+ (make-$kfun src meta self (build-cps-cont tail) (build-cps-cont clause)))
+ ((_ ($ktail))
+ (make-$ktail))
+ ((_ ($kclause arity cont alternate))
+ (make-$kclause (build-arity arity) (build-cps-cont cont)
+ (build-cps-cont alternate)))))
+
+(define-syntax build-cps-cont
+ (syntax-rules (unquote)
+ ((_ (unquote exp)) exp)
+ ((_ (k cont)) (make-$cont k (build-cont-body cont)))))
+
+(define-syntax build-cps-exp
+ (syntax-rules (unquote
+ $void $const $prim $fun $closure $branch
+ $call $callk $primcall $values $prompt)
+ ((_ (unquote exp)) exp)
+ ((_ ($void)) (make-$void))
+ ((_ ($const val)) (make-$const val))
+ ((_ ($prim name)) (make-$prim name))
+ ((_ ($fun free body)) (make-$fun free (build-cps-cont body)))
+ ((_ ($closure k nfree)) (make-$closure k nfree))
+ ((_ ($call proc (unquote args))) (make-$call proc args))
+ ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
+ ((_ ($call proc args)) (make-$call proc args))
+ ((_ ($callk k proc (unquote args))) (make-$callk k proc args))
+ ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...)))
+ ((_ ($callk k proc args)) (make-$callk k proc args))
+ ((_ ($primcall name (unquote args))) (make-$primcall name args))
+ ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
+ ((_ ($primcall name args)) (make-$primcall name args))
+ ((_ ($values (unquote args))) (make-$values args))
+ ((_ ($values (arg ...))) (make-$values (list arg ...)))
+ ((_ ($values args)) (make-$values args))
+ ((_ ($branch k exp)) (make-$branch k (build-cps-exp exp)))
+ ((_ ($prompt escape? tag handler))
+ (make-$prompt escape? tag handler))))
+
+(define-syntax build-cps-term
+ (syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($letk (unquote conts) body))
+ (make-$letk conts (build-cps-term body)))
+ ((_ ($letk (cont ...) body))
+ (make-$letk (list (build-cps-cont cont) ...)
+ (build-cps-term body)))
+ ((_ ($letk* () body))
+ (build-cps-term body))
+ ((_ ($letk* (cont conts ...) body))
+ (build-cps-term ($letk (cont) ($letk* (conts ...) body))))
+ ((_ ($letconst () body))
+ (build-cps-term body))
+ ((_ ($letconst ((name sym val) tail ...) body))
+ (let-fresh (kconst) ()
+ (build-cps-term
+ ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
+ ($continue kconst (let ((props (source-properties val)))
+ (and (pair? props) props))
+ ($const val))))))
+ ((_ ($letrec names gensyms funs body))
+ (make-$letrec names gensyms funs (build-cps-term body)))
+ ((_ ($program (unquote conts)))
+ (make-$program conts))
+ ((_ ($program (cont ...)))
+ (make-$program (list (build-cps-cont cont) ...)))
+ ((_ ($program conts))
+ (make-$program conts))
+ ((_ ($continue k src exp))
+ (make-$continue k src (build-cps-exp exp)))))
+
+(define-syntax-rule (rewrite-cps-term x (pat body) ...)
+ (match x
+ (pat (build-cps-term body)) ...))
+(define-syntax-rule (rewrite-cps-cont x (pat body) ...)
+ (match x
+ (pat (build-cps-cont body)) ...))
+(define-syntax-rule (rewrite-cps-exp x (pat body) ...)
+ (match x
+ (pat (build-cps-exp body)) ...))
+
+(define (parse-cps exp)
+ (define (src exp)
+ (let ((props (source-properties exp)))
+ (and (pair? props) props)))
+ (match exp
+ ;; Continuations.
+ (('letconst k (name sym c) body)
+ (build-cps-term
+ ($letk ((k ($kargs (name) (sym)
+ ,(parse-cps body))))
+ ($continue k (src exp) ($const c)))))
+ (('let k (name sym val) body)
+ (build-cps-term
+ ($letk ((k ($kargs (name) (sym)
+ ,(parse-cps body))))
+ ,(parse-cps val))))
+ (('letk (cont ...) body)
+ (build-cps-term
+ ($letk ,(map parse-cps cont) ,(parse-cps body))))
+ (('k sym body)
+ (build-cps-cont
+ (sym ,(parse-cps body))))
+ (('kreceive req rest k)
+ (build-cont-body ($kreceive req rest k)))
+ (('kargs names syms body)
+ (build-cont-body ($kargs names syms ,(parse-cps body))))
+ (('kfun src meta self tail clause)
+ (build-cont-body
+ ($kfun (src exp) meta self ,(parse-cps tail)
+ ,(and=> clause parse-cps))))
+ (('ktail)
+ (build-cont-body
+ ($ktail)))
+ (('kclause (req opt rest kw allow-other-keys?) body)
+ (build-cont-body
+ ($kclause (req opt rest kw allow-other-keys?)
+ ,(parse-cps body)
+ ,#f)))
+ (('kclause (req opt rest kw allow-other-keys?) body alternate)
+ (build-cont-body
+ ($kclause (req opt rest kw allow-other-keys?)
+ ,(parse-cps body)
+ ,(parse-cps alternate))))
+ (('kseq body)
+ (build-cont-body ($kargs () () ,(parse-cps body))))
+
+ ;; Calls.
+ (('continue k exp)
+ (build-cps-term ($continue k (src exp) ,(parse-cps exp))))
+ (('void)
+ (build-cps-exp ($void)))
+ (('const exp)
+ (build-cps-exp ($const exp)))
+ (('prim name)
+ (build-cps-exp ($prim name)))
+ (('fun free body)
+ (build-cps-exp ($fun free ,(parse-cps body))))
+ (('closure k nfree)
+ (build-cps-exp ($closure k nfree)))
+ (('letrec ((name sym fun) ...) body)
+ (build-cps-term
+ ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
+ (('program (cont ...))
+ (build-cps-term ($program ,(map parse-cps cont))))
+ (('call proc arg ...)
+ (build-cps-exp ($call proc arg)))
+ (('callk k proc arg ...)
+ (build-cps-exp ($callk k proc arg)))
+ (('primcall name arg ...)
+ (build-cps-exp ($primcall name arg)))
+ (('branch k exp)
+ (build-cps-exp ($branch k ,(parse-cps exp))))
+ (('values arg ...)
+ (build-cps-exp ($values arg)))
+ (('prompt escape? tag handler)
+ (build-cps-exp ($prompt escape? tag handler)))
+ (_
+ (error "unexpected cps" exp))))
+
+(define (unparse-cps exp)
+ (match exp
+ ;; Continuations.
+ (($ $letk (($ $cont k ($ $kargs (name) (sym) body)))
+ ($ $continue k src ($ $const c)))
+ `(letconst ,k (,name ,sym ,c)
+ ,(unparse-cps body)))
+ (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val)
+ `(let ,k (,name ,sym ,(unparse-cps val))
+ ,(unparse-cps body)))
+ (($ $letk conts body)
+ `(letk ,(map unparse-cps conts) ,(unparse-cps body)))
+ (($ $cont sym body)
+ `(k ,sym ,(unparse-cps body)))
+ (($ $kreceive ($ $arity req () rest '() #f) k)
+ `(kreceive ,req ,rest ,k))
+ (($ $kargs () () body)
+ `(kseq ,(unparse-cps body)))
+ (($ $kargs names syms body)
+ `(kargs ,names ,syms ,(unparse-cps body)))
+ (($ $kfun src meta self tail clause)
+ `(kfun ,meta ,self ,(unparse-cps tail) ,(unparse-cps clause)))
+ (($ $ktail)
+ `(ktail))
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
+ `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)
+ . ,(if alternate (list (unparse-cps alternate)) '())))
+
+ ;; Calls.
+ (($ $continue k src exp)
+ `(continue ,k ,(unparse-cps exp)))
+ (($ $void)
+ `(void))
+ (($ $const val)
+ `(const ,val))
+ (($ $prim name)
+ `(prim ,name))
+ (($ $fun free body)
+ `(fun ,free ,(unparse-cps body)))
+ (($ $closure k nfree)
+ `(closure ,k ,nfree))
+ (($ $letrec names syms funs body)
+ `(letrec ,(map (lambda (name sym fun)
+ (list name sym (unparse-cps fun)))
+ names syms funs)
+ ,(unparse-cps body)))
+ (($ $program conts)
+ `(program ,(map unparse-cps conts)))
+ (($ $call proc args)
+ `(call ,proc ,@args))
+ (($ $callk k proc args)
+ `(callk ,k ,proc ,@args))
+ (($ $primcall name args)
+ `(primcall ,name ,@args))
+ (($ $branch k exp)
+ `(branch ,k ,(unparse-cps exp)))
+ (($ $values args)
+ `(values ,@args))
+ (($ $prompt escape? tag handler)
+ `(prompt ,escape? ,tag ,handler))
+ (_
+ (error "unexpected cps" exp))))
+
+(define-syntax-rule (make-global-cont-folder seed ...)
+ (lambda (proc cont seed ...)
+ (define (cont-folder cont seed ...)
+ (match cont
+ (($ $cont k cont)
+ (let-values (((seed ...) (proc k cont seed ...)))
+ (match cont
+ (($ $kargs names syms body)
+ (term-folder body seed ...))
+
+ (($ $kfun src meta self tail clause)
+ (let-values (((seed ...) (cont-folder tail seed ...)))
+ (if clause
+ (cont-folder clause seed ...)
+ (values seed ...))))
+
+ (($ $kclause arity body alternate)
+ (let-values (((seed ...) (cont-folder body seed ...)))
+ (if alternate
+ (cont-folder alternate seed ...)
+ (values seed ...))))
+
+ (_ (values seed ...)))))))
+
+ (define (fun-folder fun seed ...)
+ (match fun
+ (($ $fun free body)
+ (cont-folder body seed ...))))
+
+ (define (term-folder term seed ...)
+ (match term
+ (($ $letk conts body)
+ (let-values (((seed ...) (term-folder body seed ...)))
+ (let lp ((conts conts) (seed seed) ...)
+ (if (null? conts)
+ (values seed ...)
+ (let-values (((seed ...) (cont-folder (car conts) seed ...)))
+ (lp (cdr conts) seed ...))))))
+
+ (($ $continue k src exp)
+ (match exp
+ (($ $fun) (fun-folder exp seed ...))
+ (_ (values seed ...))))
+
+ (($ $letrec names syms funs body)
+ (let-values (((seed ...) (term-folder body seed ...)))
+ (let lp ((funs funs) (seed seed) ...)
+ (if (null? funs)
+ (values seed ...)
+ (let-values (((seed ...) (fun-folder (car funs) seed ...)))
+ (lp (cdr funs) seed ...))))))))
+
+ (cont-folder cont seed ...)))
+
+(define-syntax-rule (make-local-cont-folder seed ...)
+ (lambda (proc cont seed ...)
+ (define (cont-folder cont seed ...)
+ (match cont
+ (($ $cont k (and cont ($ $kargs names syms body)))
+ (let-values (((seed ...) (proc k cont seed ...)))
+ (term-folder body seed ...)))
+ (($ $cont k cont)
+ (proc k cont seed ...))))
+ (define (term-folder term seed ...)
+ (match term
+ (($ $letk conts body)
+ (let-values (((seed ...) (term-folder body seed ...)))
+ (let lp ((conts conts) (seed seed) ...)
+ (match conts
+ (() (values seed ...))
+ ((cont) (cont-folder cont seed ...))
+ ((cont . conts)
+ (let-values (((seed ...) (cont-folder cont seed ...)))
+ (lp conts seed ...)))))))
+ (($ $letrec names syms funs body) (term-folder body seed ...))
+ (_ (values seed ...))))
+ (define (clause-folder clause seed ...)
+ (match clause
+ (($ $cont k (and cont ($ $kclause arity body alternate)))
+ (let-values (((seed ...) (proc k cont seed ...)))
+ (if alternate
+ (let-values (((seed ...) (cont-folder body seed ...)))
+ (clause-folder alternate seed ...))
+ (cont-folder body seed ...))))))
+ (match cont
+ (($ $cont k (and cont ($ $kfun src meta self tail clause)))
+ (let*-values (((seed ...) (proc k cont seed ...))
+ ((seed ...) (if clause
+ (clause-folder clause seed ...)
+ (values seed ...))))
+ (cont-folder tail seed ...))))))
+
+(define (compute-max-label-and-var fun)
+ (match fun
+ (($ $cont)
+ ((make-global-cont-folder max-label max-var)
+ (lambda (label cont max-label max-var)
+ (values (max label max-label)
+ (match cont
+ (($ $kargs names vars body)
+ (let lp ((body body) (max-var (fold max max-var vars)))
+ (match body
+ (($ $letk conts body) (lp body max-var))
+ (($ $letrec names vars funs body)
+ (lp body (fold max max-var vars)))
+ (_ max-var))))
+ (($ $kfun src meta self)
+ (max self max-var))
+ (_ max-var))))
+ fun -1 -1))
+ (($ $program conts)
+ (define (fold/2 proc in s0 s1)
+ (if (null? in)
+ (values s0 s1)
+ (let-values (((s0 s1) (proc (car in) s0 s1)))
+ (fold/2 proc (cdr in) s0 s1))))
+ (let lp ((conts conts) (max-label -1) (max-var -1))
+ (if (null? conts)
+ (values max-label max-var)
+ (call-with-values (lambda ()
+ ((make-local-cont-folder max-label max-var)
+ (lambda (label cont max-label max-var)
+ (values (max label max-label)
+ (match cont
+ (($ $kargs names vars body)
+ (fold max max-var vars))
+ (($ $kfun src meta self)
+ (max self max-var))
+ (_ max-var))))
+ (car conts) max-label max-var))
+ (lambda (max-label max-var)
+ (lp (cdr conts) max-label max-var))))))))
+
+(define (fold-conts proc seed fun)
+ ((make-global-cont-folder seed) proc fun seed))
+
+(define (fold-local-conts proc seed fun)
+ ((make-local-cont-folder seed) proc fun seed))
+
+(define (visit-cont-successors proc cont)
+ (match cont
+ (($ $kargs names syms body)
+ (let lp ((body body))
+ (match body
+ (($ $letk conts body) (lp body))
+ (($ $letrec names vars funs body) (lp body))
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt escape? tag handler) (proc k handler))
+ (($ $branch kt) (proc k kt))
+ (_ (proc k)))))))
+
+ (($ $kreceive arity k) (proc k))
+
+ (($ $kclause arity ($ $cont kbody) #f) (proc kbody))
+
+ (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
+
+ (($ $kfun src meta self tail ($ $cont clause)) (proc clause))
+
+ (($ $kfun src meta self tail #f) (proc))
+
+ (($ $ktail) (proc))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; A pass to adapt expressions to the arities of their continuations,
+;;; and to rewrite some tail expressions as primcalls to "return".
+;;;
+;;; Code:
+
+(define-module (language cps arities)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps primitives)
+ #:export (fix-arities))
+
+(define (fix-arities* clause dfg)
+ (let ((ktail (match clause
+ (($ $cont _
+ ($ $kfun src meta _ ($ $cont ktail) _)) ktail))))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts) ,(visit-term body)))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (map (lambda (fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun free ,(fix-arities* body dfg)))))
+ funs)
+ ,(visit-term body)))
+ (($ $continue k src exp)
+ ,(visit-exp k src exp))))
+
+ (define (adapt-exp nvals k src exp)
+ (match nvals
+ (0
+ (rewrite-cps-term (lookup-cont k dfg)
+ (($ $ktail)
+ ,(let-fresh (kvoid kunspec) (unspec)
+ (build-cps-term
+ ($letk* ((kunspec ($kargs (unspec) (unspec)
+ ($continue k src
+ ($primcall 'return (unspec)))))
+ (kvoid ($kargs () ()
+ ($continue kunspec src ($void)))))
+ ($continue kvoid src ,exp)))))
+ (($ $kreceive arity kargs)
+ ,(match arity
+ (($ $arity () () rest () #f)
+ (if rest
+ (let-fresh (knil) ()
+ (build-cps-term
+ ($letk ((knil ($kargs () ()
+ ($continue kargs src ($const '())))))
+ ($continue knil src ,exp))))
+ (build-cps-term
+ ($continue kargs src ,exp))))
+ (_
+ (let-fresh (kvoid kvalues) (void)
+ (build-cps-term
+ ($letk* ((kvalues ($kargs ('void) (void)
+ ($continue k src
+ ($primcall 'values (void)))))
+ (kvoid ($kargs () ()
+ ($continue kvalues src
+ ($void)))))
+ ($continue kvoid src ,exp)))))))
+ (($ $kargs () () _)
+ ($continue k src ,exp))
+ (_
+ ,(let-fresh (k*) ()
+ (build-cps-term
+ ($letk ((k* ($kargs () () ($continue k src ($void)))))
+ ($continue k* src ,exp)))))))
+ (1
+ (rewrite-cps-term (lookup-cont k dfg)
+ (($ $ktail)
+ ,(rewrite-cps-term exp
+ (($ $values (sym))
+ ($continue ktail src ($primcall 'return (sym))))
+ (_
+ ,(let-fresh (k*) (v)
+ (build-cps-term
+ ($letk ((k* ($kargs (v) (v)
+ ($continue k src
+ ($primcall 'return (v))))))
+ ($continue k* src ,exp)))))))
+ (($ $kreceive arity kargs)
+ ,(match arity
+ (($ $arity (_) () rest () #f)
+ (if rest
+ (let-fresh (kval) (val nil)
+ (build-cps-term
+ ($letk ((kval ($kargs ('val) (val)
+ ($letconst (('nil nil '()))
+ ($continue kargs src
+ ($values (val nil)))))))
+ ($continue kval src ,exp))))
+ (build-cps-term ($continue kargs src ,exp))))
+ (_
+ (let-fresh (kvalues) (value)
+ (build-cps-term
+ ($letk ((kvalues ($kargs ('value) (value)
+ ($continue k src
+ ($primcall 'values (value))))))
+ ($continue kvalues src ,exp)))))))
+ (($ $kargs () () _)
+ ,(let-fresh (k*) (drop)
+ (build-cps-term
+ ($letk ((k* ($kargs ('drop) (drop)
+ ($continue k src ($values ())))))
+ ($continue k* src ,exp)))))
+ (_
+ ($continue k src ,exp))))))
+
+ (define (visit-exp k src exp)
+ (rewrite-cps-term exp
+ ((or ($ $void)
+ ($ $const)
+ ($ $prim)
+ ($ $values (_)))
+ ,(adapt-exp 1 k src exp))
+ (($ $fun free body)
+ ,(adapt-exp 1 k src (build-cps-exp
+ ($fun free ,(fix-arities* body dfg)))))
+ ((or ($ $call) ($ $callk))
+ ;; In general, calls have unknown return arity. For that
+ ;; reason every non-tail call has a $kreceive continuation to
+ ;; adapt the return to the target continuation, and we don't
+ ;; need to do any adapting here.
+ ($continue k src ,exp))
+ (($ $branch)
+ ;; Assume branching primcalls have the correct arity.
+ ($continue k src ,exp))
+ (($ $primcall 'return (arg))
+ ;; Primcalls to return are in tail position.
+ ($continue ktail src ,exp))
+ (($ $primcall (? (lambda (name)
+ (and (not (prim-instruction name))
+ (not (branching-primitive? name))))))
+ ($continue k src ,exp))
+ (($ $primcall name args)
+ ,(match (prim-arity name)
+ ((out . in)
+ (if (= in (length args))
+ (adapt-exp out k src
+ (let ((inst (prim-instruction name)))
+ (if (and inst (not (eq? inst name)))
+ (build-cps-exp ($primcall inst args))
+ exp)))
+ (let-fresh (k*) (p*)
+ (build-cps-term
+ ($letk ((k* ($kargs ('prim) (p*)
+ ($continue k src ($call p* args)))))
+ ($continue k* src ($prim name)))))))))
+ (($ $values)
+ ;; Non-unary values nodes are inserted by CPS optimization
+ ;; passes, so we assume they are correct.
+ ($continue k src ,exp))
+ (($ $prompt)
+ ($continue k src ,exp))))
+
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (($ $cont)
+ ,cont)))
+
+ (rewrite-cps-cont clause
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))))))
+
+(define (fix-arities fun)
+ (let ((dfg (compute-dfg fun)))
+ (with-fresh-name-state-from-dfg dfg
+ (fix-arities* fun dfg))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; This pass converts a CPS term in such a way that no function has any
+;;; free variables. Instead, closures are built explicitly with
+;;; make-closure primcalls, and free variables are referenced through
+;;; the closure.
+;;;
+;;; Closure conversion also removes any $letrec forms that contification
+;;; did not handle. See (language cps) for a further discussion of
+;;; $letrec.
+;;;
+;;; Code:
+
+(define-module (language cps closure-conversion)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold
+ lset-union lset-difference
+ list-index))
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:export (convert-closures))
+
+;; free := var ...
+
+(define (analyze-closures exp dfg)
+ "Compute the set of free variables for all $fun instances in
+@var{exp}."
+ (let ((bound-vars (make-hash-table))
+ (free-vars (make-hash-table))
+ (named-funs (make-hash-table))
+ (well-known-vars (make-bitvector (var-counter) #t)))
+ (define (add-named-fun! var cont)
+ (hashq-set! named-funs var cont)
+ (match cont
+ (($ $cont label ($ $kfun src meta self))
+ (unless (eq? var self)
+ (hashq-set! bound-vars label var)))))
+ (define (clear-well-known! var)
+ (bitvector-set! well-known-vars var #f))
+ (define (compute-well-known-labels)
+ (let ((bv (make-bitvector (label-counter) #f)))
+ (hash-for-each
+ (lambda (var cont)
+ (match cont
+ (($ $cont label ($ $kfun src meta self))
+ (unless (equal? var self)
+ (bitvector-set! bv label
+ (and (bitvector-ref well-known-vars var)
+ (bitvector-ref well-known-vars self)))))))
+ named-funs)
+ bv))
+ (define (union a b)
+ (lset-union eq? a b))
+ (define (difference a b)
+ (lset-difference eq? a b))
+ (define (visit-cont cont bound)
+ (match cont
+ (($ $cont label ($ $kargs names vars body))
+ (visit-term body (append vars bound)))
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (add-named-fun! self cont)
+ (let ((free (if clause
+ (visit-cont clause (list self))
+ '())))
+ (hashq-set! free-vars label free)
+ (difference free bound)))
+ (($ $cont label ($ $kclause arity body alternate))
+ (let ((free (visit-cont body bound)))
+ (if alternate
+ (union (visit-cont alternate bound) free)
+ free)))
+ (($ $cont) '())))
+ (define (visit-term term bound)
+ (match term
+ (($ $letk conts body)
+ (fold (lambda (cont free)
+ (union (visit-cont cont bound) free))
+ (visit-term body bound)
+ conts))
+ (($ $letrec names vars (($ $fun () cont) ...) body)
+ (let ((bound (append vars bound)))
+ (for-each add-named-fun! vars cont)
+ (fold (lambda (cont free)
+ (union (visit-cont cont bound) free))
+ (visit-term body bound)
+ cont)))
+ (($ $continue k src ($ $fun () body))
+ (match (lookup-predecessors k dfg)
+ ((_) (match (lookup-cont k dfg)
+ (($ $kargs (name) (var))
+ (add-named-fun! var body))))
+ (_ #f))
+ (visit-cont body bound))
+ (($ $continue k src exp)
+ (visit-exp exp bound))))
+ (define (visit-exp exp bound)
+ (define (adjoin var free)
+ (if (or (memq var bound) (memq var free))
+ free
+ (cons var free)))
+ (match exp
+ ((or ($ $void) ($ $const) ($ $prim)) '())
+ (($ $call proc args)
+ (for-each clear-well-known! args)
+ (fold adjoin (adjoin proc '()) args))
+ (($ $primcall name args)
+ (for-each clear-well-known! args)
+ (fold adjoin '() args))
+ (($ $branch kt exp)
+ (visit-exp exp bound))
+ (($ $values args)
+ (for-each clear-well-known! args)
+ (fold adjoin '() args))
+ (($ $prompt escape? tag handler)
+ (clear-well-known! tag)
+ (adjoin tag '()))))
+
+ (let ((free (visit-cont exp '())))
+ (unless (null? free)
+ (error "Expected no free vars in toplevel thunk" free exp))
+ (values bound-vars free-vars named-funs (compute-well-known-labels)))))
+
+(define (prune-free-vars free-vars named-funs well-known var-aliases)
+ (define (well-known? label)
+ (bitvector-ref well-known label))
+ (let ((eliminated (make-bitvector (label-counter) #f))
+ (label-aliases (make-vector (label-counter) #f)))
+ (let lp ((label 0))
+ (let ((label (bit-position #t well-known label)))
+ (when label
+ (match (hashq-ref free-vars label)
+ ;; Mark all well-known closures that have no free variables
+ ;; for elimination.
+ (() (bitvector-set! eliminated label #t))
+ ;; Replace well-known closures that have just one free
+ ;; variable by references to that free variable.
+ ((var)
+ (vector-set! label-aliases label var))
+ (_ #f))
+ (lp (1+ label)))))
+ ;; Iterative free variable elimination.
+ (let lp ()
+ (let ((recurse? #f))
+ (define (adjoin elt list)
+ ;; Normally you wouldn't see duplicates in a free variable
+ ;; list, but with aliases that is possible.
+ (if (memq elt list) list (cons elt list)))
+ (define (prune-free closure-label free)
+ (match free
+ (() '())
+ ((var . free)
+ (let lp ((var var) (alias-stack '()))
+ (match (hashq-ref named-funs var)
+ (($ $cont label)
+ (cond
+ ((bitvector-ref eliminated label)
+ (prune-free closure-label free))
+ ((vector-ref label-aliases label)
+ => (lambda (var)
+ (cond
+ ((memq label alias-stack)
+ ;; We have found a set of mutually recursive
+ ;; well-known procedures, each of which only
+ ;; closes over one of the others. Mark them
+ ;; all for elimination.
+ (for-each (lambda (label)
+ (bitvector-set! eliminated label #t)
+ (set! recurse? #t))
+ alias-stack)
+ (prune-free closure-label free))
+ (else
+ (lp var (cons label alias-stack))))))
+ ((eq? closure-label label)
+ ;; Eliminate self-reference.
+ (prune-free closure-label free))
+ (else
+ (adjoin var (prune-free closure-label free)))))
+ (_ (adjoin var (prune-free closure-label free))))))))
+ (hash-for-each-handle
+ (lambda (pair)
+ (match pair
+ ((label . ()) #t)
+ ((label . free)
+ (let ((orig-nfree (length free))
+ (free (prune-free label free)))
+ (set-cdr! pair free)
+ ;; If we managed to eliminate one or more free variables
+ ;; from a well-known function, it could be that we can
+ ;; eliminate or alias this function as well.
+ (when (and (well-known? label)
+ (< (length free) orig-nfree))
+ (match free
+ (()
+ (bitvector-set! eliminated label #t)
+ (set! recurse? #t))
+ ((var)
+ (vector-set! label-aliases label var)
+ (set! recurse? #t))
+ (_ #t)))))))
+ free-vars)
+ ;; Iterate to fixed point.
+ (when recurse? (lp))))
+ ;; Populate var-aliases from label-aliases.
+ (hash-for-each (lambda (var cont)
+ (match cont
+ (($ $cont label)
+ (let ((alias (vector-ref label-aliases label)))
+ (when alias
+ (vector-set! var-aliases var alias))))))
+ named-funs)))
+
+(define (convert-one bound label fun free-vars named-funs well-known aliases)
+ (define (well-known? label)
+ (bitvector-ref well-known label))
+
+ (let ((free (hashq-ref free-vars label))
+ (self-known? (well-known? label))
+ (self (match fun (($ $kfun _ _ self) self))))
+ (define (convert-free-var var k)
+ "Convert one possibly free variable reference to a bound reference.
+
+If @var{var} is free, it is replaced by a closure reference via a
+@code{free-ref} primcall, and @var{k} is called with the new var.
+Otherwise @var{var} is bound, so @var{k} is called with @var{var}."
+ (cond
+ ((list-index (cut eq? <> var) free)
+ => (lambda (free-idx)
+ (match (cons self-known? free)
+ ;; A reference to the one free var of a well-known function.
+ ((#t _) (k self))
+ ;; A reference to one of the two free vars in a well-known
+ ;; function.
+ ((#t _ _)
+ (let-fresh (k*) (var*)
+ (build-cps-term
+ ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
+ ($continue k* #f
+ ($primcall (match free-idx (0 'car) (1 'cdr)) (self)))))))
+ (_
+ (let-fresh (k* kidx) (idx var*)
+ (build-cps-term
+ ($letk ((kidx ($kargs ('idx) (idx)
+ ($letk ((k* ($kargs (var*) (var*) ,(k var*))))
+ ($continue k* #f
+ ($primcall
+ (cond
+ ((not self-known?) 'free-ref)
+ ((<= free-idx #xff) 'vector-ref/immediate)
+ (else 'vector-ref))
+ (self idx)))))))
+ ($continue kidx #f ($const free-idx)))))))))
+ ((eq? var bound) (k self))
+ (else (k var))))
+
+ (define (convert-free-vars vars k)
+ "Convert a number of possibly free references to bound references.
+@var{k} is called with the bound references, and should return the
+term."
+ (match vars
+ (() (k '()))
+ ((var . vars)
+ (convert-free-var var
+ (lambda (var)
+ (convert-free-vars vars
+ (lambda (vars)
+ (k (cons var vars)))))))))
+
+ (define (allocate-closure src name var label known? free body)
+ "Allocate a new closure."
+ (match (cons known? free)
+ ((#f . _)
+ (let-fresh (k*) ()
+ (build-cps-term
+ ($letk ((k* ($kargs (name) (var) ,body)))
+ ($continue k* src
+ ($closure label (length free)))))))
+ ((#t)
+ ;; Well-known closure with no free variables; elide the
+ ;; binding entirely.
+ body)
+ ((#t _)
+ ;; Well-known closure with one free variable; the free var is the
+ ;; closure, and no new binding need be made.
+ body)
+ ((#t _ _)
+ ;; Well-known closure with two free variables; the closure is a
+ ;; pair.
+ (let-fresh (kinit kfalse) (false)
+ (build-cps-term
+ ($letk ((kinit ($kargs (name) (var)
+ ,body))
+ (kfalse ($kargs ('false) (false)
+ ($continue kinit src
+ ($primcall 'cons (false false))))))
+ ($continue kfalse src ($const #f))))))
+ ;; Well-known callee with more than two free variables; the closure
+ ;; is a vector.
+ ((#t . _)
+ (let ((nfree (length free)))
+ (let-fresh (kinit klen kfalse) (false len-var)
+ (build-cps-term
+ ($letk ((kinit ($kargs (name) (var) ,body))
+ (kfalse
+ ($kargs ('false) (false)
+ ($letk ((klen
+ ($kargs ('len) (len-var)
+ ($continue kinit src
+ ($primcall (if (<= nfree #xff)
+ 'make-vector/immediate
+ 'make-vector)
+ (len-var false))))))
+ ($continue klen src ($const nfree))))))
+ ($continue kfalse src ($const #f)))))))))
+
+ (define (init-closure src var known? closure-free body)
+ "Initialize the free variables @var{closure-free} in a closure
+bound to @var{var}, and continue with @var{body}."
+ (match (cons known? closure-free)
+ ;; Well-known callee with no free variables; no initialization
+ ;; necessary.
+ ((#t) body)
+ ;; Well-known callee with one free variable; no initialization
+ ;; necessary.
+ ((#t _) body)
+ ;; Well-known callee with two free variables; do a set-car! and
+ ;; set-cdr!.
+ ((#t v0 v1)
+ (let-fresh (kcar kcdr) ()
+ (convert-free-var
+ v0
+ (lambda (v0)
+ (build-cps-term
+ ($letk ((kcar ($kargs () ()
+ ,(convert-free-var
+ v1
+ (lambda (v1)
+ (build-cps-term
+ ($letk ((kcdr ($kargs () () ,body)))
+ ($continue kcdr src
+ ($primcall 'set-cdr! (var v1))))))))))
+ ($continue kcar src
+ ($primcall 'set-car! (var v0)))))))))
+ ;; Otherwise residualize a sequence of vector-set! or free-set!,
+ ;; depending on whether the callee is well-known or not.
+ (_
+ (fold (lambda (free idx body)
+ (let-fresh (k) (idxvar)
+ (build-cps-term
+ ($letk ((k ($kargs () () ,body)))
+ ,(convert-free-var
+ free
+ (lambda (free)
+ (build-cps-term
+ ($letconst (('idx idxvar idx))
+ ($continue k src
+ ($primcall (cond
+ ((not known?) 'free-set!)
+ ((<= idx #xff) 'vector-set!/immediate)
+ (else 'vector-set!))
+ (var idxvar free)))))))))))
+ body
+ closure-free
+ (iota (length closure-free))))))
+
+ ;; Load the closure for a known call. The callee may or may not be
+ ;; known at all call sites.
+ (define (convert-known-proc-call var label self self-known? free k)
+ ;; Well-known closures with one free variable are replaced at their
+ ;; use sites by uses of the one free variable. The use sites of a
+ ;; well-known closures are only in well-known proc calls, and in
+ ;; free lists of other closures. Here we handle the call case; the
+ ;; free list case is handled by prune-free-vars.
+ (define (rename var)
+ (let ((var* (vector-ref aliases var)))
+ (if var*
+ (rename var*)
+ var)))
+ (match (cons (well-known? label)
+ (hashq-ref free-vars label))
+ ((#t)
+ ;; Calling a well-known procedure with no free variables; pass #f
+ ;; as the closure.
+ (let-fresh (k*) (v*)
+ (build-cps-term
+ ($letk ((k* ($kargs (v*) (v*) ,(k v*))))
+ ($continue k* #f ($const #f))))))
+ ((#t _)
+ ;; Calling a well-known procedure with one free variable; pass
+ ;; the free variable as the closure.
+ (convert-free-var (rename var) k))
+ (_
+ (convert-free-var var k))))
+
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kargs names vars body))
+ (label ($kargs names vars ,(visit-term body))))
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail
+ ,(and clause (visit-cont clause)))))
+ (($ $cont label ($ $kclause arity body alternate))
+ (label ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (($ $cont) ,cont)))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ (build-cps-term
+ ($letk ,(map visit-cont conts) ,(visit-term body))))
+
+ ;; Remove letrec.
+ (($ $letrec names vars funs body)
+ (let lp ((in (map list names vars funs))
+ (bindings (lambda (body) body))
+ (body (visit-term body)))
+ (match in
+ (() (bindings body))
+ (((name var ($ $fun ()
+ (and fun-body
+ ($ $cont kfun ($ $kfun src))))) . in)
+ (let ((fun-free (hashq-ref free-vars kfun)))
+ (lp in
+ (lambda (body)
+ (allocate-closure
+ src name var kfun (well-known? kfun) fun-free
+ (bindings body)))
+ (init-closure
+ src var (well-known? kfun) fun-free
+ body)))))))
+
+ (($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
+ term)
+
+ (($ $continue k src ($ $fun () ($ $cont kfun)))
+ (let ((fun-free (hashq-ref free-vars kfun)))
+ (match (cons (well-known? kfun) fun-free)
+ ((known?)
+ (build-cps-term
+ ($continue k src ,(if known?
+ (build-cps-exp ($const #f))
+ (build-cps-exp ($closure kfun 0))))))
+ ((#t _)
+ ;; A well-known closure of one free variable is replaced
+ ;; at each use with the free variable itself, so we don't
+ ;; need a binding at all; and yet, the continuation
+ ;; expects one value, so give it something. DCE should
+ ;; clean up later.
+ (build-cps-term
+ ($continue k src ,(build-cps-exp ($const #f)))))
+ (_
+ (let-fresh () (var)
+ (allocate-closure
+ src #f var kfun (well-known? kfun) fun-free
+ (init-closure
+ src var (well-known? kfun) fun-free
+ (build-cps-term ($continue k src ($values (var)))))))))))
+
+ (($ $continue k src ($ $call proc args))
+ (match (hashq-ref named-funs proc)
+ (($ $cont kfun)
+ (convert-known-proc-call
+ proc kfun self self-known? free
+ (lambda (proc)
+ (convert-free-vars args
+ (lambda (args)
+ (build-cps-term
+ ($continue k src
+ ($callk kfun proc args))))))))
+ (#f
+ (convert-free-vars (cons proc args)
+ (match-lambda
+ ((proc . args)
+ (build-cps-term
+ ($continue k src
+ ($call proc args)))))))))
+
+ (($ $continue k src ($ $primcall name args))
+ (convert-free-vars args
+ (lambda (args)
+ (build-cps-term
+ ($continue k src ($primcall name args))))))
+
+ (($ $continue k src ($ $branch kt ($ $primcall name args)))
+ (convert-free-vars args
+ (lambda (args)
+ (build-cps-term
+ ($continue k src
+ ($branch kt ($primcall name args)))))))
+
+ (($ $continue k src ($ $branch kt ($ $values (arg))))
+ (convert-free-var arg
+ (lambda (arg)
+ (build-cps-term
+ ($continue k src
+ ($branch kt ($values (arg))))))))
+
+ (($ $continue k src ($ $values args))
+ (convert-free-vars args
+ (lambda (args)
+ (build-cps-term
+ ($continue k src ($values args))))))
+
+ (($ $continue k src ($ $prompt escape? tag handler))
+ (convert-free-var tag
+ (lambda (tag)
+ (build-cps-term
+ ($continue k src
+ ($prompt escape? tag handler))))))))
+ (visit-cont (build-cps-cont (label ,fun)))))
+
+(define (convert-closures fun)
+ "Convert free reference in @var{exp} to primcalls to @code{free-ref},
+and allocate and initialize flat closures."
+ (let ((dfg (compute-dfg fun)))
+ (with-fresh-name-state-from-dfg dfg
+ (call-with-values (lambda () (analyze-closures fun dfg))
+ (lambda (bound-vars free-vars named-funs well-known)
+ (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <))
+ (aliases (make-vector (var-counter) #f)))
+ (prune-free-vars free-vars named-funs well-known aliases)
+ (build-cps-term
+ ($program
+ ,(map (lambda (label)
+ (convert-one (hashq-ref bound-vars label) label
+ (lookup-cont label dfg)
+ free-vars named-funs well-known aliases))
+ labels)))))))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 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
+
+;;; Commentary:
+;;;
+;;; Compiling CPS to bytecode. The result is in the bytecode language,
+;;; which happens to be an ELF image as a bytecode.
+;;;
+;;; Code:
+
+(define-module (language cps compile-bytecode)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (language cps)
+ #:use-module (language cps arities)
+ #:use-module (language cps closure-conversion)
+ #:use-module (language cps contification)
+ #:use-module (language cps constructors)
+ #:use-module (language cps cse)
+ #:use-module (language cps dce)
+ #:use-module (language cps dfg)
+ #:use-module (language cps elide-values)
+ #:use-module (language cps primitives)
+ #:use-module (language cps prune-bailouts)
+ #:use-module (language cps prune-top-level-scopes)
+ #:use-module (language cps reify-primitives)
+ #:use-module (language cps renumber)
+ #:use-module (language cps self-references)
+ #:use-module (language cps simplify)
+ #:use-module (language cps slot-allocation)
+ #:use-module (language cps specialize-primcalls)
+ #:use-module (language cps type-fold)
+ #:use-module (system vm assembler)
+ #:export (compile-bytecode))
+
+;; TODO: Local var names.
+
+(define (kw-arg-ref args kw default)
+ (match (memq kw args)
+ ((_ val . _) val)
+ (_ default)))
+
+(define (optimize exp opts)
+ (define (run-pass exp pass kw default)
+ (if (kw-arg-ref opts kw default)
+ (pass exp)
+ exp))
+
+ ;; The first DCE pass is mainly to eliminate functions that aren't
+ ;; called. The last is mainly to eliminate rest parameters that
+ ;; aren't used, and thus shouldn't be consed.
+
+ (let* ((exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
+ (exp (run-pass exp prune-top-level-scopes #:prune-top-level-scopes? #t))
+ (exp (run-pass exp simplify #:simplify? #t))
+ (exp (run-pass exp contify #:contify? #t))
+ (exp (run-pass exp inline-constructors #:inline-constructors? #t))
+ (exp (run-pass exp specialize-primcalls #:specialize-primcalls? #t))
+ (exp (run-pass exp elide-values #:elide-values? #t))
+ (exp (run-pass exp prune-bailouts #:prune-bailouts? #t))
+ (exp (run-pass exp eliminate-common-subexpressions #:cse? #t))
+ (exp (run-pass exp type-fold #:type-fold? #t))
+ (exp (run-pass exp resolve-self-references #:resolve-self-references? #t))
+ (exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
+ (exp (run-pass exp simplify #:simplify? #t)))
+ ;; Passes that are needed:
+ ;;
+ ;; * Abort contification: turning abort primcalls into continuation
+ ;; calls, and eliding prompts if possible.
+ ;;
+ ;; * Loop peeling. Unrolls the first round through a loop if the
+ ;; loop has effects that CSE can work on. Requires effects
+ ;; analysis. When run before CSE, loop peeling is the equivalent
+ ;; of loop-invariant code motion (LICM).
+
+ exp))
+
+(define (compile-fun f asm)
+ (let* ((dfg (compute-dfg f #:global? #f))
+ (allocation (allocate-slots f dfg)))
+ (define (maybe-slot sym)
+ (lookup-maybe-slot sym allocation))
+
+ (define (slot sym)
+ (lookup-slot sym allocation))
+
+ (define (constant sym)
+ (lookup-constant-value sym allocation))
+
+ (define (maybe-mov dst src)
+ (unless (= dst src)
+ (emit-mov asm dst src)))
+
+ (define (maybe-load-constant slot src)
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value src allocation))
+ (lambda (has-const? val)
+ (and has-const?
+ (begin
+ (emit-load-constant asm slot val)
+ #t)))))
+
+ (define (compile-entry)
+ (let ((label (dfg-min-label dfg)))
+ (match (lookup-cont label dfg)
+ (($ $kfun src meta self tail clause)
+ (when src
+ (emit-source asm src))
+ (emit-begin-program asm label meta)
+ (compile-clause (1+ label))
+ (emit-end-program asm)))))
+
+ (define (compile-clause label)
+ (match (lookup-cont label dfg)
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?)
+ body alternate)
+ (let* ((kw-indices (map (match-lambda
+ ((key name sym)
+ (cons key (lookup-slot sym allocation))))
+ kw))
+ (nlocals (lookup-nlocals label allocation)))
+ (emit-label asm label)
+ (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
+ nlocals
+ (match alternate (#f #f) (($ $cont alt) alt)))
+ (let ((next (compile-body (1+ label) nlocals)))
+ (emit-end-arity asm)
+ (match alternate
+ (($ $cont alt)
+ (unless (eq? next alt)
+ (error "unexpected k" alt))
+ (compile-clause next))
+ (#f
+ (unless (= next (+ (dfg-min-label dfg) (dfg-label-count dfg)))
+ (error "unexpected end of clauses")))))))))
+
+ (define (compile-body label nlocals)
+ (let compile-cont ((label label))
+ (if (eq? label (+ (dfg-min-label dfg) (dfg-label-count dfg)))
+ label
+ (match (lookup-cont label dfg)
+ (($ $kclause) label)
+ (($ $kargs names vars term)
+ (emit-label asm label)
+ (for-each (lambda (name var)
+ (let ((slot (maybe-slot var)))
+ (when slot
+ (emit-definition asm name slot))))
+ names vars)
+ (let find-exp ((term term))
+ (match term
+ (($ $letk conts term)
+ (find-exp term))
+ (($ $continue k src exp)
+ (when src
+ (emit-source asm src))
+ (compile-expression label k exp nlocals)
+ (compile-cont (1+ label))))))
+ (_
+ (emit-label asm label)
+ (compile-cont (1+ label)))))))
+
+ (define (compile-expression label k exp nlocals)
+ (let* ((fallthrough? (= k (1+ label))))
+ (define (maybe-emit-jump)
+ (unless fallthrough?
+ (emit-br asm k)))
+ (match (lookup-cont k dfg)
+ (($ $ktail)
+ (compile-tail label exp))
+ (($ $kargs (name) (sym))
+ (let ((dst (maybe-slot sym)))
+ (when dst
+ (compile-value label exp dst nlocals)))
+ (maybe-emit-jump))
+ (($ $kargs () ())
+ (match exp
+ (($ $branch kt exp)
+ (compile-test label exp kt k (1+ label)))
+ (_
+ (compile-effect label exp k nlocals)
+ (maybe-emit-jump))))
+ (($ $kargs names syms)
+ (compile-values label exp syms)
+ (maybe-emit-jump))
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
+ (compile-trunc label k exp (length req)
+ (and rest
+ (match (lookup-cont kargs dfg)
+ (($ $kargs names (_ ... rest)) rest)))
+ nlocals)
+ (unless (and fallthrough? (= kargs (1+ k)))
+ (emit-br asm kargs))))))
+
+ (define (compile-tail label exp)
+ ;; There are only three kinds of expressions in tail position:
+ ;; tail calls, multiple-value returns, and single-value returns.
+ (match exp
+ (($ $call proc args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
+ (for-each maybe-load-constant tail-slots args))
+ (emit-tail-call asm (1+ (length args))))
+ (($ $callk k proc args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
+ (for-each maybe-load-constant tail-slots args))
+ (emit-tail-call-label asm (1+ (length args)) k))
+ (($ $values ())
+ (emit-reset-frame asm 1)
+ (emit-return-values asm))
+ (($ $values (arg))
+ (if (maybe-slot arg)
+ (emit-return asm (slot arg))
+ (begin
+ (emit-load-constant asm 1 (constant arg))
+ (emit-return asm 1))))
+ (($ $values args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
+ (for-each maybe-load-constant tail-slots args))
+ (emit-reset-frame asm (1+ (length args)))
+ (emit-return-values asm))
+ (($ $primcall 'return (arg))
+ (emit-return asm (slot arg)))))
+
+ (define (compile-value label exp dst nlocals)
+ (match exp
+ (($ $values (arg))
+ (or (maybe-load-constant dst arg)
+ (maybe-mov dst (slot arg))))
+ (($ $void)
+ (emit-load-constant asm dst *unspecified*))
+ (($ $const exp)
+ (emit-load-constant asm dst exp))
+ (($ $closure k 0)
+ (emit-load-static-procedure asm dst k))
+ (($ $closure k nfree)
+ (emit-make-closure asm dst k nfree))
+ (($ $primcall 'current-module)
+ (emit-current-module asm dst))
+ (($ $primcall 'cached-toplevel-box (scope name bound?))
+ (emit-cached-toplevel-box asm dst (constant scope) (constant name)
+ (constant bound?)))
+ (($ $primcall 'cached-module-box (mod name public? bound?))
+ (emit-cached-module-box asm dst (constant mod) (constant name)
+ (constant public?) (constant bound?)))
+ (($ $primcall 'resolve (name bound?))
+ (emit-resolve asm dst (constant bound?) (slot name)))
+ (($ $primcall 'free-ref (closure idx))
+ (emit-free-ref asm dst (slot closure) (constant idx)))
+ (($ $primcall 'vector-ref (vector index))
+ (emit-vector-ref asm dst (slot vector) (slot index)))
+ (($ $primcall 'make-vector (length init))
+ (emit-make-vector asm dst (slot length) (slot init)))
+ (($ $primcall 'make-vector/immediate (length init))
+ (emit-make-vector/immediate asm dst (constant length) (slot init)))
+ (($ $primcall 'vector-ref/immediate (vector index))
+ (emit-vector-ref/immediate asm dst (slot vector) (constant index)))
+ (($ $primcall 'allocate-struct (vtable nfields))
+ (emit-allocate-struct asm dst (slot vtable) (slot nfields)))
+ (($ $primcall 'allocate-struct/immediate (vtable nfields))
+ (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields)))
+ (($ $primcall 'struct-ref (struct n))
+ (emit-struct-ref asm dst (slot struct) (slot n)))
+ (($ $primcall 'struct-ref/immediate (struct n))
+ (emit-struct-ref/immediate asm dst (slot struct) (constant n)))
+ (($ $primcall 'builtin-ref (name))
+ (emit-builtin-ref asm dst (constant name)))
+ (($ $primcall 'bv-u8-ref (bv idx))
+ (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s8-ref (bv idx))
+ (emit-bv-s8-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-u16-ref (bv idx))
+ (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s16-ref (bv idx))
+ (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-u32-ref (bv idx val))
+ (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s32-ref (bv idx val))
+ (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-u64-ref (bv idx val))
+ (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s64-ref (bv idx val))
+ (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-f32-ref (bv idx val))
+ (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-f64-ref (bv idx val))
+ (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall name args)
+ ;; FIXME: Inline all the cases.
+ (let ((inst (prim-instruction name)))
+ (emit-text asm `((,inst ,dst ,@(map slot args))))))))
+
+ (define (compile-effect label exp k nlocals)
+ (match exp
+ (($ $values ()) #f)
+ (($ $prompt escape? tag handler)
+ (match (lookup-cont handler dfg)
+ (($ $kreceive ($ $arity req () rest () #f) khandler-body)
+ (let ((receive-args (gensym "handler"))
+ (nreq (length req))
+ (proc-slot (lookup-call-proc-slot handler allocation)))
+ (emit-prompt asm (slot tag) escape? proc-slot receive-args)
+ (emit-br asm k)
+ (emit-label asm receive-args)
+ (unless (and rest (zero? nreq))
+ (emit-receive-values asm proc-slot (->bool rest) nreq))
+ (when (and rest
+ (match (lookup-cont khandler-body dfg)
+ (($ $kargs names (_ ... rest))
+ (maybe-slot rest))))
+ (emit-bind-rest asm (+ proc-slot 1 nreq)))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves handler allocation))
+ (emit-reset-frame asm nlocals)
+ (emit-br asm khandler-body)))))
+ (($ $primcall 'cache-current-module! (sym scope))
+ (emit-cache-current-module! asm (slot sym) (constant scope)))
+ (($ $primcall 'free-set! (closure idx value))
+ (emit-free-set! asm (slot closure) (slot value) (constant idx)))
+ (($ $primcall 'box-set! (box value))
+ (emit-box-set! asm (slot box) (slot value)))
+ (($ $primcall 'struct-set! (struct index value))
+ (emit-struct-set! asm (slot struct) (slot index) (slot value)))
+ (($ $primcall 'struct-set!/immediate (struct index value))
+ (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value)))
+ (($ $primcall 'vector-set! (vector index value))
+ (emit-vector-set! asm (slot vector) (slot index) (slot value)))
+ (($ $primcall 'vector-set!/immediate (vector index value))
+ (emit-vector-set!/immediate asm (slot vector) (constant index)
+ (slot value)))
+ (($ $primcall 'set-car! (pair value))
+ (emit-set-car! asm (slot pair) (slot value)))
+ (($ $primcall 'set-cdr! (pair value))
+ (emit-set-cdr! asm (slot pair) (slot value)))
+ (($ $primcall 'define! (sym value))
+ (emit-define! asm (slot sym) (slot value)))
+ (($ $primcall 'push-fluid (fluid val))
+ (emit-push-fluid asm (slot fluid) (slot val)))
+ (($ $primcall 'pop-fluid ())
+ (emit-pop-fluid asm))
+ (($ $primcall 'wind (winder unwinder))
+ (emit-wind asm (slot winder) (slot unwinder)))
+ (($ $primcall 'bv-u8-set! (bv idx val))
+ (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s8-set! (bv idx val))
+ (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-u16-set! (bv idx val))
+ (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s16-set! (bv idx val))
+ (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-u32-set! (bv idx val))
+ (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s32-set! (bv idx val))
+ (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-u64-set! (bv idx val))
+ (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s64-set! (bv idx val))
+ (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-f32-set! (bv idx val))
+ (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-f64-set! (bv idx val))
+ (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'unwind ())
+ (emit-unwind asm))))
+
+ (define (compile-values label exp syms)
+ (match exp
+ (($ $values args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (for-each maybe-load-constant (map slot syms) args))))
+
+ (define (compile-test label exp kt kf next-label)
+ (define (unary op sym)
+ (cond
+ ((eq? kt next-label)
+ (op asm (slot sym) #t kf))
+ (else
+ (op asm (slot sym) #f kt)
+ (unless (eq? kf next-label)
+ (emit-br asm kf)))))
+ (define (binary op a b)
+ (cond
+ ((eq? kt next-label)
+ (op asm (slot a) (slot b) #t kf))
+ (else
+ (op asm (slot a) (slot b) #f kt)
+ (unless (eq? kf next-label)
+ (emit-br asm kf)))))
+ (match exp
+ (($ $values (sym))
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value sym allocation))
+ (lambda (has-const? val)
+ (if has-const?
+ (if val
+ (unless (eq? kt next-label)
+ (emit-br asm kt))
+ (unless (eq? kf next-label)
+ (emit-br asm kf)))
+ (unary emit-br-if-true sym)))))
+ (($ $primcall 'null? (a)) (unary emit-br-if-null a))
+ (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
+ (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
+ (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
+ (($ $primcall 'char? (a)) (unary emit-br-if-char a))
+ (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
+ (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
+ (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
+ (($ $primcall 'string? (a)) (unary emit-br-if-string a))
+ (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
+ (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a))
+ (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a))
+ ;; Add more TC7 tests here. Keep in sync with
+ ;; *branching-primcall-arities* in (language cps primitives) and
+ ;; the set of macro-instructions in assembly.scm.
+ (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+ (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
+ (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
+ (($ $primcall '< (a b)) (binary emit-br-if-< a b))
+ (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
+ (($ $primcall '= (a b)) (binary emit-br-if-= a b))
+ (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
+ (($ $primcall '> (a b)) (binary emit-br-if-< b a))
+ (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
+
+ (define (compile-trunc label k exp nreq rest-var nlocals)
+ (define (do-call proc args emit-call)
+ (let* ((proc-slot (lookup-call-proc-slot label allocation))
+ (nargs (1+ (length args)))
+ (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (for-each maybe-load-constant arg-slots (cons proc args))
+ (emit-call asm proc-slot nargs)
+ (emit-dead-slot-map asm proc-slot
+ (lookup-dead-slot-map label allocation))
+ (cond
+ ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
+ (match (lookup-parallel-moves k allocation)
+ ((((? (lambda (src) (= src (1+ proc-slot))) src)
+ . dst)) dst)
+ (_ #f)))
+ ;; The usual case: one required live return value, ignoring
+ ;; any additional values.
+ => (lambda (dst)
+ (emit-receive asm dst proc-slot nlocals)))
+ (else
+ (unless (and (zero? nreq) rest-var)
+ (emit-receive-values asm proc-slot (->bool rest-var) nreq))
+ (when (and rest-var (maybe-slot rest-var))
+ (emit-bind-rest asm (+ proc-slot 1 nreq)))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves k allocation))
+ (emit-reset-frame asm nlocals)))))
+ (match exp
+ (($ $call proc args)
+ (do-call proc args
+ (lambda (asm proc-slot nargs)
+ (emit-call asm proc-slot nargs))))
+ (($ $callk k proc args)
+ (do-call proc args
+ (lambda (asm proc-slot nargs)
+ (emit-call-label asm proc-slot nargs k))))))
+
+ (match f
+ (($ $cont k ($ $kfun src meta self tail clause))
+ (compile-entry)))))
+
+(define (compile-bytecode exp env opts)
+ (let* ((exp (fix-arities exp))
+ (exp (optimize exp opts))
+ (exp (convert-closures exp))
+ ;; first-order optimization should go here
+ (exp (reify-primitives exp))
+ (exp (renumber exp))
+ (asm (make-assembler)))
+ (match exp
+ (($ $program funs)
+ (for-each (lambda (fun) (compile-fun fun asm))
+ funs)))
+ (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
+ env
+ env)))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; Constructor inlining turns "list" primcalls into a series of conses,
+;;; and does similar transformations for "vector".
+;;;
+;;; Code:
+
+(define-module (language cps constructors)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:export (inline-constructors))
+
+(define (inline-constructors* fun)
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (($ $cont)
+ ,cont)))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts)
+ ,(visit-term body)))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body)))
+ (($ $continue k src ($ $primcall 'list args))
+ ,(let-fresh (kvalues) (val)
+ (build-cps-term
+ ($letk ((kvalues ($kargs ('val) (val)
+ ($continue k src
+ ($primcall 'values (val))))))
+ ,(let lp ((args args) (k kvalues))
+ (match args
+ (()
+ (build-cps-term
+ ($continue k src ($const '()))))
+ ((arg . args)
+ (let-fresh (ktail) (tail)
+ (build-cps-term
+ ($letk ((ktail ($kargs ('tail) (tail)
+ ($continue k src
+ ($primcall 'cons (arg tail))))))
+ ,(lp args ktail)))))))))))
+ (($ $continue k src ($ $primcall 'vector args))
+ ,(let-fresh (kalloc) (vec len init)
+ (define (initialize args n)
+ (match args
+ (()
+ (build-cps-term
+ ($continue k src ($primcall 'values (vec)))))
+ ((arg . args)
+ (let-fresh (knext) (idx)
+ (build-cps-term
+ ($letk ((knext ($kargs () ()
+ ,(initialize args (1+ n)))))
+ ($letconst (('idx idx n))
+ ($continue knext src
+ ($primcall 'vector-set! (vec idx arg))))))))))
+ (build-cps-term
+ ($letk ((kalloc ($kargs ('vec) (vec)
+ ,(initialize args 0))))
+ ($letconst (('len len (length args))
+ ('init init #f))
+ ($continue kalloc src
+ ($primcall 'make-vector (len init))))))))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue k src ,(visit-fun fun)))
+ (($ $continue)
+ ,term)))
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun free ,(inline-constructors* body)))))
+
+ (visit-cont fun))
+
+(define (inline-constructors fun)
+ (with-fresh-name-state fun
+ (inline-constructors* fun)))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; Contification is a pass that turns $fun instances into $cont
+;;; instances if all calls to the $fun return to the same continuation.
+;;; This is a more rigorous variant of our old "fixpoint labels
+;;; allocation" optimization.
+;;;
+;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
+;;; and Weeks's "Contification using Dominators".
+;;;
+;;; Code:
+
+(define-module (language cps contification)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (concatenate filter-map))
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps primitives)
+ #:use-module (language bytecode)
+ #:export (contify))
+
+(define (compute-contification fun)
+ (let* ((dfg (compute-dfg fun))
+ (scope-table (make-hash-table))
+ (call-substs '())
+ (cont-substs '())
+ (fun-elisions '())
+ (cont-splices (make-hash-table)))
+ (define (subst-call! sym arities body-ks)
+ (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
+ (define (subst-return! old-tail new-tail)
+ (set! cont-substs (acons old-tail new-tail cont-substs)))
+ (define (elide-function! k cont)
+ (set! fun-elisions (acons k cont fun-elisions)))
+ (define (splice-conts! scope conts)
+ (for-each (match-lambda
+ (($ $cont k) (hashq-set! scope-table k scope)))
+ conts)
+ (hashq-set! cont-splices scope
+ (append conts (hashq-ref cont-splices scope '()))))
+
+ (define (lookup-return-cont k)
+ (match (assq-ref cont-substs k)
+ (#f k)
+ (k (lookup-return-cont k))))
+
+ ;; If K is a continuation that binds one variable, and it has only
+ ;; one predecessor, return that variable.
+ (define (bound-symbol k)
+ (match (lookup-cont k dfg)
+ (($ $kargs (_) (sym))
+ (match (lookup-predecessors k dfg)
+ ((_)
+ ;; K has one predecessor, the one that defined SYM.
+ sym)
+ (_ #f)))
+ (_ #f)))
+
+ (define (extract-arities clause)
+ (match clause
+ (($ $cont _ ($ $kclause arity body alternate))
+ (cons arity (extract-arities alternate)))
+ (#f '())))
+ (define (extract-bodies clause)
+ (match clause
+ (($ $cont _ ($ $kclause arity body alternate))
+ (cons body (extract-bodies alternate)))
+ (#f '())))
+
+ (define (contify-fun term-k sym self tail arities bodies)
+ (contify-funs term-k
+ (list sym) (list self) (list tail)
+ (list arities) (list bodies)))
+
+ ;; Given a set of mutually recursive functions bound to local
+ ;; variables SYMS, with self symbols SELFS, tail continuations
+ ;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K,
+ ;; contify them if we can prove that they all return to the same
+ ;; continuation. Returns a true value on success, and false
+ ;; otherwise.
+ (define (contify-funs term-k syms selfs tails arities bodies)
+ (define (unused? sym)
+ (null? (lookup-uses sym dfg)))
+
+ ;; Are the given args compatible with any of the arities?
+ (define (applicable? proc args)
+ (let lp ((arities (assq-ref (map cons syms arities) proc)))
+ (match arities
+ ((($ $arity req () #f () #f) . arities)
+ (or (= (length args) (length req))
+ (lp arities)))
+ ;; If we reached the end of the arities, fail. Also fail if
+ ;; the next arity in the list has optional, keyword, or rest
+ ;; arguments.
+ (_ #f))))
+
+ ;; If the use of PROC in continuation USE is a call to PROC that
+ ;; is compatible with one of the procedure's arities, return the
+ ;; target continuation. Otherwise return #f.
+ (define (call-target use proc)
+ (match (find-call (lookup-cont use dfg))
+ (($ $continue k src ($ $call proc* args))
+ (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
+ ;; Converge more quickly by resolving already-contified
+ ;; call targets.
+ (lookup-return-cont k)))
+ (_ #f)))
+
+ ;; If this set of functions is always called with one
+ ;; continuation, not counting tail calls between the functions,
+ ;; return that continuation.
+ (define (find-common-continuation)
+ (let visit-syms ((syms syms) (k #f))
+ (match syms
+ (() k)
+ ((sym . syms)
+ (let visit-uses ((uses (lookup-uses sym dfg)) (k k))
+ (match uses
+ (() (visit-syms syms k))
+ ((use . uses)
+ (and=> (call-target use sym)
+ (lambda (k*)
+ (cond
+ ((memq k* tails) (visit-uses uses k))
+ ((not k) (visit-uses uses k*))
+ ((eq? k k*) (visit-uses uses k))
+ (else #f)))))))))))
+
+ ;; Given that the functions are called with the common
+ ;; continuation K, determine the scope at which to contify the
+ ;; functions. If K is in scope in the term, we go ahead and
+ ;; contify them there. Otherwise the scope is inside the letrec
+ ;; body, and so choose the scope in which the continuation is
+ ;; defined, whose free variables are a superset of the free
+ ;; variables of the functions.
+ ;;
+ ;; There is some slight trickiness here. Call-target already uses
+ ;; the information we compute within this pass. Previous
+ ;; contifications may cause functions to be contified not at their
+ ;; point of definition but at their point of non-recursive use.
+ ;; That will cause the scope nesting to change. (It may
+ ;; effectively push a function deeper down the tree -- the second
+ ;; case above, a call within the letrec body.) What if we contify
+ ;; to the tail of a previously contified function? We have to
+ ;; track what the new scope tree will be when asking whether K
+ ;; will be bound in TERM-K's scope, not the scope tree that
+ ;; existed when we started the pass.
+ ;;
+ ;; FIXME: Does this choose the right scope for contified let-bound
+ ;; functions?
+ (define (find-contification-scope k)
+ (define (scope-contains? scope k)
+ (let ((k-scope (or (hashq-ref scope-table k)
+ (let ((k-scope (lookup-block-scope k dfg)))
+ (hashq-set! scope-table k k-scope)
+ k-scope))))
+ (or (eq? scope k-scope)
+ (and k-scope (scope-contains? scope k-scope)))))
+
+ ;; Find the scope of K.
+ (define (continuation-scope k)
+ (or (hashq-ref scope-table k)
+ (let ((scope (lookup-block-scope k dfg)))
+ (hashq-set! scope-table k scope)
+ scope)))
+
+ (let ((k-scope (continuation-scope k)))
+ (if (scope-contains? k-scope term-k)
+ term-k
+ (match (lookup-cont k-scope dfg)
+ (($ $kfun src meta self tail clause)
+ ;; K is the tail of some function. If that function
+ ;; has just one clause, return that clause. Otherwise
+ ;; bail.
+ (match clause
+ (($ $cont _ ($ $kclause arity ($ $cont kargs) #f))
+ kargs)
+ (_ #f)))
+ (_ k-scope)))))
+
+ ;; We are going to contify. Mark all SYMs for replacement in
+ ;; calls, and mark the tail continuations for replacement by K.
+ ;; Arrange for the continuations to be spliced into SCOPE.
+ (define (enqueue-contification! k scope)
+ (for-each (lambda (sym tail arities bodies)
+ (match bodies
+ ((($ $cont body-k) ...)
+ (subst-call! sym arities body-k)))
+ (subst-return! tail k))
+ syms tails arities bodies)
+ (splice-conts! scope (concatenate bodies))
+ #t)
+
+ ;; "Call me maybe"
+ (and (and-map unused? selfs)
+ (and=> (find-common-continuation)
+ (lambda (k)
+ (and=> (find-contification-scope k)
+ (cut enqueue-contification! k <>))))))
+
+ (define (visit-fun term)
+ (match term
+ (($ $fun free body)
+ (visit-cont body))))
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont sym ($ $kargs _ _ body))
+ (visit-term body sym))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (when clause (visit-cont clause)))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (visit-cont body)
+ (when alternate (visit-cont alternate)))
+ (($ $cont)
+ #t)))
+ (define (visit-term term term-k)
+ (match term
+ (($ $letk conts body)
+ (for-each visit-cont conts)
+ (visit-term body term-k))
+ (($ $letrec names syms funs body)
+ (define (split-components nsf)
+ ;; FIXME: Compute strongly-connected components. Currently
+ ;; we just put non-recursive functions in their own
+ ;; components, and lump everything else in the remaining
+ ;; component.
+ (define (recursive? k)
+ (or-map (cut variable-free-in? <> k dfg) syms))
+ (let lp ((nsf nsf) (rec '()))
+ (match nsf
+ (()
+ (if (null? rec)
+ '()
+ (list rec)))
+ (((and elt (n s ($ $fun free ($ $cont kfun))))
+ . nsf)
+ (if (recursive? kfun)
+ (lp nsf (cons elt rec))
+ (cons (list elt) (lp nsf rec)))))))
+ (define (extract-arities+bodies clauses)
+ (values (map extract-arities clauses)
+ (map extract-bodies clauses)))
+ (define (visit-component component)
+ (match component
+ (((name sym fun) ...)
+ (match fun
+ ((($ $fun free
+ ($ $cont fun-k
+ ($ $kfun src meta self ($ $cont tail-k ($ $ktail))
+ clause)))
+ ...)
+ (call-with-values (lambda () (extract-arities+bodies clause))
+ (lambda (arities bodies)
+ (if (contify-funs term-k sym self tail-k arities bodies)
+ (for-each (cut for-each visit-cont <>) bodies)
+ (for-each visit-fun fun)))))))))
+ (visit-term body term-k)
+ (for-each visit-component
+ (split-components (map list names syms funs))))
+ (($ $continue k src exp)
+ (match exp
+ (($ $fun free
+ ($ $cont fun-k
+ ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause)))
+ (if (and=> (bound-symbol k)
+ (lambda (sym)
+ (contify-fun term-k sym self tail-k
+ (extract-arities clause)
+ (extract-bodies clause))))
+ (begin
+ (elide-function! k (lookup-cont k dfg))
+ (for-each visit-cont (extract-bodies clause)))
+ (visit-fun exp)))
+ (_ #t)))))
+
+ (visit-cont fun)
+ (values call-substs cont-substs fun-elisions cont-splices)))
+
+(define (apply-contification fun call-substs cont-substs fun-elisions cont-splices)
+ (define (contify-call src proc args)
+ (and=> (assq-ref call-substs proc)
+ (lambda (clauses)
+ (let lp ((clauses clauses))
+ (match clauses
+ (() (error "invalid contification"))
+ (((($ $arity req () #f () #f) . k) . clauses)
+ (if (= (length req) (length args))
+ (build-cps-term
+ ($continue k src
+ ($values args)))
+ (lp clauses)))
+ ((_ . clauses) (lp clauses)))))))
+ (define (continue k src exp)
+ (define (lookup-return-cont k)
+ (match (assq-ref cont-substs k)
+ (#f k)
+ (k (lookup-return-cont k))))
+ (let ((k* (lookup-return-cont k)))
+ ;; We are contifying this return. It must be a call or a
+ ;; primcall to values, return, or return-values.
+ (if (eq? k k*)
+ (build-cps-term ($continue k src ,exp))
+ (rewrite-cps-term exp
+ (($ $primcall 'return (val))
+ ($continue k* src ($primcall 'values (val))))
+ (($ $values vals)
+ ($continue k* src ($primcall 'values vals)))
+ (_ ($continue k* src ,exp))))))
+ (define (splice-continuations term-k term)
+ (match (hashq-ref cont-splices term-k)
+ (#f term)
+ ((cont ...)
+ (let lp ((term term))
+ (rewrite-cps-term term
+ (($ $letrec names syms funs body)
+ ($letrec names syms funs ,(lp body)))
+ (($ $letk conts* body)
+ ($letk ,(append conts* (filter-map visit-cont cont))
+ ,body))
+ (body
+ ($letk ,(filter-map visit-cont cont)
+ ,body)))))))
+ (define (visit-fun term)
+ (rewrite-cps-exp term
+ (($ $fun free body)
+ ($fun free ,(visit-cont body)))))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont (? (cut assq <> fun-elisions)))
+ ;; This cont gets inlined in place of the $fun.
+ ,#f)
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body sym))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (($ $cont)
+ ,cont)))
+ (define (visit-term term term-k)
+ (match term
+ (($ $letk conts body)
+ ;; Visit the body first, so we rewrite depth-first.
+ (let lp ((body (visit-term body term-k)))
+ ;; Because we attach contified functions on a particular
+ ;; term-k, and one term-k can correspond to an arbitrarily
+ ;; nested sequence of $letrec and $letk instances, normalize
+ ;; so that all continuations are bound by one $letk --
+ ;; guaranteeing that they are in the same scope.
+ (rewrite-cps-term body
+ (($ $letrec names syms funs body)
+ ($letrec names syms funs ,(lp body)))
+ (($ $letk conts* body)
+ ($letk ,(append conts* (filter-map visit-cont conts))
+ ,body))
+ (body
+ ($letk ,(filter-map visit-cont conts)
+ ,body)))))
+ (($ $letrec names syms funs body)
+ (rewrite-cps-term (filter (match-lambda
+ ((n s f) (not (assq s call-substs))))
+ (map list names syms funs))
+ (((names syms funs) ...)
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body term-k)))))
+ (($ $continue k src exp)
+ (splice-continuations
+ term-k
+ (match exp
+ (($ $fun)
+ (cond
+ ((assq-ref fun-elisions k)
+ => (match-lambda
+ (($ $kargs (_) (_) body)
+ (visit-term body k))))
+ (else
+ (continue k src (visit-fun exp)))))
+ (($ $call proc args)
+ (or (contify-call src proc args)
+ (continue k src exp)))
+ (_ (continue k src exp)))))))
+ (visit-cont fun))
+
+(define (contify fun)
+ (call-with-values (lambda () (compute-contification fun))
+ (lambda (call-substs cont-substs fun-elisions cont-splices)
+ (if (null? call-substs)
+ fun
+ ;; Iterate to fixed point.
+ (contify
+ (apply-contification fun call-substs cont-substs fun-elisions cont-splices))))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; Common subexpression elimination for CPS.
+;;;
+;;; Code:
+
+(define-module (language cps cse)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps effects-analysis)
+ #:use-module (language cps renumber)
+ #:use-module (language cps intset)
+ #:use-module (rnrs bytevectors)
+ #:export (eliminate-common-subexpressions))
+
+(define (cont-successors cont)
+ (match cont
+ (($ $kargs names syms body)
+ (let lp ((body body))
+ (match body
+ (($ $letk conts body) (lp body))
+ (($ $letrec names vars funs body) (lp body))
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt escape? tag handler) (list k handler))
+ (($ $branch kt) (list k kt))
+ (_ (list k)))))))
+
+ (($ $kreceive arity k) (list k))
+
+ (($ $kclause arity ($ $cont kbody)) (list kbody))
+
+ (($ $kfun src meta self tail clause)
+ (let lp ((clause clause))
+ (match clause
+ (($ $cont kclause ($ $kclause _ _ alt))
+ (cons kclause (lp alt)))
+ (#f '()))))
+
+ (($ $kfun src meta self tail #f) '())
+
+ (($ $ktail) '())))
+
+(define (compute-available-expressions dfg min-label label-count idoms)
+ "Compute and return the continuations that may be reached if flow
+reaches a continuation N. Returns a vector of intsets, whose first
+index corresponds to MIN-LABEL, and so on."
+ (let* ((effects (compute-effects dfg min-label label-count))
+ ;; Vector of intsets, indicating that at a continuation N, the
+ ;; values from continuations M... are available.
+ (avail (make-vector label-count #f))
+ (revisit-label #f))
+
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+ (define (get-effects label) (vector-ref effects (label->idx label)))
+
+ (define (propagate! pred succ out)
+ (let* ((succ-idx (label->idx succ))
+ (in (match (lookup-predecessors succ dfg)
+ ;; Fast path: normal control flow.
+ ((_) out)
+ ;; Slow path: control-flow join.
+ (_ (cond
+ ((vector-ref avail succ-idx)
+ => (lambda (in)
+ (intset-intersect in out)))
+ (else out))))))
+ (when (and (<= succ pred)
+ (or (not revisit-label) (< succ revisit-label))
+ (not (eq? in (vector-ref avail succ-idx))))
+ ;; Arrange to revisit if this is not a forward edge and the
+ ;; available set changed.
+ (set! revisit-label succ))
+ (vector-set! avail succ-idx in)))
+
+ (define (clobber label in)
+ (let ((fx (get-effects label)))
+ (cond
+ ((not (causes-effect? fx &write))
+ ;; Fast-path if this expression clobbers nothing.
+ in)
+ (else
+ ;; Kill clobbered expressions. There is no need to check on
+ ;; any label before than the last dominating label that
+ ;; clobbered everything.
+ (let ((first (let lp ((dom label))
+ (let* ((dom (vector-ref idoms (label->idx dom))))
+ (and (< min-label dom)
+ (let ((fx (vector-ref effects (label->idx dom))))
+ (if (causes-all-effects? fx)
+ dom
+ (lp dom))))))))
+ (let lp ((i first) (in in))
+ (cond
+ ((intset-next in i)
+ => (lambda (i)
+ (if (effect-clobbers? fx (vector-ref effects (label->idx i)))
+ (lp (1+ i) (intset-remove in i))
+ (lp (1+ i) in))))
+ (else in))))))))
+
+ (synthesize-definition-effects! effects dfg min-label label-count)
+
+ (vector-set! avail 0 empty-intset)
+
+ (let lp ((n 0))
+ (cond
+ ((< n label-count)
+ (let* ((label (idx->label n))
+ ;; It's possible for "in" to be #f if it has no
+ ;; predecessors, as is the case for the ktail of a
+ ;; function with an iloop.
+ (in (or (vector-ref avail n) empty-intset))
+ (out (intset-add (clobber label in) label)))
+ (lookup-predecessors label dfg)
+ (let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
+ (match succs
+ (() (lp (1+ n)))
+ ((succ . succs)
+ (propagate! label succ out)
+ (visit-succs succs))))))
+ (revisit-label
+ (let ((n (label->idx revisit-label)))
+ (set! revisit-label #f)
+ (lp n)))
+ (else
+ (values avail effects))))))
+
+(define (compute-truthy-expressions dfg min-label label-count)
+ "Compute a \"truth map\", indicating which expressions can be shown to
+be true and/or false at each of LABEL-COUNT expressions in DFG, starting
+from MIN-LABEL. Returns a vector of intsets, each intset twice as long
+as LABEL-COUNT. The even elements of the intset indicate labels that
+may be true, and the odd ones indicate those that may be false. It
+could be that both true and false proofs are available."
+ (let ((boolv (make-vector label-count #f))
+ (revisit-label #f))
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+ (define (true-idx idx) (ash idx 1))
+ (define (false-idx idx) (1+ (ash idx 1)))
+
+ (define (propagate! pred succ out)
+ (let* ((succ-idx (label->idx succ))
+ (in (match (lookup-predecessors succ dfg)
+ ;; Fast path: normal control flow.
+ ((_) out)
+ ;; Slow path: control-flow join.
+ (_ (cond
+ ((vector-ref boolv succ-idx)
+ => (lambda (in)
+ (intset-intersect in out)))
+ (else out))))))
+ (when (and (<= succ pred)
+ (or (not revisit-label) (< succ revisit-label))
+ (not (eq? in (vector-ref boolv succ-idx))))
+ (set! revisit-label succ))
+ (vector-set! boolv succ-idx in)))
+
+ (vector-set! boolv 0 empty-intset)
+
+ (let lp ((n 0))
+ (cond
+ ((< n label-count)
+ (let* ((label (idx->label n))
+ ;; It's possible for "in" to be #f if it has no
+ ;; predecessors, as is the case for the ktail of a
+ ;; function with an iloop.
+ (in (or (vector-ref boolv n) empty-intset)))
+ (define (default-propagate)
+ (let visit-succs ((succs (cont-successors (lookup-cont label dfg))))
+ (match succs
+ (() (lp (1+ n)))
+ ((succ . succs)
+ (propagate! label succ in)
+ (visit-succs succs)))))
+ (match (lookup-cont label dfg)
+ (($ $kargs names syms body)
+ (match (find-call body)
+ (($ $continue k src ($ $branch kt))
+ (propagate! label k (intset-add in (false-idx n)))
+ (propagate! label kt (intset-add in (true-idx n)))
+ (lp (1+ n)))
+ (_ (default-propagate))))
+ (_ (default-propagate)))))
+ (revisit-label
+ (let ((n (label->idx revisit-label)))
+ (set! revisit-label #f)
+ (lp n)))
+ (else boolv)))))
+
+;; Returns a map of label-idx -> (var-idx ...) indicating the variables
+;; defined by a given labelled expression.
+(define (compute-defs dfg min-label label-count)
+ (define (cont-defs k)
+ (match (lookup-cont k dfg)
+ (($ $kargs names vars) vars)
+ (_ '())))
+ (define (idx->label idx) (+ idx min-label))
+ (let ((defs (make-vector label-count '())))
+ (let lp ((n 0))
+ (when (< n label-count)
+ (vector-set!
+ defs
+ n
+ (match (lookup-cont (idx->label n) dfg)
+ (($ $kargs _ _ body)
+ (match (find-call body)
+ (($ $continue k) (cont-defs k))))
+ (($ $kreceive arity kargs)
+ (cont-defs kargs))
+ (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
+ syms)
+ (($ $kfun src meta self) (list self))
+ (($ $ktail) '())))
+ (lp (1+ n))))
+ defs))
+
+(define (compute-label-and-var-ranges fun)
+ (match fun
+ (($ $cont kfun ($ $kfun src meta self))
+ ((make-local-cont-folder min-label label-count min-var var-count)
+ (lambda (k cont min-label label-count min-var var-count)
+ (let ((min-label (min k min-label))
+ (label-count (1+ label-count)))
+ (match cont
+ (($ $kargs names vars body)
+ (let lp ((body body)
+ (min-var (fold min min-var vars))
+ (var-count (+ var-count (length vars))))
+ (match body
+ (($ $letrec names vars funs body)
+ (lp body
+ (fold min min-var vars)
+ (+ var-count (length vars))))
+ (($ $letk conts body) (lp body min-var var-count))
+ (_ (values min-label label-count min-var var-count)))))
+ (($ $kfun src meta self)
+ (values min-label label-count (min self min-var) (1+ var-count)))
+ (_
+ (values min-label label-count min-var var-count)))))
+ fun kfun 0 self 0))))
+
+;; Compute a vector containing, for each node, a list of the nodes that
+;; it immediately dominates. These are the "D" edges in the DJ tree.
+
+(define (compute-equivalent-subexpressions fun dfg)
+ (define (compute min-label label-count min-var var-count idoms avail effects)
+ (let ((defs (compute-defs dfg min-label label-count))
+ (var-substs (make-vector var-count #f))
+ (equiv-labels (make-vector label-count #f))
+ (equiv-set (make-hash-table)))
+ (define (idx->label idx) (+ idx min-label))
+ (define (label->idx label) (- label min-label))
+ (define (idx->var idx) (+ idx min-var))
+ (define (var->idx var) (- var min-var))
+
+ (define (for-each/2 f l1 l2)
+ (unless (= (length l1) (length l2))
+ (error "bad lengths" l1 l2))
+ (let lp ((l1 l1) (l2 l2))
+ (when (pair? l1)
+ (f (car l1) (car l2))
+ (lp (cdr l1) (cdr l2)))))
+
+ (define (subst-var var)
+ ;; It could be that the var is free in this function; if so, its
+ ;; name will be less than min-var.
+ (let ((idx (var->idx var)))
+ (if (<= 0 idx)
+ (vector-ref var-substs idx)
+ var)))
+
+ (define (compute-exp-key exp)
+ (match exp
+ (($ $void) 'void)
+ (($ $const val) (cons 'const val))
+ (($ $prim name) (cons 'prim name))
+ (($ $fun free body) #f)
+ (($ $call proc args) #f)
+ (($ $callk k proc args) #f)
+ (($ $primcall name args)
+ (cons* 'primcall name (map subst-var args)))
+ (($ $branch _ ($ $primcall name args))
+ (cons* 'primcall name (map subst-var args)))
+ (($ $branch) #f)
+ (($ $values args) #f)
+ (($ $prompt escape? tag handler) #f)))
+
+ (define (add-auxiliary-definitions! label exp-key)
+ (let ((defs (vector-ref defs (label->idx label))))
+ (define (add-def! aux-key var)
+ (let ((equiv (hash-ref equiv-set aux-key '())))
+ (hash-set! equiv-set aux-key
+ (acons label (list var) equiv))))
+ (match exp-key
+ (('primcall 'box val)
+ (match defs
+ ((box)
+ (add-def! `(primcall box-ref ,(subst-var box)) val))))
+ (('primcall 'box-set! box val)
+ (add-def! `(primcall box-ref ,box) val))
+ (('primcall 'cons car cdr)
+ (match defs
+ ((pair)
+ (add-def! `(primcall car ,(subst-var pair)) car)
+ (add-def! `(primcall cdr ,(subst-var pair)) cdr))))
+ (('primcall 'set-car! pair car)
+ (add-def! `(primcall car ,pair) car))
+ (('primcall 'set-cdr! pair cdr)
+ (add-def! `(primcall cdr ,pair) cdr))
+ (('primcall (or 'make-vector 'make-vector/immediate) len fill)
+ (match defs
+ ((vec)
+ (add-def! `(primcall vector-length ,(subst-var vec)) len))))
+ (('primcall 'vector-set! vec idx val)
+ (add-def! `(primcall vector-ref ,vec ,idx) val))
+ (('primcall 'vector-set!/immediate vec idx val)
+ (add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
+ (('primcall (or 'allocate-struct 'allocate-struct/immediate)
+ vtable size)
+ (match defs
+ (() #f) ;; allocate-struct in tail or kreceive position.
+ ((struct)
+ (add-def! `(primcall struct-vtable ,(subst-var struct))
+ vtable))))
+ (('primcall 'struct-set! struct n val)
+ (add-def! `(primcall struct-ref ,struct ,n) val))
+ (('primcall 'struct-set!/immediate struct n val)
+ (add-def! `(primcall struct-ref/immediate ,struct ,n) val))
+ (_ #t))))
+
+ ;; The initial substs vector is the identity map.
+ (let lp ((var min-var))
+ (when (< (var->idx var) var-count)
+ (vector-set! var-substs (var->idx var) var)
+ (lp (1+ var))))
+
+ ;; Traverse the labels in fun in forward order, which will visit
+ ;; dominators first.
+ (let lp ((label min-label))
+ (when (< (label->idx label) label-count)
+ (match (lookup-cont label dfg)
+ (($ $kargs names vars body)
+ (match (find-call body)
+ (($ $continue k src exp)
+ (let* ((exp-key (compute-exp-key exp))
+ (equiv (hash-ref equiv-set exp-key '()))
+ (lidx (label->idx label))
+ (fx (vector-ref effects lidx))
+ (avail (vector-ref avail lidx)))
+ (let lp ((candidates equiv))
+ (match candidates
+ (()
+ ;; No matching expressions. Add our expression
+ ;; to the equivalence set, if appropriate. Note
+ ;; that expressions that allocate a fresh object
+ ;; or change the current fluid environment can't
+ ;; be eliminated by CSE (though DCE might do it
+ ;; if the value proves to be unused, in the
+ ;; allocation case).
+ (when (and exp-key
+ (not (causes-effect? fx &allocation))
+ (not (effect-clobbers?
+ fx
+ (&read-object &fluid))))
+ (hash-set! equiv-set exp-key
+ (acons label (vector-ref defs lidx)
+ equiv))))
+ (((and head (candidate . vars)) . candidates)
+ (cond
+ ((not (intset-ref avail candidate))
+ ;; This expression isn't available here; try
+ ;; the next one.
+ (lp candidates))
+ (else
+ ;; Yay, a match. Mark expression as equivalent.
+ (vector-set! equiv-labels lidx head)
+ ;; If we dominate the successor, mark vars
+ ;; for substitution.
+ (when (= label (vector-ref idoms (label->idx k)))
+ (for-each/2
+ (lambda (var subst-var)
+ (vector-set! var-substs (var->idx var) subst-var))
+ (vector-ref defs lidx)
+ vars)))))))
+ ;; If this expression defines auxiliary definitions,
+ ;; as `cons' does for the results of `car' and `cdr',
+ ;; define those. Do so after finding equivalent
+ ;; expressions, so that we can take advantage of
+ ;; subst'd output vars.
+ (add-auxiliary-definitions! label exp-key)))))
+ (_ #f))
+ (lp (1+ label))))
+ (values (compute-dom-edges idoms min-label)
+ equiv-labels min-label var-substs min-var)))
+
+ (call-with-values (lambda () (compute-label-and-var-ranges fun))
+ (lambda (min-label label-count min-var var-count)
+ (let ((idoms (compute-idoms dfg min-label label-count)))
+ (call-with-values
+ (lambda ()
+ (compute-available-expressions dfg min-label label-count idoms))
+ (lambda (avail effects)
+ (compute min-label label-count min-var var-count
+ idoms avail effects)))))))
+
+(define (apply-cse fun dfg
+ doms equiv-labels min-label var-substs min-var boolv)
+ (define (idx->label idx) (+ idx min-label))
+ (define (label->idx label) (- label min-label))
+ (define (idx->var idx) (+ idx min-var))
+ (define (var->idx var) (- var min-var))
+ (define (true-idx idx) (ash idx 1))
+ (define (false-idx idx) (1+ (ash idx 1)))
+
+ (define (subst-var var)
+ ;; It could be that the var is free in this function; if so,
+ ;; its name will be less than min-var.
+ (let ((idx (var->idx var)))
+ (if (<= 0 idx)
+ (vector-ref var-substs idx)
+ var)))
+
+ (define (visit-fun-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail
+ ,(and clause (visit-fun-cont clause)))))
+ (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
+ (label ($kclause ,arity ,(visit-cont kbody body)
+ ,(and alternate (visit-fun-cont alternate)))))))
+
+ (define (visit-cont label cont)
+ (rewrite-cps-cont cont
+ (($ $kargs names vars body)
+ (label ($kargs names vars ,(visit-term body label))))
+ (_ (label ,cont))))
+
+ (define (visit-term term label)
+ (define (visit-exp exp)
+ ;; We shouldn't see $fun here.
+ (rewrite-cps-exp exp
+ ((or ($ $void) ($ $const) ($ $prim)) ,exp)
+ (($ $call proc args)
+ ($call (subst-var proc) ,(map subst-var args)))
+ (($ $callk k proc args)
+ ($callk k (subst-var proc) ,(map subst-var args)))
+ (($ $primcall name args)
+ ($primcall name ,(map subst-var args)))
+ (($ $branch k exp)
+ ($branch k ,(visit-exp exp)))
+ (($ $values args)
+ ($values ,(map subst-var args)))
+ (($ $prompt escape? tag handler)
+ ($prompt escape? (subst-var tag) handler))))
+
+ (define (visit-exp* k src exp)
+ (match exp
+ (($ $fun free body)
+ (build-cps-term
+ ($continue k src
+ ($fun (map subst-var free) ,(cse body dfg)))))
+ (_
+ (cond
+ ((vector-ref equiv-labels (label->idx label))
+ => (match-lambda
+ ((equiv . vars)
+ (let* ((eidx (label->idx equiv)))
+ (match exp
+ (($ $branch kt exp)
+ (let* ((bool (vector-ref boolv (label->idx label)))
+ (t (intset-ref bool (true-idx eidx)))
+ (f (intset-ref bool (false-idx eidx))))
+ (if (eqv? t f)
+ (build-cps-term
+ ($continue k src
+ ($branch kt ,(visit-exp exp))))
+ (build-cps-term
+ ($continue (if t kt k) src ($values ()))))))
+ (_
+ ;; FIXME: can we always continue with $values? why
+ ;; or why not?
+ (rewrite-cps-term (lookup-cont k dfg)
+ (($ $kargs)
+ ($continue k src ($values vars)))
+ (_
+ ($continue k src ,(visit-exp exp))))))))))
+ (else
+ (build-cps-term
+ ($continue k src ,(visit-exp exp))))))))
+
+ (define (visit-dom-conts label)
+ (let ((cont (lookup-cont label dfg)))
+ (match cont
+ (($ $ktail) '())
+ (($ $kargs) (list (visit-cont label cont)))
+ (else
+ (cons (visit-cont label cont)
+ (append-map visit-dom-conts
+ (vector-ref doms (label->idx label))))))))
+
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ,(visit-term body label))
+ (($ $letrec names syms funs body)
+ ($letrec names syms
+ (map (lambda (fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun (map subst-var free) ,(cse body dfg)))))
+ funs)
+ ,(visit-term body label)))
+ (($ $continue k src exp)
+ ,(let ((conts (append-map visit-dom-conts
+ (vector-ref doms (label->idx label)))))
+ (if (null? conts)
+ (visit-exp* k src exp)
+ (build-cps-term
+ ($letk ,conts ,(visit-exp* k src exp))))))))
+
+ (visit-fun-cont fun))
+
+(define (cse fun dfg)
+ (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
+ (lambda (doms equiv-labels min-label var-substs min-var)
+ (apply-cse fun dfg doms equiv-labels min-label var-substs min-var
+ (compute-truthy-expressions dfg
+ min-label (vector-length doms))))))
+
+(define (eliminate-common-subexpressions fun)
+ (call-with-values (lambda () (renumber fun))
+ (lambda (fun nlabels nvars)
+ (cse fun (compute-dfg fun)))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; Various optimizations can inline calls from one continuation to some
+;;; other continuation, usually in response to information about the
+;;; return arity of the call. That leaves us with dangling
+;;; continuations that aren't reachable any more from the procedure
+;;; entry. This pass will remove them.
+;;;
+;;; This pass also kills dead expressions: code that has no side
+;;; effects, and whose value is unused. It does so by marking all live
+;;; values, and then discarding other values as dead. This happens
+;;; recursively through procedures, so it should be possible to elide
+;;; dead procedures as well.
+;;;
+;;; Code:
+
+(define-module (language cps dce)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps effects-analysis)
+ #:use-module (language cps renumber)
+ #:use-module (language cps types)
+ #:export (eliminate-dead-code))
+
+(define-record-type $fun-data
+ (make-fun-data min-label effects live-conts defs)
+ fun-data?
+ (min-label fun-data-min-label)
+ (effects fun-data-effects)
+ (live-conts fun-data-live-conts)
+ (defs fun-data-defs))
+
+(define (compute-defs dfg min-label label-count)
+ (define (cont-defs k)
+ (match (lookup-cont k dfg)
+ (($ $kargs names vars) vars)
+ (_ #f)))
+ (define (idx->label idx) (+ idx min-label))
+ (let ((defs (make-vector label-count #f)))
+ (let lp ((n 0))
+ (when (< n label-count)
+ (vector-set!
+ defs
+ n
+ (match (lookup-cont (idx->label n) dfg)
+ (($ $kargs _ _ body)
+ (match (find-call body)
+ (($ $continue k src exp)
+ (match exp
+ (($ $branch) #f)
+ (_ (cont-defs k))))))
+ (($ $kreceive arity kargs)
+ (cont-defs kargs))
+ (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
+ syms)
+ (($ $kfun src meta self) (list self))
+ (($ $ktail) #f)))
+ (lp (1+ n))))
+ defs))
+
+(define (elide-type-checks! fun dfg effects min-label label-count)
+ (match fun
+ (($ $cont kfun ($ $kfun src meta min-var))
+ (let ((typev (infer-types fun dfg)))
+ (define (idx->label idx) (+ idx min-label))
+ (define (var->idx var) (- var min-var))
+ (define (visit-primcall lidx fx name args)
+ (when (primcall-types-check? typev (idx->label lidx) name args)
+ (vector-set! effects lidx
+ (logand fx (lognot &type-check)))))
+ (let lp ((lidx 0))
+ (when (< lidx label-count)
+ (let ((fx (vector-ref effects lidx)))
+ (unless (causes-all-effects? fx)
+ (when (causes-effect? fx &type-check)
+ (match (lookup-cont (idx->label lidx) dfg)
+ (($ $kargs _ _ term)
+ (match (find-call term)
+ (($ $continue k src ($ $primcall name args))
+ (visit-primcall lidx fx name args))
+ (($ $continue k src ($ $branch _ ($primcall name args)))
+ (visit-primcall lidx fx name args))
+ (_ #f)))
+ (_ #f)))))
+ (lp (1+ lidx))))))))
+
+(define (compute-live-code fun)
+ (let* ((fun-data-table (make-hash-table))
+ (dfg (compute-dfg fun #:global? #t))
+ (live-vars (make-bitvector (dfg-var-count dfg) #f))
+ (changed? #f))
+ (define (mark-live! var)
+ (unless (value-live? var)
+ (set! changed? #t)
+ (bitvector-set! live-vars var #t)))
+ (define (value-live? var)
+ (bitvector-ref live-vars var))
+ (define (ensure-fun-data fun)
+ (or (hashq-ref fun-data-table fun)
+ (call-with-values (lambda ()
+ ((make-local-cont-folder label-count max-label)
+ (lambda (k cont label-count max-label)
+ (values (1+ label-count) (max k max-label)))
+ fun 0 -1))
+ (lambda (label-count max-label)
+ (let* ((min-label (- (1+ max-label) label-count))
+ (effects (compute-effects dfg min-label label-count))
+ (live-conts (make-bitvector label-count #f))
+ (defs (compute-defs dfg min-label label-count))
+ (fun-data (make-fun-data
+ min-label effects live-conts defs)))
+ (elide-type-checks! fun dfg effects min-label label-count)
+ (hashq-set! fun-data-table fun fun-data)
+ (set! changed? #t)
+ fun-data)))))
+ (define (visit-fun fun)
+ (match (ensure-fun-data fun)
+ (($ $fun-data min-label effects live-conts defs)
+ (define (idx->label idx) (+ idx min-label))
+ (define (label->idx label) (- label min-label))
+ (define (known-allocation? var dfg)
+ (match (lookup-predecessors (lookup-def var dfg) dfg)
+ ((def-exp-k)
+ (match (lookup-cont def-exp-k dfg)
+ (($ $kargs _ _ term)
+ (match (find-call term)
+ (($ $continue k src ($ $values (var)))
+ (known-allocation? var dfg))
+ (($ $continue k src ($ $primcall))
+ (let ((kidx (label->idx def-exp-k)))
+ (and (>= kidx 0)
+ (causes-effect? (vector-ref effects kidx)
+ &allocation))))
+ (_ #f)))
+ (_ #f)))
+ (_ #f)))
+ (define (visit-grey-exp n exp)
+ (let ((defs (vector-ref defs n))
+ (fx (vector-ref effects n)))
+ (or
+ ;; No defs; perhaps continuation is $ktail.
+ (not defs)
+ ;; Do we have a live def?
+ (or-map value-live? defs)
+ ;; Does this expression cause all effects? If so, it's
+ ;; definitely live.
+ (causes-all-effects? fx)
+ ;; Does it cause a type check, but we weren't able to
+ ;; prove that the types check?
+ (causes-effect? fx &type-check)
+ ;; We might have a setter. If the object being assigned
+ ;; to is live or was not created by us, then this
+ ;; expression is live. Otherwise the value is still dead.
+ (and (causes-effect? fx &write)
+ (match exp
+ (($ $primcall
+ (or 'vector-set! 'vector-set!/immediate
+ 'set-car! 'set-cdr!
+ 'box-set!)
+ (obj . _))
+ (or (value-live? obj)
+ (not (known-allocation? obj dfg))))
+ (_ #t))))))
+ (let lp ((n (1- (vector-length effects))))
+ (unless (< n 0)
+ (let ((cont (lookup-cont (idx->label n) dfg)))
+ (match cont
+ (($ $kargs _ _ body)
+ (let lp ((body body))
+ (match body
+ (($ $letk conts body) (lp body))
+ (($ $letrec names syms funs body)
+ (lp body)
+ (for-each (lambda (sym fun)
+ (when (value-live? sym)
+ (match fun
+ (($ $fun free body)
+ (visit-fun body)))))
+ syms funs))
+ (($ $continue k src exp)
+ (unless (bitvector-ref live-conts n)
+ (when (visit-grey-exp n exp)
+ (set! changed? #t)
+ (bitvector-set! live-conts n #t)))
+ (when (bitvector-ref live-conts n)
+ (match exp
+ ((or ($ $void) ($ $const) ($ $prim))
+ #f)
+ (($ $fun free body)
+ (visit-fun body))
+ (($ $prompt escape? tag handler)
+ (mark-live! tag))
+ (($ $call proc args)
+ (mark-live! proc)
+ (for-each mark-live! args))
+ (($ $callk k proc args)
+ (mark-live! proc)
+ (for-each mark-live! args))
+ (($ $primcall name args)
+ (for-each mark-live! args))
+ (($ $branch k ($ $primcall name args))
+ (for-each mark-live! args))
+ (($ $branch k ($ $values (arg)))
+ (mark-live! arg))
+ (($ $values args)
+ (match (vector-ref defs n)
+ (#f (for-each mark-live! args))
+ (defs (for-each (lambda (use def)
+ (when (value-live? def)
+ (mark-live! use)))
+ args defs))))))))))
+ (($ $kreceive arity kargs) #f)
+ (($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
+ (for-each mark-live! syms))
+ (($ $kfun src meta self)
+ (mark-live! self))
+ (($ $ktail) #f))
+ (lp (1- n))))))))
+ (unless (= (dfg-var-count dfg) (var-counter))
+ (error "internal error" (dfg-var-count dfg) (var-counter)))
+ (let lp ()
+ (set! changed? #f)
+ (visit-fun fun)
+ (when changed? (lp)))
+ (values fun-data-table live-vars)))
+
+(define (process-eliminations fun fun-data-table live-vars)
+ (define (value-live? var)
+ (bitvector-ref live-vars var))
+ (define (make-adaptor name k defs)
+ (let* ((names (map (lambda (_) 'tmp) defs))
+ (syms (map (lambda (_) (fresh-var)) defs))
+ (live (filter-map (lambda (def sym)
+ (and (value-live? def)
+ sym))
+ defs syms)))
+ (build-cps-cont
+ (name ($kargs names syms
+ ($continue k #f ($values live)))))))
+ (define (visit-fun fun)
+ (match (hashq-ref fun-data-table fun)
+ (($ $fun-data min-label effects live-conts defs)
+ (define (label->idx label) (- label min-label))
+ (define (visit-cont cont)
+ (match (visit-cont* cont)
+ ((cont) cont)))
+ (define (visit-cont* cont)
+ (match cont
+ (($ $cont label cont)
+ (match cont
+ (($ $kargs names syms body)
+ (match (filter-map (lambda (name sym)
+ (and (value-live? sym)
+ (cons name sym)))
+ names syms)
+ (((names . syms) ...)
+ (list
+ (build-cps-cont
+ (label ($kargs names syms
+ ,(visit-term body label))))))))
+ (($ $kfun src meta self tail clause)
+ (list
+ (build-cps-cont
+ (label ($kfun src meta self ,tail
+ ,(and clause (visit-cont clause)))))))
+ (($ $kclause arity body alternate)
+ (list
+ (build-cps-cont
+ (label ($kclause ,arity
+ ,(visit-cont body)
+ ,(and alternate
+ (visit-cont alternate)))))))
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
+ (let ((defs (vector-ref defs (label->idx label))))
+ (if (and-map value-live? defs)
+ (list (build-cps-cont (label ,cont)))
+ (let-fresh (adapt) ()
+ (list (make-adaptor adapt kargs defs)
+ (build-cps-cont
+ (label ($kreceive req rest adapt))))))))
+ (_ (list (build-cps-cont (label ,cont))))))))
+ (define (visit-conts conts)
+ (append-map visit-cont* conts))
+ (define (visit-term term term-k)
+ (match term
+ (($ $letk conts body)
+ (let ((body (visit-term body term-k)))
+ (match (visit-conts conts)
+ (() body)
+ (conts (build-cps-term ($letk ,conts ,body))))))
+ (($ $letrec names syms funs body)
+ (let ((body (visit-term body term-k)))
+ (match (filter-map
+ (lambda (name sym fun)
+ (and (value-live? sym)
+ (match fun
+ (($ $fun free body)
+ (list name
+ sym
+ (build-cps-exp
+ ($fun free ,(visit-fun body))))))))
+ names syms funs)
+ (() body)
+ (((names syms funs) ...)
+ (build-cps-term
+ ($letrec names syms funs ,body))))))
+ (($ $continue k src ($ $values args))
+ (match (vector-ref defs (label->idx term-k))
+ (#f term)
+ (defs
+ (let ((args (filter-map (lambda (use def)
+ (and (value-live? def) use))
+ args defs)))
+ (build-cps-term
+ ($continue k src ($values args)))))))
+ (($ $continue k src exp)
+ (if (bitvector-ref live-conts (label->idx term-k))
+ (rewrite-cps-term exp
+ (($ $fun free body)
+ ($continue k src ($fun free ,(visit-fun body))))
+ (_
+ ,(match (vector-ref defs (label->idx term-k))
+ ((or #f ((? value-live?) ...))
+ (build-cps-term
+ ($continue k src ,exp)))
+ (syms
+ (let-fresh (adapt) ()
+ (build-cps-term
+ ($letk (,(make-adaptor adapt k syms))
+ ($continue adapt src ,exp))))))))
+ (build-cps-term ($continue k src ($values ())))))))
+ (visit-cont fun))))
+ (visit-fun fun))
+
+(define (eliminate-dead-code fun)
+ (call-with-values (lambda () (renumber fun))
+ (lambda (fun nlabels nvars)
+ (parameterize ((label-counter nlabels)
+ (var-counter nvars))
+ (call-with-values (lambda () (compute-live-code fun))
+ (lambda (fun-data-table live-vars)
+ (process-eliminations fun fun-data-table live-vars)))))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; Many passes rely on a local or global static analysis of a function.
+;;; This module implements a simple data-flow graph (DFG) analysis,
+;;; tracking the definitions and uses of variables and continuations.
+;;; It also builds a table of continuations and scope links, to be able
+;;; to easily determine if one continuation is in the scope of another,
+;;; and to get to the expression inside a continuation.
+;;;
+;;; Note that the data-flow graph of continuation labels is a
+;;; control-flow graph.
+;;;
+;;; We currently don't expose details of the DFG type outside this
+;;; module, preferring to only expose accessors. That may change in the
+;;; future but it seems to work for now.
+;;;
+;;; Code:
+
+(define-module (language cps dfg)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 format)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps intset)
+ #:export (build-cont-table
+ lookup-cont
+
+ compute-dfg
+ dfg-cont-table
+ dfg-min-label
+ dfg-label-count
+ dfg-min-var
+ dfg-var-count
+ with-fresh-name-state-from-dfg
+ lookup-def
+ lookup-uses
+ lookup-predecessors
+ lookup-successors
+ lookup-block-scope
+ find-call
+ call-expression
+ find-expression
+ find-defining-expression
+ find-constant-value
+ continuation-bound-in?
+ variable-free-in?
+ constant-needs-allocation?
+ control-point?
+ lookup-bound-syms
+
+ compute-idoms
+ compute-dom-edges
+
+ ;; Data flow analysis.
+ compute-live-variables
+ dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
+ dfa-var-idx dfa-var-sym dfa-var-count
+ print-dfa))
+
+;; These definitions are here because currently we don't do cross-module
+;; inlining. They can be removed once that restriction is gone.
+(define-inlinable (for-each f l)
+ (unless (list? l)
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
+ (let for-each1 ((l l))
+ (unless (null? l)
+ (f (car l))
+ (for-each1 (cdr l)))))
+
+(define-inlinable (for-each/2 f l1 l2)
+ (unless (= (length l1) (length l2))
+ (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+ (list l2) #f))
+ (let for-each2 ((l1 l1) (l2 l2))
+ (unless (null? l1)
+ (f (car l1) (car l2))
+ (for-each2 (cdr l1) (cdr l2)))))
+
+(define (build-cont-table fun)
+ (let ((max-k (fold-conts (lambda (k cont max-k) (max k max-k))
+ -1 fun)))
+ (fold-conts (lambda (k cont table)
+ (vector-set! table k cont)
+ table)
+ (make-vector (1+ max-k) #f)
+ fun)))
+
+;; Data-flow graph for CPS: both for values and continuations.
+(define-record-type $dfg
+ (make-dfg conts preds defs uses scopes scope-levels
+ min-label max-label label-count
+ min-var max-var var-count)
+ dfg?
+ ;; vector of label -> $kargs, etc
+ (conts dfg-cont-table)
+ ;; vector of label -> (pred-label ...)
+ (preds dfg-preds)
+ ;; vector of var -> def-label
+ (defs dfg-defs)
+ ;; vector of var -> (use-label ...)
+ (uses dfg-uses)
+ ;; vector of label -> label
+ (scopes dfg-scopes)
+ ;; vector of label -> int
+ (scope-levels dfg-scope-levels)
+
+ (min-label dfg-min-label)
+ (max-label dfg-max-label)
+ (label-count dfg-label-count)
+
+ (min-var dfg-min-var)
+ (max-var dfg-max-var)
+ (var-count dfg-var-count))
+
+(define-inlinable (vector-push! vec idx val)
+ (let ((v vec) (i idx))
+ (vector-set! v i (cons val (vector-ref v i)))))
+
+(define (compute-reachable dfg min-label label-count)
+ "Compute and return the continuations that may be reached if flow
+reaches a continuation N. Returns a vector of intsets, whose first
+index corresponds to MIN-LABEL, and so on."
+ (let (;; Vector of intsets, indicating that continuation N can
+ ;; reach a set M...
+ (reachable (make-vector label-count #f)))
+
+ (define (label->idx label) (- label min-label))
+
+ ;; Iterate labels backwards, to converge quickly.
+ (let lp ((label (+ min-label label-count)) (changed? #f))
+ (cond
+ ((= label min-label)
+ (if changed?
+ (lp (+ min-label label-count) #f)
+ reachable))
+ (else
+ (let* ((label (1- label))
+ (idx (label->idx label))
+ (old (vector-ref reachable idx))
+ (new (fold (lambda (succ set)
+ (cond
+ ((vector-ref reachable (label->idx succ))
+ => (lambda (succ-set)
+ (intset-union set succ-set)))
+ (else set)))
+ (or (vector-ref reachable idx)
+ (intset-add empty-intset label))
+ (visit-cont-successors list
+ (lookup-cont label dfg)))))
+ (cond
+ ((eq? old new)
+ (lp label changed?))
+ (else
+ (vector-set! reachable idx new)
+ (lp label #t)))))))))
+
+(define (find-prompts dfg min-label label-count)
+ "Find the prompts in DFG between MIN-LABEL and MIN-LABEL +
+LABEL-COUNT, and return them as a list of PROMPT-LABEL, HANDLER-LABEL
+pairs."
+ (let lp ((label min-label) (prompts '()))
+ (cond
+ ((= label (+ min-label label-count))
+ (reverse prompts))
+ (else
+ (match (lookup-cont label dfg)
+ (($ $kargs names syms body)
+ (match (find-expression body)
+ (($ $prompt escape? tag handler)
+ (lp (1+ label) (acons label handler prompts)))
+ (_ (lp (1+ label) prompts))))
+ (_ (lp (1+ label) prompts)))))))
+
+(define (compute-interval reachable min-label label-count start end)
+ "Compute and return the set of continuations that may be reached from
+START, inclusive, but not reached by END, exclusive. Returns an
+intset."
+ (intset-subtract (vector-ref reachable (- start min-label))
+ (vector-ref reachable (- end min-label))))
+
+(define (find-prompt-bodies dfg min-label label-count)
+ "Find all the prompts in DFG from the LABEL-COUNT continuations
+starting at MIN-LABEL, and compute the set of continuations that is
+reachable from the prompt bodies but not from the corresponding handler.
+Returns a list of PROMPT, HANDLER, BODY lists, where the BODY is an
+intset."
+ (match (find-prompts dfg min-label label-count)
+ (() '())
+ (((prompt . handler) ...)
+ (let ((reachable (compute-reachable dfg min-label label-count)))
+ (map (lambda (prompt handler)
+ ;; FIXME: It isn't correct to use all continuations
+ ;; reachable from the prompt, because that includes
+ ;; continuations outside the prompt body. This point is
+ ;; moot if the handler's control flow joins with the the
+ ;; body, as is usually but not always the case.
+ ;;
+ ;; One counter-example is when the handler contifies an
+ ;; infinite loop; in that case we compute a too-large
+ ;; prompt body. This error is currently innocuous, but we
+ ;; should fix it at some point.
+ ;;
+ ;; The fix is to end the body at the corresponding "pop"
+ ;; primcall, if any.
+ (let ((body (compute-interval reachable min-label label-count
+ prompt handler)))
+ (list prompt handler body)))
+ prompt handler)))))
+
+(define* (visit-prompt-control-flow dfg min-label label-count f #:key complete?)
+ "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL +
+LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each
+body continuation in the prompt."
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+ (for-each
+ (match-lambda
+ ((prompt handler body)
+ (define (out-or-back-edge? label)
+ ;; Most uses of visit-prompt-control-flow don't need every body
+ ;; continuation, and would be happy getting called only for
+ ;; continuations that postdominate the rest of the body. Unless
+ ;; you pass #:complete? #t, we only invoke F on continuations
+ ;; that can leave the body, or on back-edges in loops.
+ ;;
+ ;; You would think that looking for the final "pop" primcall
+ ;; would be sufficient, but that is incorrect; it's possible for
+ ;; a loop in the prompt body to be contified, and that loop need
+ ;; not continue to the pop if it never terminates. The pop could
+ ;; even be removed by DCE, in that case.
+ (or-map (lambda (succ)
+ (or (not (intset-ref body succ))
+ (<= succ label)))
+ (lookup-successors label dfg)))
+ (let lp ((label min-label))
+ (let ((label (intset-next body label)))
+ (when label
+ (when (or complete? (out-or-back-edge? label))
+ (f prompt handler label))
+ (lp (1+ label)))))))
+ (find-prompt-bodies dfg min-label label-count)))
+
+(define (analyze-reverse-control-flow fun dfg min-label label-count)
+ (define (compute-reverse-control-flow-order ktail dfg)
+ (let ((label-map (make-vector label-count #f))
+ (next -1))
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+
+ (let visit ((k ktail))
+ ;; Mark this label as visited.
+ (vector-set! label-map (label->idx k) #t)
+ (for-each (lambda (k)
+ ;; Visit predecessors unless they are already visited.
+ (unless (vector-ref label-map (label->idx k))
+ (visit k)))
+ (lookup-predecessors k dfg))
+ ;; Add to reverse post-order chain.
+ (vector-set! label-map (label->idx k) next)
+ (set! next k))
+
+ (let lp ((n 0) (head next))
+ (if (< head 0)
+ ;; Add nodes that are not reachable from the tail.
+ (let lp ((n n) (m label-count))
+ (unless (= n label-count)
+ (let find-unvisited ((m (1- m)))
+ (if (vector-ref label-map m)
+ (find-unvisited (1- m))
+ (begin
+ (vector-set! label-map m n)
+ (lp (1+ n) m))))))
+ ;; Pop the head off the chain, give it its
+ ;; reverse-post-order numbering, and continue.
+ (let ((next (vector-ref label-map (label->idx head))))
+ (vector-set! label-map (label->idx head) n)
+ (lp (1+ n) next))))
+
+ label-map))
+
+ (define (convert-successors k-map)
+ (define (idx->label idx) (+ idx min-label))
+ (define (renumber label)
+ (vector-ref k-map (- label min-label)))
+ (let ((succs (make-vector (vector-length k-map) #f)))
+ (let lp ((n 0))
+ (when (< n (vector-length succs))
+ (vector-set! succs (vector-ref k-map n)
+ (map renumber
+ (lookup-successors (idx->label n) dfg)))
+ (lp (1+ n))))
+ succs))
+
+ (match fun
+ (($ $cont kfun ($ $kfun src meta self ($ $cont ktail tail)))
+ (let* ((k-map (compute-reverse-control-flow-order ktail dfg))
+ (succs (convert-successors k-map)))
+ ;; Any expression in the prompt body could cause an abort to
+ ;; the handler. This code adds links from every block in the
+ ;; prompt body to the handler. This causes all values used
+ ;; by the handler to be seen as live in the prompt body, as
+ ;; indeed they are.
+ (visit-prompt-control-flow
+ dfg min-label label-count
+ (lambda (prompt handler body)
+ (define (renumber label)
+ (vector-ref k-map (- label min-label)))
+ (vector-push! succs (renumber body) (renumber handler))))
+
+ (values k-map succs)))))
+
+(define (compute-idoms dfg min-label label-count)
+ (define preds (dfg-preds dfg))
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+ (define (idx->dfg-idx idx) (- (idx->label idx) (dfg-min-label dfg)))
+ (let ((idoms (make-vector label-count #f)))
+ (define (common-idom d0 d1)
+ ;; We exploit the fact that a reverse post-order is a topological
+ ;; sort, and so the idom of a node is always numerically less than
+ ;; the node itself.
+ (cond
+ ((= d0 d1) d0)
+ ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1))))
+ (else (common-idom (vector-ref idoms (label->idx d0)) d1))))
+ (define (compute-idom preds)
+ (define (has-idom? pred)
+ (vector-ref idoms (label->idx pred)))
+ (match preds
+ (() min-label)
+ ((pred . preds)
+ (if (has-idom? pred)
+ (let lp ((idom pred) (preds preds))
+ (match preds
+ (() idom)
+ ((pred . preds)
+ (lp (if (has-idom? pred)
+ (common-idom idom pred)
+ idom)
+ preds))))
+ (compute-idom preds)))))
+ ;; This is the iterative O(n^2) fixpoint algorithm, originally from
+ ;; Allen and Cocke ("Graph-theoretic constructs for program flow
+ ;; analysis", 1972). See the discussion in Cooper, Harvey, and
+ ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
+ (let iterate ((n 0) (changed? #f))
+ (cond
+ ((< n label-count)
+ (let ((idom (vector-ref idoms n))
+ (idom* (compute-idom (vector-ref preds (idx->dfg-idx n)))))
+ (cond
+ ((eqv? idom idom*)
+ (iterate (1+ n) changed?))
+ (else
+ (vector-set! idoms n idom*)
+ (iterate (1+ n) #t)))))
+ (changed?
+ (iterate 0 #f))
+ (else idoms)))))
+
+;; Compute a vector containing, for each node, a list of the nodes that
+;; it immediately dominates. These are the "D" edges in the DJ tree.
+(define (compute-dom-edges idoms min-label)
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+ (let ((doms (make-vector (vector-length idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vector-length idoms))
+ (let ((idom (vector-ref idoms n)))
+ (vector-push! doms (label->idx idom) (idx->label n)))
+ (lp (1+ n))))
+ doms))
+
+;; There used to be some loop detection code here, but it bitrotted.
+;; We'll need it again eventually but for now it can be found in the git
+;; history.
+
+;; Data-flow analysis.
+(define-record-type $dfa
+ (make-dfa min-label min-var var-count in out)
+ dfa?
+ ;; Minimum label in this function.
+ (min-label dfa-min-label)
+ ;; Minimum var in this function.
+ (min-var dfa-min-var)
+ ;; Var count in this function.
+ (var-count dfa-var-count)
+ ;; Vector of k-idx -> intset
+ (in dfa-in)
+ ;; Vector of k-idx -> intset
+ (out dfa-out))
+
+(define (dfa-k-idx dfa k)
+ (- k (dfa-min-label dfa)))
+
+(define (dfa-k-sym dfa idx)
+ (+ idx (dfa-min-label dfa)))
+
+(define (dfa-k-count dfa)
+ (vector-length (dfa-in dfa)))
+
+(define (dfa-var-idx dfa var)
+ (let ((idx (- var (dfa-min-var dfa))))
+ (unless (< -1 idx (dfa-var-count dfa))
+ (error "var out of range" var))
+ idx))
+
+(define (dfa-var-sym dfa idx)
+ (unless (< -1 idx (dfa-var-count dfa))
+ (error "idx out of range" idx))
+ (+ idx (dfa-min-var dfa)))
+
+(define (dfa-k-in dfa idx)
+ (vector-ref (dfa-in dfa) idx))
+
+(define (dfa-k-out dfa idx)
+ (vector-ref (dfa-out dfa) idx))
+
+(define (compute-live-variables fun dfg)
+ ;; Compute the maximum fixed point of the data-flow constraint problem.
+ ;;
+ ;; This always completes, as the graph is finite and the in and out sets
+ ;; are complete semi-lattices. If the graph is reducible and the blocks
+ ;; are sorted in reverse post-order, this completes in a maximum of LC +
+ ;; 2 iterations, where LC is the loop connectedness number. See Hecht
+ ;; and Ullman, "Analysis of a simple algorithm for global flow
+ ;; problems", POPL 1973, or the recent summary in "Notes on graph
+ ;; algorithms used in optimizing compilers", Offner 2013.
+ (define (compute-maximum-fixed-point preds inv outv killv genv)
+ (define (fold f seed l)
+ (if (null? l) seed (fold f (f (car l) seed) (cdr l))))
+ (let lp ((n 0) (changed? #f))
+ (cond
+ ((< n (vector-length preds))
+ (let* ((in (vector-ref inv n))
+ (in* (or
+ (fold (lambda (pred set)
+ (cond
+ ((vector-ref outv pred)
+ => (lambda (out)
+ (if set
+ (intset-union set out)
+ out)))
+ (else set)))
+ in
+ (vector-ref preds n))
+ empty-intset)))
+ (if (eq? in in*)
+ (lp (1+ n) changed?)
+ (let ((out* (fold (lambda (gen set)
+ (intset-add set gen))
+ (fold (lambda (kill set)
+ (intset-remove set kill))
+ in*
+ (vector-ref killv n))
+ (vector-ref genv n))))
+ (vector-set! inv n in*)
+ (vector-set! outv n out*)
+ (lp (1+ n) #t)))))
+ (changed?
+ (lp 0 #f)))))
+
+ (unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg))
+ (= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg)))
+ (error "function needs renumbering"))
+ (let* ((min-label (dfg-min-label dfg))
+ (nlabels (dfg-label-count dfg))
+ (min-var (dfg-min-var dfg))
+ (nvars (dfg-var-count dfg))
+ (usev (make-vector nlabels '()))
+ (defv (make-vector nlabels '()))
+ (live-in (make-vector nlabels #f))
+ (live-out (make-vector nlabels #f)))
+ (call-with-values
+ (lambda ()
+ (analyze-reverse-control-flow fun dfg min-label nlabels))
+ (lambda (k-map succs)
+ (define (var->idx var) (- var min-var))
+ (define (idx->var idx) (+ idx min-var))
+ (define (label->idx label)
+ (vector-ref k-map (- label min-label)))
+
+ ;; Initialize defv and usev.
+ (let ((defs (dfg-defs dfg))
+ (uses (dfg-uses dfg)))
+ (let lp ((n 0))
+ (when (< n (vector-length defs))
+ (let ((def (vector-ref defs n)))
+ (unless def
+ (error "internal error -- var array not packed"))
+ (for-each (lambda (def)
+ (vector-push! defv (label->idx def) n))
+ (lookup-predecessors def dfg))
+ (for-each (lambda (use)
+ (vector-push! usev (label->idx use) n))
+ (vector-ref uses n))
+ (lp (1+ n))))))
+
+ ;; Liveness is a reverse data-flow problem, so we give
+ ;; compute-maximum-fixed-point a reversed graph, swapping in for
+ ;; out, usev for defv, and using successors instead of
+ ;; predecessors. Continuation 0 is ktail.
+ (compute-maximum-fixed-point succs live-out live-in defv usev)
+
+ ;; Now rewrite the live-in and live-out sets to be indexed by
+ ;; (LABEL - MIN-LABEL).
+ (let ((live-in* (make-vector nlabels #f))
+ (live-out* (make-vector nlabels #f)))
+ (let lp ((idx 0))
+ (when (< idx nlabels)
+ (let ((dfa-idx (vector-ref k-map idx)))
+ (vector-set! live-in* idx (vector-ref live-in dfa-idx))
+ (vector-set! live-out* idx (vector-ref live-out dfa-idx))
+ (lp (1+ idx)))))
+
+ (make-dfa min-label min-var nvars live-in* live-out*))))))
+
+(define (print-dfa dfa)
+ (match dfa
+ (($ $dfa min-label min-var var-count in out)
+ (define (print-var-set bv)
+ (let lp ((n 0))
+ (let ((n (intset-next bv n)))
+ (when n
+ (format #t " ~A" (+ n min-var))
+ (lp (1+ n))))))
+ (let lp ((n 0))
+ (when (< n (vector-length in))
+ (format #t "~A:\n" (+ n min-label))
+ (format #t " in:")
+ (print-var-set (vector-ref in n))
+ (newline)
+ (format #t " out:")
+ (print-var-set (vector-ref out n))
+ (newline)
+ (lp (1+ n)))))))
+
+(define (compute-label-and-var-ranges fun global?)
+ (define (min* a b)
+ (if b (min a b) a))
+ (define-syntax-rule (do-fold make-cont-folder)
+ ((make-cont-folder min-label max-label label-count
+ min-var max-var var-count)
+ (lambda (label cont
+ min-label max-label label-count
+ min-var max-var var-count)
+ (let ((min-label (min* label min-label))
+ (max-label (max label max-label)))
+ (define (visit-letrec body min-var max-var var-count)
+ (match body
+ (($ $letk conts body)
+ (visit-letrec body min-var max-var var-count))
+ (($ $letrec names vars funs body)
+ (visit-letrec body
+ (cond (min-var (fold min min-var vars))
+ ((pair? vars) (fold min (car vars) (cdr vars)))
+ (else min-var))
+ (fold max max-var vars)
+ (+ var-count (length vars))))
+ (($ $continue) (values min-var max-var var-count))))
+ (match cont
+ (($ $kargs names vars body)
+ (call-with-values
+ (lambda ()
+ (if global?
+ (visit-letrec body min-var max-var var-count)
+ (values min-var max-var var-count)))
+ (lambda (min-var max-var var-count)
+ (values min-label max-label (1+ label-count)
+ (cond (min-var (fold min min-var vars))
+ ((pair? vars) (fold min (car vars) (cdr vars)))
+ (else min-var))
+ (fold max max-var vars)
+ (+ var-count (length vars))))))
+ (($ $kfun src meta self)
+ (values min-label max-label (1+ label-count)
+ (min* self min-var) (max self max-var) (1+ var-count)))
+ (_ (values min-label max-label (1+ label-count)
+ min-var max-var var-count)))))
+ fun
+ #f -1 0 #f -1 0))
+ (if global?
+ (do-fold make-global-cont-folder)
+ (do-fold make-local-cont-folder)))
+
+(define* (compute-dfg fun #:key (global? #t))
+ (call-with-values (lambda () (compute-label-and-var-ranges fun global?))
+ (lambda (min-label max-label label-count min-var max-var var-count)
+ (when (or (zero? label-count) (zero? var-count))
+ (error "internal error (no vars or labels for fun?)"))
+ (let* ((nlabels (- (1+ max-label) min-label))
+ (nvars (- (1+ max-var) min-var))
+ (conts (make-vector nlabels #f))
+ (preds (make-vector nlabels '()))
+ (defs (make-vector nvars #f))
+ (uses (make-vector nvars '()))
+ (scopes (make-vector nlabels #f))
+ (scope-levels (make-vector nlabels #f)))
+ (define (var->idx var) (- var min-var))
+ (define (label->idx label) (- label min-label))
+
+ (define (add-def! var def-k)
+ (vector-set! defs (var->idx var) def-k))
+ (define (add-use! var use-k)
+ (vector-push! uses (var->idx var) use-k))
+
+ (define* (declare-block! label cont parent
+ #:optional (level
+ (1+ (vector-ref
+ scope-levels
+ (label->idx parent)))))
+ (vector-set! conts (label->idx label) cont)
+ (vector-set! scopes (label->idx label) parent)
+ (vector-set! scope-levels (label->idx label) level))
+
+ (define (link-blocks! pred succ)
+ (vector-push! preds (label->idx succ) pred))
+
+ (define (visit-cont cont label)
+ (match cont
+ (($ $kargs names syms body)
+ (for-each (cut add-def! <> label) syms)
+ (visit-term body label))
+ (($ $kreceive arity k)
+ (link-blocks! label k))))
+
+ (define (visit-term term label)
+ (match term
+ (($ $letk (($ $cont k cont) ...) body)
+ ;; Set up recursive environment before visiting cont bodies.
+ (for-each/2 (lambda (cont k)
+ (declare-block! k cont label))
+ cont k)
+ (for-each/2 visit-cont cont k)
+ (visit-term body label))
+ (($ $letrec names syms funs body)
+ (unless global?
+ (error "$letrec should not be present when building a local DFG"))
+ (for-each (cut add-def! <> label) syms)
+ (for-each (lambda (fun)
+ (match fun
+ (($ $fun free body)
+ (visit-fun body))))
+ funs)
+ (visit-term body label))
+ (($ $continue k src exp)
+ (link-blocks! label k)
+ (visit-exp exp label))))
+
+ (define (visit-exp exp label)
+ (define (use! sym)
+ (add-use! sym label))
+ (match exp
+ ((or ($ $void) ($ $const) ($ $prim) ($ $closure)) #f)
+ (($ $call proc args)
+ (use! proc)
+ (for-each use! args))
+ (($ $callk k proc args)
+ (use! proc)
+ (for-each use! args))
+ (($ $primcall name args)
+ (for-each use! args))
+ (($ $branch kt exp)
+ (link-blocks! label kt)
+ (visit-exp exp label))
+ (($ $values args)
+ (for-each use! args))
+ (($ $prompt escape? tag handler)
+ (use! tag)
+ (link-blocks! label handler))
+ (($ $fun free body)
+ (when global?
+ (visit-fun body)))))
+
+ (define (visit-clause clause kfun)
+ (match clause
+ (#f #t)
+ (($ $cont kclause
+ (and clause ($ $kclause arity ($ $cont kbody body)
+ alternate)))
+ (declare-block! kclause clause kfun)
+ (link-blocks! kfun kclause)
+
+ (declare-block! kbody body kclause)
+ (link-blocks! kclause kbody)
+
+ (visit-cont body kbody)
+ (visit-clause alternate kfun))))
+
+ (define (visit-fun fun)
+ (match fun
+ (($ $cont kfun
+ (and cont
+ ($ $kfun src meta self ($ $cont ktail tail) clause)))
+ (declare-block! kfun cont #f 0)
+ (add-def! self kfun)
+ (declare-block! ktail tail kfun)
+ (visit-clause clause kfun))))
+
+ (visit-fun fun)
+
+ (make-dfg conts preds defs uses scopes scope-levels
+ min-label max-label label-count
+ min-var max-var var-count)))))
+
+(define* (dump-dfg dfg #:optional (port (current-output-port)))
+ (let ((min-label (dfg-min-label dfg))
+ (min-var (dfg-min-var dfg)))
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+ (define (var->idx var) (- var min-var))
+ (define (idx->var idx) (+ idx min-var))
+
+ (let lp ((label (dfg-min-label dfg)))
+ (when (<= label (dfg-max-label dfg))
+ (let ((cont (vector-ref (dfg-cont-table dfg) (label->idx label))))
+ (when cont
+ (unless (equal? (lookup-predecessors label dfg) (list (1- label)))
+ (newline port))
+ (format port "k~a:~8t" label)
+ (match cont
+ (($ $kreceive arity k)
+ (format port "$kreceive ~a k~a\n" arity k))
+ (($ $kfun src meta self tail clause)
+ (format port "$kfun ~a ~a v~a\n" src meta self))
+ (($ $ktail)
+ (format port "$ktail\n"))
+ (($ $kclause arity ($ $cont kbody) alternate)
+ (format port "$kclause ~a k~a" arity kbody)
+ (match alternate
+ (#f #f)
+ (($ $cont kalt) (format port " -> k~a" kalt)))
+ (newline port))
+ (($ $kargs names vars term)
+ (unless (null? vars)
+ (format port "v~a[~a]~:{ v~a[~a]~}: "
+ (car vars) (car names) (map list (cdr vars) (cdr names))))
+ (match (find-call term)
+ (($ $continue kf src ($ $branch kt exp))
+ (format port "if ")
+ (match exp
+ (($ $primcall name args)
+ (format port "(~a~{ v~a~})" name args))
+ (($ $values (arg))
+ (format port "v~a" arg)))
+ (format port " k~a k~a\n" kt kf))
+ (($ $continue k src exp)
+ (match exp
+ (($ $void) (format port "void"))
+ (($ $const val) (format port "const ~@y" val))
+ (($ $prim name) (format port "prim ~a" name))
+ (($ $fun free ($ $cont kbody)) (format port "fun k~a" kbody))
+ (($ $closure label nfree) (format port "closure k~a (~a free)" label nfree))
+ (($ $call proc args) (format port "call~{ v~a~}" (cons proc args)))
+ (($ $callk k proc args) (format port "callk k~a~{ v~a~}" k (cons proc args)))
+ (($ $primcall name args) (format port "~a~{ v~a~}" name args))
+ (($ $values args) (format port "values~{ v~a~}" args))
+ (($ $prompt escape? tag handler) (format port "prompt ~a v~a k~a" escape? tag handler)))
+ (unless (= k (1+ label))
+ (format port " -> k~a" k))
+ (newline port))))))
+ (lp (1+ label)))))))
+
+(define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...)
+ (parameterize ((label-counter (1+ (dfg-max-label dfg)))
+ (var-counter (1+ (dfg-max-var dfg))))
+ body ...))
+
+(define (lookup-cont label dfg)
+ (let ((res (vector-ref (dfg-cont-table dfg) (- label (dfg-min-label dfg)))))
+ (unless res
+ (error "Unknown continuation!" label))
+ res))
+
+(define (lookup-predecessors k dfg)
+ (vector-ref (dfg-preds dfg) (- k (dfg-min-label dfg))))
+
+(define (lookup-successors k dfg)
+ (let ((cont (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg)))))
+ (visit-cont-successors list cont)))
+
+(define (lookup-def var dfg)
+ (vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg))))
+
+(define (lookup-uses var dfg)
+ (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg))))
+
+(define (lookup-block-scope k dfg)
+ (vector-ref (dfg-scopes dfg) (- k (dfg-min-label dfg))))
+
+(define (lookup-scope-level k dfg)
+ (vector-ref (dfg-scope-levels dfg) (- k (dfg-min-label dfg))))
+
+(define (find-defining-term sym dfg)
+ (match (lookup-predecessors (lookup-def sym dfg) dfg)
+ ((def-exp-k)
+ (lookup-cont def-exp-k dfg))
+ (else #f)))
+
+(define (find-call term)
+ (match term
+ (($ $kargs names syms body) (find-call body))
+ (($ $letk conts body) (find-call body))
+ (($ $letrec names syms funs body) (find-call body))
+ (($ $continue) term)))
+
+(define (call-expression call)
+ (match call
+ (($ $continue k src exp) exp)))
+
+(define (find-expression term)
+ (call-expression (find-call term)))
+
+(define (find-defining-expression sym dfg)
+ (match (find-defining-term sym dfg)
+ (#f #f)
+ (($ $kreceive) #f)
+ (($ $kclause) #f)
+ (term (find-expression term))))
+
+(define (find-constant-value sym dfg)
+ (match (find-defining-expression sym dfg)
+ (($ $const val)
+ (values #t val))
+ (($ $continue k src ($ $void))
+ (values #t *unspecified*))
+ (else
+ (values #f #f))))
+
+(define (constant-needs-allocation? var val dfg)
+ (define (immediate-u8? val)
+ (and (integer? val) (exact? val) (<= 0 val 255)))
+
+ (define (find-exp term)
+ (match term
+ (($ $kargs names vars body) (find-exp body))
+ (($ $letk conts body) (find-exp body))
+ (else term)))
+
+ (or-map
+ (lambda (use)
+ (match (find-expression (lookup-cont use dfg))
+ (($ $call) #f)
+ (($ $callk) #f)
+ (($ $values) #f)
+ (($ $primcall 'free-ref (closure slot))
+ (eq? var closure))
+ (($ $primcall 'free-set! (closure slot value))
+ (or (eq? var closure) (eq? var value)))
+ (($ $primcall 'cache-current-module! (mod . _))
+ (eq? var mod))
+ (($ $primcall 'cached-toplevel-box _)
+ #f)
+ (($ $primcall 'cached-module-box _)
+ #f)
+ (($ $primcall 'resolve (name bound?))
+ (eq? var name))
+ (($ $primcall 'make-vector/immediate (len init))
+ (eq? var init))
+ (($ $primcall 'vector-ref/immediate (v i))
+ (eq? var v))
+ (($ $primcall 'vector-set!/immediate (v i x))
+ (or (eq? var v) (eq? var x)))
+ (($ $primcall 'allocate-struct/immediate (vtable nfields))
+ (eq? var vtable))
+ (($ $primcall 'struct-ref/immediate (s n))
+ (eq? var s))
+ (($ $primcall 'struct-set!/immediate (s n x))
+ (or (eq? var s) (eq? var x)))
+ (($ $primcall 'builtin-ref (idx))
+ #f)
+ (_ #t)))
+ (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg)))))
+
+(define (continuation-scope-contains? scope-k k dfg)
+ (let ((scope-level (lookup-scope-level scope-k dfg)))
+ (let lp ((k k))
+ (or (eq? scope-k k)
+ (and (< scope-level (lookup-scope-level k dfg))
+ (lp (lookup-block-scope k dfg)))))))
+
+(define (continuation-bound-in? k use-k dfg)
+ (continuation-scope-contains? (lookup-block-scope k dfg) use-k dfg))
+
+(define (variable-free-in? var k dfg)
+ (or-map (lambda (use)
+ (continuation-scope-contains? k use dfg))
+ (lookup-uses var dfg)))
+
+;; A continuation is a control point if it has multiple predecessors, or
+;; if its single predecessor does not have a single successor.
+(define (control-point? k dfg)
+ (match (lookup-predecessors k dfg)
+ ((pred)
+ (let ((cont (vector-ref (dfg-cont-table dfg)
+ (- pred (dfg-min-label dfg)))))
+ (visit-cont-successors (case-lambda
+ (() #t)
+ ((succ0) #f)
+ ((succ1 succ2) #t))
+ cont)))
+ (_ #t)))
+
+(define (lookup-bound-syms k dfg)
+ (match (lookup-cont k dfg)
+ (($ $kargs names syms body)
+ syms)))
--- /dev/null
+;;; Effects analysis on CPS
+
+;; Copyright (C) 2011, 2012, 2013, 2014, 2015 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
+
+;;; Commentary:
+;;;
+;;; A helper module to compute the set of effects caused by an
+;;; expression. This information is useful when writing algorithms that
+;;; move code around, while preserving the semantics of an input
+;;; program.
+;;;
+;;; The effects set is represented as an integer with three parts. The
+;;; low 4 bits indicate effects caused by an expression, as a bitfield.
+;;; The next 4 bits indicate the kind of memory accessed by the
+;;; expression, if it accesses mutable memory. Finally the rest of the
+;;; bits indicate the field in the object being accessed, if known, or
+;;; -1 for unknown.
+;;;
+;;; In this way we embed a coarse type-based alias analysis in the
+;;; effects analysis. For example, a "car" call is modelled as causing
+;;; a read to field 0 on a &pair, and causing a &type-check effect. If
+;;; any intervening code sets the car of any pair, that will block
+;;; motion of the "car" call, because any write to field 0 of a pair is
+;;; seen by effects analysis as being a write to field 0 of all pairs.
+;;;
+;;; Code:
+
+(define-module (language cps effects-analysis)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (ice-9 match)
+ #:export (expression-effects
+ compute-effects
+ synthesize-definition-effects!
+
+ &allocation
+ &type-check
+ &read
+ &write
+
+ &fluid
+ &prompt
+ &car
+ &cdr
+ &vector
+ &box
+ &module
+ &struct
+ &string
+ &bytevector
+
+ &object
+ &field
+
+ &allocate
+ &read-object
+ &read-field
+ &write-object
+ &write-field
+
+ &no-effects
+ &all-effects
+
+ exclude-effects
+ effect-free?
+ constant?
+ causes-effect?
+ causes-all-effects?
+ effect-clobbers?))
+
+(define-syntax define-flags
+ (lambda (x)
+ (syntax-case x ()
+ ((_ all shift name ...)
+ (let ((count (length #'(name ...))))
+ (with-syntax (((n ...) (iota count))
+ (count count))
+ #'(begin
+ (define-syntax name (identifier-syntax (ash 1 n)))
+ ...
+ (define-syntax all (identifier-syntax (1- (ash 1 count))))
+ (define-syntax shift (identifier-syntax count)))))))))
+
+(define-syntax define-enumeration
+ (lambda (x)
+ (define (count-bits n)
+ (let lp ((out 1))
+ (if (< n (ash 1 (1- out)))
+ out
+ (lp (1+ out)))))
+ (syntax-case x ()
+ ((_ mask shift name ...)
+ (let* ((len (length #'(name ...)))
+ (bits (count-bits len)))
+ (with-syntax (((n ...) (iota len))
+ (bits bits))
+ #'(begin
+ (define-syntax name (identifier-syntax n))
+ ...
+ (define-syntax mask (identifier-syntax (1- (ash 1 bits))))
+ (define-syntax shift (identifier-syntax bits)))))))))
+
+(define-flags &all-effect-kinds &effect-kind-bits
+ ;; Indicates that an expression may cause a type check. A type check,
+ ;; for the purposes of this analysis, is the possibility of throwing
+ ;; an exception the first time an expression is evaluated. If the
+ ;; expression did not cause an exception to be thrown, users can
+ ;; assume that evaluating the expression again will not cause an
+ ;; exception to be thrown.
+ ;;
+ ;; For example, (+ x y) might throw if X or Y are not numbers. But if
+ ;; it doesn't throw, it should be safe to elide a dominated, common
+ ;; subexpression (+ x y).
+ &type-check
+
+ ;; Indicates that an expression may return a fresh object. The kind
+ ;; of object is indicated in the object kind field.
+ &allocation
+
+ ;; Indicates that an expression may cause a read from memory. The
+ ;; kind of memory is given in the object kind field. Some object
+ ;; kinds have finer-grained fields; those are expressed in the "field"
+ ;; part of the effects value. -1 indicates "the whole object".
+ &read
+
+ ;; Indicates that an expression may cause a write to memory.
+ &write)
+
+(define-enumeration &memory-kind-mask &memory-kind-bits
+ ;; Indicates than an expression may access unknown kinds of memory.
+ &unknown-memory-kinds
+
+ ;; Indicates that an expression depends on the value of a fluid
+ ;; variable, or on the current fluid environment.
+ &fluid
+
+ ;; Indicates that an expression depends on the current prompt
+ ;; stack.
+ &prompt
+
+ ;; Indicates that an expression depends on the value of the car or cdr
+ ;; of a pair.
+ &pair
+
+ ;; Indicates that an expression depends on the value of a vector
+ ;; field. The effect field indicates the specific field, or zero for
+ ;; an unknown field.
+ &vector
+
+ ;; Indicates that an expression depends on the value of a variable
+ ;; cell.
+ &box
+
+ ;; Indicates that an expression depends on the current module.
+ &module
+
+ ;; Indicates that an expression depends on the value of a struct
+ ;; field. The effect field indicates the specific field, or zero for
+ ;; an unknown field.
+ &struct
+
+ ;; Indicates that an expression depends on the contents of a string.
+ &string
+
+ ;; Indicates that an expression depends on the contents of a
+ ;; bytevector. We cannot be more precise, as bytevectors may alias
+ ;; other bytevectors.
+ &bytevector)
+
+(define-inlinable (&field kind field)
+ (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits))
+(define-inlinable (&object kind)
+ (&field kind -1))
+
+(define-inlinable (&allocate kind)
+ (logior &allocation (&object kind)))
+(define-inlinable (&read-field kind field)
+ (logior &read (&field kind field)))
+(define-inlinable (&read-object kind)
+ (logior &read (&object kind)))
+(define-inlinable (&write-field kind field)
+ (logior &write (&field kind field)))
+(define-inlinable (&write-object kind)
+ (logior &write (&object kind)))
+
+(define-syntax &no-effects (identifier-syntax 0))
+(define-syntax &all-effects
+ (identifier-syntax
+ (logior &all-effect-kinds (&object &unknown-memory-kinds))))
+
+(define-inlinable (constant? effects)
+ (zero? effects))
+
+(define-inlinable (causes-effect? x effects)
+ (not (zero? (logand x effects))))
+
+(define-inlinable (causes-all-effects? x)
+ (eqv? x &all-effects))
+
+(define (effect-clobbers? a b)
+ "Return true if A clobbers B. This is the case if A is a write, and B
+is or might be a read or a write to the same location as A."
+ (define (locations-same?)
+ (let ((a (ash a (- &effect-kind-bits)))
+ (b (ash b (- &effect-kind-bits))))
+ (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask))
+ (eqv? &unknown-memory-kinds (logand b &memory-kind-mask))
+ (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask))
+ ;; A negative field indicates "the whole object".
+ ;; Non-negative fields indicate only part of the object.
+ (or (< a 0) (< b 0) (= a b))))))
+ (and (not (zero? (logand a &write)))
+ (not (zero? (logand b (logior &read &write))))
+ (locations-same?)))
+
+(define (lookup-constant-index sym dfg)
+ (call-with-values (lambda () (find-constant-value sym dfg))
+ (lambda (has-const? val)
+ (and has-const? (integer? val) (exact? val) (<= 0 val) val))))
+
+(define-inlinable (indexed-field kind n dfg)
+ (cond
+ ((lookup-constant-index n dfg)
+ => (lambda (idx)
+ (&field kind idx)))
+ (else (&object kind))))
+
+(define *primitive-effects* (make-hash-table))
+
+(define-syntax-rule (define-primitive-effects* dfg
+ ((name . args) effects ...)
+ ...)
+ (begin
+ (hashq-set! *primitive-effects* 'name
+ (case-lambda*
+ ((dfg . args) (logior effects ...))
+ (_ &all-effects)))
+ ...))
+
+(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...)
+ (define-primitive-effects* dfg ((name . args) effects ...) ...))
+
+;; Miscellaneous.
+(define-primitive-effects
+ ((values . _)))
+
+;; Generic effect-free predicates.
+(define-primitive-effects
+ ((eq? . _))
+ ((eqv? . _))
+ ((equal? . _))
+ ((pair? arg))
+ ((null? arg))
+ ((nil? arg ))
+ ((symbol? arg))
+ ((variable? arg))
+ ((vector? arg))
+ ((struct? arg))
+ ((string? arg))
+ ((number? arg))
+ ((char? arg))
+ ((bytevector? arg))
+ ((keyword? arg))
+ ((bitvector? arg))
+ ((procedure? arg))
+ ((thunk? arg)))
+
+;; Fluids.
+(define-primitive-effects
+ ((fluid-ref f) (&read-object &fluid) &type-check)
+ ((fluid-set! f v) (&write-object &fluid) &type-check)
+ ((push-fluid f v) (&write-object &fluid) &type-check)
+ ((pop-fluid) (&write-object &fluid) &type-check))
+
+;; Prompts.
+(define-primitive-effects
+ ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds)))
+
+;; Pairs.
+(define-primitive-effects
+ ((cons a b) (&allocate &pair))
+ ((list . _) (&allocate &pair))
+ ((car x) (&read-field &pair 0) &type-check)
+ ((set-car! x y) (&write-field &pair 0) &type-check)
+ ((cdr x) (&read-field &pair 1) &type-check)
+ ((set-cdr! x y) (&write-field &pair 1) &type-check)
+ ((memq x y) (&read-object &pair) &type-check)
+ ((memv x y) (&read-object &pair) &type-check)
+ ((list? arg) (&read-field &pair 1))
+ ((length l) (&read-field &pair 1) &type-check))
+
+;; Variables.
+(define-primitive-effects
+ ((box v) (&allocate &box))
+ ((box-ref v) (&read-object &box) &type-check)
+ ((box-set! v x) (&write-object &box) &type-check))
+
+;; Vectors.
+(define (vector-field n dfg)
+ (indexed-field &vector n dfg))
+(define (read-vector-field n dfg)
+ (logior &read (vector-field n dfg)))
+(define (write-vector-field n dfg)
+ (logior &write (vector-field n dfg)))
+(define-primitive-effects* dfg
+ ((vector . _) (&allocate &vector))
+ ((make-vector n init) (&allocate &vector) &type-check)
+ ((make-vector/immediate n init) (&allocate &vector))
+ ((vector-ref v n) (read-vector-field n dfg) &type-check)
+ ((vector-ref/immediate v n) (read-vector-field n dfg) &type-check)
+ ((vector-set! v n x) (write-vector-field n dfg) &type-check)
+ ((vector-set!/immediate v n x) (write-vector-field n dfg) &type-check)
+ ((vector-length v) &type-check))
+
+;; Structs.
+(define (struct-field n dfg)
+ (indexed-field &struct n dfg))
+(define (read-struct-field n dfg)
+ (logior &read (struct-field n dfg)))
+(define (write-struct-field n dfg)
+ (logior &write (struct-field n dfg)))
+(define-primitive-effects* dfg
+ ((allocate-struct vt n) (&allocate &struct) &type-check)
+ ((allocate-struct/immediate v n) (&allocate &struct) &type-check)
+ ((make-struct vt ntail . _) (&allocate &struct) &type-check)
+ ((make-struct/no-tail vt . _) (&allocate &struct) &type-check)
+ ((struct-ref s n) (read-struct-field n dfg) &type-check)
+ ((struct-ref/immediate s n) (read-struct-field n dfg) &type-check)
+ ((struct-set! s n x) (write-struct-field n dfg) &type-check)
+ ((struct-set!/immediate s n x) (write-struct-field n dfg) &type-check)
+ ((struct-vtable s) &type-check))
+
+;; Strings.
+(define-primitive-effects
+ ((string-ref s n) (&read-object &string) &type-check)
+ ((string-set! s n c) (&write-object &string) &type-check)
+ ((number->string _) (&allocate &string) &type-check)
+ ((string->number _) (&read-object &string) &type-check)
+ ((string-length s) &type-check))
+
+;; Bytevectors.
+(define-primitive-effects
+ ((bytevector-length _) &type-check)
+
+ ((bv-u8-ref bv n) (&read-object &bytevector) &type-check)
+ ((bv-s8-ref bv n) (&read-object &bytevector) &type-check)
+ ((bv-u16-ref bv n) (&read-object &bytevector) &type-check)
+ ((bv-s16-ref bv n) (&read-object &bytevector) &type-check)
+ ((bv-u32-ref bv n) (&read-object &bytevector) &type-check)
+ ((bv-s32-ref bv n) (&read-object &bytevector) &type-check)
+ ((bv-u64-ref bv n) (&read-object &bytevector) &type-check)
+ ((bv-s64-ref bv n) (&read-object &bytevector) &type-check)
+ ((bv-f32-ref bv n) (&read-object &bytevector) &type-check)
+ ((bv-f64-ref bv n) (&read-object &bytevector) &type-check)
+
+ ((bv-u8-set! bv n x) (&write-object &bytevector) &type-check)
+ ((bv-s8-set! bv n x) (&write-object &bytevector) &type-check)
+ ((bv-u16-set! bv n x) (&write-object &bytevector) &type-check)
+ ((bv-s16-set! bv n x) (&write-object &bytevector) &type-check)
+ ((bv-u32-set! bv n x) (&write-object &bytevector) &type-check)
+ ((bv-s32-set! bv n x) (&write-object &bytevector) &type-check)
+ ((bv-u64-set! bv n x) (&write-object &bytevector) &type-check)
+ ((bv-s64-set! bv n x) (&write-object &bytevector) &type-check)
+ ((bv-f32-set! bv n x) (&write-object &bytevector) &type-check)
+ ((bv-f64-set! bv n x) (&write-object &bytevector) &type-check))
+
+;; Modules.
+(define-primitive-effects
+ ((current-module) (&read-object &module))
+ ((cache-current-module! m scope) (&write-object &box))
+ ((resolve name bound?) (&read-object &module) &type-check)
+ ((cached-toplevel-box scope name bound?) &type-check)
+ ((cached-module-box mod name public? bound?) &type-check)
+ ((define! name val) (&read-object &module) (&write-object &box)))
+
+;; Numbers.
+(define-primitive-effects
+ ((= . _) &type-check)
+ ((< . _) &type-check)
+ ((> . _) &type-check)
+ ((<= . _) &type-check)
+ ((>= . _) &type-check)
+ ((zero? . _) &type-check)
+ ((add . _) &type-check)
+ ((mul . _) &type-check)
+ ((sub . _) &type-check)
+ ((div . _) &type-check)
+ ((sub1 . _) &type-check)
+ ((add1 . _) &type-check)
+ ((quo . _) &type-check)
+ ((rem . _) &type-check)
+ ((mod . _) &type-check)
+ ((complex? _) &type-check)
+ ((real? _) &type-check)
+ ((rational? _) &type-check)
+ ((inf? _) &type-check)
+ ((nan? _) &type-check)
+ ((integer? _) &type-check)
+ ((exact? _) &type-check)
+ ((inexact? _) &type-check)
+ ((even? _) &type-check)
+ ((odd? _) &type-check)
+ ((ash n m) &type-check)
+ ((logand . _) &type-check)
+ ((logior . _) &type-check)
+ ((logxor . _) &type-check)
+ ((lognot . _) &type-check)
+ ((logtest a b) &type-check)
+ ((logbit? a b) &type-check)
+ ((sqrt _) &type-check)
+ ((abs _) &type-check))
+
+;; Characters.
+(define-primitive-effects
+ ((char<? . _) &type-check)
+ ((char<=? . _) &type-check)
+ ((char>=? . _) &type-check)
+ ((char>? . _) &type-check)
+ ((integer->char _) &type-check)
+ ((char->integer _) &type-check))
+
+(define (primitive-effects dfg name args)
+ (let ((proc (hashq-ref *primitive-effects* name)))
+ (if proc
+ (apply proc dfg args)
+ &all-effects)))
+
+(define (expression-effects exp dfg)
+ (match exp
+ ((or ($ $void) ($ $const) ($ $prim) ($ $values))
+ &no-effects)
+ (($ $fun)
+ (&allocate &unknown-memory-kinds))
+ (($ $prompt)
+ (&write-object &prompt))
+ ((or ($ $call) ($ $callk))
+ &all-effects)
+ (($ $branch k exp)
+ (expression-effects exp dfg))
+ (($ $primcall name args)
+ (primitive-effects dfg name args))))
+
+(define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg))
+ (label-count (dfg-label-count dfg)))
+ (let ((effects (make-vector label-count &no-effects)))
+ (define (idx->label idx) (+ idx min-label))
+ (let lp ((n 0))
+ (when (< n label-count)
+ (vector-set!
+ effects
+ n
+ (match (lookup-cont (idx->label n) dfg)
+ (($ $kargs names syms body)
+ (expression-effects (find-expression body) dfg))
+ (($ $kreceive arity kargs)
+ (match arity
+ (($ $arity _ () #f () #f) &type-check)
+ (($ $arity () () _ () #f) (&allocate &pair))
+ (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
+ (($ $kfun) &type-check)
+ (($ $kclause) &type-check)
+ (($ $ktail) &no-effects)))
+ (lp (1+ n))))
+ effects))
+
+;; There is a way to abuse effects analysis in CSE to also do scalar
+;; replacement, effectively adding `car' and `cdr' expressions to `cons'
+;; expressions, and likewise with other constructors and setters. This
+;; routine adds appropriate effects to `cons' and `set-car!' and the
+;; like.
+;;
+;; This doesn't affect CSE's ability to eliminate expressions, given
+;; that allocations aren't eliminated anyway, and the new effects will
+;; just cause the allocations not to commute with e.g. set-car! which
+;; is what we want anyway.
+(define* (synthesize-definition-effects! effects dfg min-label #:optional
+ (label-count (vector-length effects)))
+ (define (label->idx label) (- label min-label))
+ (let lp ((label min-label))
+ (when (< label (+ min-label label-count))
+ (let* ((lidx (label->idx label))
+ (fx (vector-ref effects lidx)))
+ (unless (zero? (logand (logior &write &allocation) fx))
+ (vector-set! effects lidx (logior (vector-ref effects lidx) &read)))
+ (lp (1+ label))))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; Primcalls that don't correspond to VM instructions are treated as if
+;;; they are calls, and indeed the later reify-primitives pass turns
+;;; them into calls. Because no return arity checking is done for these
+;;; primitives, if a later optimization pass simplifies the primcall to
+;;; a VM operation, the tail of the simplification has to be a
+;;; primcall to 'values. Most of these primcalls can be elided, and
+;;; that is the job of this pass.
+;;;
+;;; Code:
+
+(define-module (language cps elide-values)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:export (elide-values))
+
+(define (elide-values* fun conts)
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (($ $cont)
+ ,cont)))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts)
+ ,(visit-term body)))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body)))
+ (($ $continue k src ($ $primcall 'values vals))
+ ,(rewrite-cps-term (vector-ref conts k)
+ (($ $ktail)
+ ($continue k src ($values vals)))
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
+ ,(cond
+ ((and (not rest) (= (length vals) (length req)))
+ (build-cps-term
+ ($continue kargs src ($values vals))))
+ ((and rest (>= (length vals) (length req)))
+ (let-fresh (krest) (rest)
+ (let ((vals* (append (list-head vals (length req))
+ (list rest))))
+ (build-cps-term
+ ($letk ((krest ($kargs ('rest) (rest)
+ ($continue kargs src
+ ($values vals*)))))
+ ,(let lp ((tail (list-tail vals (length req)))
+ (k krest))
+ (match tail
+ (()
+ (build-cps-term ($continue k src
+ ($const '()))))
+ ((v . tail)
+ (let-fresh (krest) (rest)
+ (build-cps-term
+ ($letk ((krest ($kargs ('rest) (rest)
+ ($continue k src
+ ($primcall 'cons
+ (v rest))))))
+ ,(lp tail krest))))))))))))
+ (else term)))
+ (($ $kargs args)
+ ,(if (< (length vals) (length args))
+ term
+ (let ((vals (list-head vals (length args))))
+ (build-cps-term
+ ($continue k src ($values vals))))))))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue k src ,(visit-fun fun)))
+ (($ $continue)
+ ,term)))
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun free cont)
+ ($fun free ,(visit-cont cont)))))
+
+ (visit-cont fun))
+
+(define (elide-values fun)
+ (with-fresh-name-state fun
+ (let ((conts (build-cont-table fun)))
+ (elide-values* fun conts))))
--- /dev/null
+;;; Functional name maps
+;;; Copyright (C) 2014 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; Some CPS passes need to perform a flow analysis in which every
+;;; program point has an associated map over some set of labels or
+;;; variables. The naive way to implement this is with an array of
+;;; arrays, but this has N^2 complexity, and it really can hurt us.
+;;;
+;;; Instead, this module provides a functional map that can share space
+;;; between program points, reducing the amortized space complexity of
+;;; the representations down to O(n log n). Adding entries to the
+;;; mapping and lookup are O(log n). Intersection and union between
+;;; intmaps that share state are fast, too.
+;;;
+;;; Code:
+
+(define-module (language cps intmap)
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 match)
+ #:export (empty-intmap
+ intmap?
+ intmap-add
+ intmap-remove
+ intmap-ref
+ intmap-next
+ intmap-union
+ intmap-intersect))
+
+;; Persistent sparse intmaps.
+
+(define-syntax-rule (define-inline name val)
+ (define-syntax name (identifier-syntax val)))
+
+(define-inline *branch-bits* 4)
+(define-inline *branch-size* (ash 1 *branch-bits*))
+(define-inline *branch-mask* (1- *branch-size*))
+
+(define-record-type <intmap>
+ (make-intmap min shift root)
+ intmap?
+ (min intmap-min)
+ (shift intmap-shift)
+ (root intmap-root))
+
+(define (new-branch)
+ (make-vector *branch-size* #f))
+(define (clone-branch-and-set branch i elt)
+ (let ((new (new-branch)))
+ (when branch (vector-move-left! branch 0 *branch-size* new 0))
+ (vector-set! new i elt)
+ new))
+(define (branch-empty? branch)
+ (let lp ((i 0))
+ (or (= i *branch-size*)
+ (and (not (vector-ref branch i))
+ (lp (1+ i))))))
+
+(define (round-down min shift)
+ (logand min (lognot (1- (ash 1 shift)))))
+
+(define empty-intmap (make-intmap 0 0 #f))
+
+(define (add-level min shift root)
+ (let* ((shift* (+ shift *branch-bits*))
+ (min* (round-down min shift*))
+ (idx (logand (ash (- min min*) (- shift))
+ *branch-mask*)))
+ (make-intmap min* shift* (clone-branch-and-set #f idx root))))
+
+(define (make-intmap/prune min shift root)
+ (if (zero? shift)
+ (make-intmap min shift root)
+ (let lp ((i 0) (elt #f))
+ (cond
+ ((< i *branch-size*)
+ (if (vector-ref root i)
+ (if elt
+ (make-intmap min shift root)
+ (lp (1+ i) i))
+ (lp (1+ i) elt)))
+ (elt
+ (let ((shift (- shift *branch-bits*)))
+ (make-intmap/prune (+ min (ash elt shift))
+ shift
+ (vector-ref root elt))))
+ ;; Shouldn't be reached...
+ (else empty-intmap)))))
+
+(define (intmap-add bs i val meet)
+ (define (adjoin i shift root)
+ (cond
+ ((zero? shift)
+ (cond
+ ((eq? root val) root)
+ ((not root) val)
+ (else (meet root val))))
+ (else
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*))
+ (node (and root (vector-ref root idx)))
+ (new-node (adjoin i shift node)))
+ (if (eq? node new-node)
+ root
+ (clone-branch-and-set root idx new-node))))))
+ (match bs
+ (($ <intmap> min shift root)
+ (cond
+ ((< i 0)
+ ;; The power-of-two spanning trick doesn't work across 0.
+ (error "Intmaps can only map non-negative integers." i))
+ ((not val) (intmap-remove bs i))
+ ((not root)
+ ;; Add first element.
+ (make-intmap i 0 val))
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to map; level will not change.
+ (let ((old-root root)
+ (root (adjoin (- i min) shift root)))
+ (if (eq? root old-root)
+ bs
+ (make-intmap min shift root))))
+ ((< i min)
+ ;; Rebuild the tree by unioning two intmaps.
+ (intmap-union (intmap-add empty-intmap i val error) bs error))
+ (else
+ ;; Add a new level and try again.
+ (intmap-add (add-level min shift root) i val error))))))
+
+(define (intmap-remove bs i)
+ (define (remove i shift root)
+ (cond
+ ((zero? shift) #f)
+ (else
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (cond
+ ((vector-ref root idx)
+ => (lambda (node)
+ (let ((new-node (remove i shift node)))
+ (if (eq? node new-node)
+ root
+ (let ((root (clone-branch-and-set root idx new-node)))
+ (and (or new-node (not (branch-empty? root)))
+ root))))))
+ (else root))))))
+ (match bs
+ (($ <intmap> min shift root)
+ (cond
+ ((not root) bs)
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to map; level will not change.
+ (let ((old-root root)
+ (root (remove (- i min) shift root)))
+ (if (eq? root old-root)
+ bs
+ (make-intmap/prune min shift root))))
+ (else bs)))))
+
+(define (intmap-ref bs i)
+ (match bs
+ (($ <intmap> min shift root)
+ (and (<= min i) (< i (+ min (ash 1 shift)))
+ (let ((i (- i min)))
+ (let lp ((node root) (shift shift))
+ (and node
+ (if (= shift *branch-bits*)
+ (vector-ref node (logand i *branch-mask*))
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift))
+ *branch-mask*)))
+ (lp (vector-ref node idx) shift))))))))))
+
+(define (intmap-next bs i)
+ (define (visit-branch node shift i)
+ (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
+ (and (< idx *branch-size*)
+ (or (visit-node (vector-ref node idx) shift i)
+ (let ((inc (ash 1 shift)))
+ (lp (+ (round-down i shift) inc) (1+ idx)))))))
+ (define (visit-node node shift i)
+ (and node
+ (if (zero? shift)
+ i
+ (visit-branch node (- shift *branch-bits*) i))))
+ (match bs
+ (($ <intmap> min shift root)
+ (let ((i (if (and i (< min i))
+ (- i min)
+ 0)))
+ (and (< i (ash 1 shift))
+ (let ((i (visit-node root shift i)))
+ (and i (+ min i))))))))
+
+(define (intmap-union a b meet)
+ ;; Union A and B from index I; the result will be fresh.
+ (define (union-branches/fresh shift a b i fresh)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (vector-set! fresh i (union shift a-child b-child))
+ (lp (1+ i))))
+ (else fresh))))
+ ;; Union A and B from index I; the result may be eq? to A.
+ (define (union-branches/a shift a b i)
+ (let lp ((i i))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (union shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (lp (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (union-branches/fresh shift a b (1+ i) result))))))))
+ (else a))))
+ ;; Union A and B; the may could be eq? to either.
+ (define (union-branches shift a b)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (union shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (union-branches/a shift a b (1+ i)))
+ ((eq? b-child child)
+ (union-branches/a shift b a (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (union-branches/fresh shift a b (1+ i) result))))))))
+ ;; Seems they are the same but not eq?. Odd.
+ (else a))))
+ (define (union shift a-node b-node)
+ (cond
+ ((not a-node) b-node)
+ ((not b-node) a-node)
+ ((eq? a-node b-node) a-node)
+ ((zero? shift) (meet a-node b-node))
+ (else (union-branches (- shift *branch-bits*) a-node b-node))))
+ (match (cons a b)
+ ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))
+ (cond
+ ((not (= b-shift a-shift))
+ ;; Hoist the map with the lowest shift to meet the one with the
+ ;; higher shift.
+ (if (< b-shift a-shift)
+ (intmap-union a (add-level b-min b-shift b-root) meet)
+ (intmap-union (add-level a-min a-shift a-root) b meet)))
+ ((not (= b-min a-min))
+ ;; Nodes at the same shift but different minimums will cover
+ ;; disjoint ranges (due to the round-down call on min). Hoist
+ ;; both until they cover the same range.
+ (intmap-union (add-level a-min a-shift a-root)
+ (add-level b-min b-shift b-root)
+ meet))
+ (else
+ ;; At this point, A and B cover the same range.
+ (let ((root (union a-shift a-root b-root)))
+ (cond
+ ((eq? root a-root) a)
+ ((eq? root b-root) b)
+ (else (make-intmap a-min a-shift root)))))))))
+
+(define (intmap-intersect a b meet)
+ ;; Intersect A and B from index I; the result will be fresh.
+ (define (intersect-branches/fresh shift a b i fresh)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (vector-set! fresh i (intersect shift a-child b-child))
+ (lp (1+ i))))
+ ((branch-empty? fresh) #f)
+ (else fresh))))
+ ;; Intersect A and B from index I; the result may be eq? to A.
+ (define (intersect-branches/a shift a b i)
+ (let lp ((i i))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (intersect shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (lp (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (intersect-branches/fresh shift a b (1+ i) result))))))))
+ (else a))))
+ ;; Intersect A and B; the may could be eq? to either.
+ (define (intersect-branches shift a b)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (intersect shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (intersect-branches/a shift a b (1+ i)))
+ ((eq? b-child child)
+ (intersect-branches/a shift b a (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (intersect-branches/fresh shift a b (1+ i) result))))))))
+ ;; Seems they are the same but not eq?. Odd.
+ (else a))))
+ (define (intersect shift a-node b-node)
+ (cond
+ ((or (not a-node) (not b-node)) #f)
+ ((eq? a-node b-node) a-node)
+ ((zero? shift) (meet a-node b-node))
+ (else (intersect-branches (- shift *branch-bits*) a-node b-node))))
+
+ (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?)
+ (cond
+ ((<= lo-shift hi-shift)
+ ;; If LO has a lower shift and a lower min, it is disjoint. If
+ ;; it has the same shift and a different min, it is also
+ ;; disjoint.
+ empty-intmap)
+ (else
+ (let* ((lo-shift (- lo-shift *branch-bits*))
+ (lo-idx (ash (- hi-min lo-min) (- lo-shift))))
+ (cond
+ ((>= lo-idx *branch-size*)
+ ;; HI has a lower shift, but it not within LO.
+ empty-intmap)
+ ((vector-ref lo-root lo-idx)
+ => (lambda (lo-root)
+ (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift))
+ lo-shift
+ lo-root)))
+ (if lo-is-a?
+ (intmap-intersect lo hi meet)
+ (intmap-intersect hi lo meet)))))
+ (else empty-intmap))))))
+
+ (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?)
+ (cond
+ ((vector-ref hi-root 0)
+ => (lambda (hi-root)
+ (let ((hi (make-intmap min
+ (- hi-shift *branch-bits*)
+ hi-root)))
+ (if lo-is-a?
+ (intmap-intersect lo hi meet)
+ (intmap-intersect hi lo meet)))))
+ (else empty-intmap)))
+
+ (match (cons a b)
+ ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))
+ (cond
+ ((< a-min b-min)
+ (different-mins a-min a-shift a-root b-min b-shift b #t))
+ ((< b-min a-min)
+ (different-mins b-min b-shift b-root a-min a-shift a #f))
+ ((< a-shift b-shift)
+ (different-shifts-same-min b-min b-shift b-root a #t))
+ ((< b-shift a-shift)
+ (different-shifts-same-min a-min a-shift a-root b #f))
+ (else
+ ;; At this point, A and B cover the same range.
+ (let ((root (intersect a-shift a-root b-root)))
+ (cond
+ ((eq? root a-root) a)
+ ((eq? root b-root) b)
+ (else (make-intmap/prune a-min a-shift root)))))))))
--- /dev/null
+;;; Functional name maps
+;;; Copyright (C) 2014 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; A persistent, functional data structure representing a set of
+;;; integers as a tree whose branches are vectors and whose leaves are
+;;; fixnums. Intsets are careful to preserve sub-structure, in the
+;;; sense of eq?, whereever possible.
+;;;
+;;; Code:
+
+(define-module (language cps intset)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 match)
+ #:export (empty-intset
+ intset?
+ intset-add
+ intset-remove
+ intset-ref
+ intset-next
+ intset-union
+ intset-intersect
+ intset-subtract
+ bitvector->intset))
+
+(define-syntax-rule (define-inline name val)
+ (define-syntax name (identifier-syntax val)))
+
+(eval-when (expand)
+ (use-modules (system base target))
+ (define-syntax compile-time-cond
+ (lambda (x)
+ (syntax-case x (else)
+ ((_ (test body ...) rest ...)
+ (if (primitive-eval (syntax->datum #'test))
+ #'(begin body ...)
+ #'(begin (compile-time-cond rest ...))))
+ ((_ (else body ...))
+ #'(begin body ...))
+ ((_)
+ (error "no compile-time-cond expression matched"))))))
+
+(compile-time-cond
+ ((eqv? (target-word-size) 4)
+ (define-inline *leaf-bits* 4))
+ ((eqv? (target-word-size) 8)
+ (define-inline *leaf-bits* 5)))
+
+(define-inline *leaf-size* (ash 1 *leaf-bits*))
+(define-inline *leaf-mask* (1- *leaf-size*))
+(define-inline *branch-bits* 3)
+(define-inline *branch-size* (ash 1 *branch-bits*))
+(define-inline *branch-mask* (1- *branch-size*))
+
+(define-record-type <intset>
+ (make-intset min shift root)
+ intset?
+ (min intset-min)
+ (shift intset-shift)
+ (root intset-root))
+
+(define (new-leaf) 0)
+(define-inlinable (clone-leaf-and-set leaf i val)
+ (if val
+ (if leaf
+ (logior leaf (ash 1 i))
+ (ash 1 i))
+ (if leaf
+ (logand leaf (lognot (ash 1 i)))
+ #f)))
+(define (leaf-empty? leaf)
+ (zero? leaf))
+
+(define (new-branch)
+ (make-vector *branch-size* #f))
+(define (clone-branch-and-set branch i elt)
+ (let ((new (new-branch)))
+ (when branch (vector-move-left! branch 0 *branch-size* new 0))
+ (vector-set! new i elt)
+ new))
+(define (branch-empty? branch)
+ (let lp ((i 0))
+ (or (= i *branch-size*)
+ (and (not (vector-ref branch i))
+ (lp (1+ i))))))
+
+(define (round-down min shift)
+ (logand min (lognot (1- (ash 1 shift)))))
+
+(define empty-intset (make-intset 0 *leaf-bits* #f))
+
+(define (add-level min shift root)
+ (let* ((shift* (+ shift *branch-bits*))
+ (min* (round-down min shift*))
+ (idx (logand (ash (- min min*) (- shift)) *branch-mask*)))
+ (make-intset min* shift* (clone-branch-and-set #f idx root))))
+
+(define (make-intset/prune min shift root)
+ (cond
+ ((not root)
+ empty-intset)
+ ((= shift *leaf-bits*)
+ (make-intset min shift root))
+ (else
+ (let lp ((i 0) (elt #f))
+ (cond
+ ((< i *branch-size*)
+ (if (vector-ref root i)
+ (if elt
+ (make-intset min shift root)
+ (lp (1+ i) i))
+ (lp (1+ i) elt)))
+ (elt
+ (let ((shift (- shift *branch-bits*)))
+ (make-intset/prune (+ min (ash elt shift))
+ shift
+ (vector-ref root elt))))
+ ;; Shouldn't be reached...
+ (else empty-intset))))))
+
+(define (intset-add bs i)
+ (define (adjoin i shift root)
+ (cond
+ ((= shift *leaf-bits*)
+ (let ((idx (logand i *leaf-mask*)))
+ (if (and root (logbit? idx root))
+ root
+ (clone-leaf-and-set root idx #t))))
+ (else
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*))
+ (node (and root (vector-ref root idx)))
+ (new-node (adjoin i shift node)))
+ (if (eq? node new-node)
+ root
+ (clone-branch-and-set root idx new-node))))))
+ (match bs
+ (($ <intset> min shift root)
+ (cond
+ ((< i 0)
+ ;; The power-of-two spanning trick doesn't work across 0.
+ (error "Intsets can only hold non-negative integers." i))
+ ((not root)
+ ;; Add first element.
+ (let ((min (round-down i shift)))
+ (make-intset min *leaf-bits*
+ (adjoin (- i min) *leaf-bits* root))))
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to set; level will not change.
+ (let ((old-root root)
+ (root (adjoin (- i min) shift root)))
+ (if (eq? root old-root)
+ bs
+ (make-intset min shift root))))
+ ((< i min)
+ ;; Rebuild the tree by unioning two intsets.
+ (intset-union (intset-add empty-intset i) bs))
+ (else
+ ;; Add a new level and try again.
+ (intset-add (add-level min shift root) i))))))
+
+(define (intset-remove bs i)
+ (define (remove i shift root)
+ (cond
+ ((= shift *leaf-bits*)
+ (let ((idx (logand i *leaf-mask*)))
+ (if (logbit? idx root)
+ (let ((root (clone-leaf-and-set root idx #f)))
+ (and (not (leaf-empty? root)) root))
+ root)))
+ (else
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (cond
+ ((vector-ref root idx)
+ => (lambda (node)
+ (let ((new-node (remove i shift node)))
+ (if (eq? node new-node)
+ root
+ (let ((root (clone-branch-and-set root idx new-node)))
+ (and (or new-node (not (branch-empty? root)))
+ root))))))
+ (else root))))))
+ (match bs
+ (($ <intset> min shift root)
+ (cond
+ ((not root) bs)
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to set; level will not change.
+ (let ((old-root root)
+ (root (remove (- i min) shift root)))
+ (if (eq? root old-root)
+ bs
+ (make-intset/prune min shift root))))
+ (else bs)))))
+
+(define (intset-ref bs i)
+ (match bs
+ (($ <intset> min shift root)
+ (and (<= min i) (< i (+ min (ash 1 shift)))
+ (let ((i (- i min)))
+ (let lp ((node root) (shift shift))
+ (and node
+ (if (= shift *leaf-bits*)
+ (logbit? (logand i *leaf-mask*) node)
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (lp (vector-ref node idx) shift))))))))))
+
+(define (intset-next bs i)
+ (define (visit-leaf node i)
+ (let lp ((idx (logand i *leaf-mask*)))
+ (if (logbit? idx node)
+ (logior (logand i (lognot *leaf-mask*)) idx)
+ (let ((idx (1+ idx)))
+ (and (< idx *leaf-size*)
+ (lp idx))))))
+ (define (visit-branch node shift i)
+ (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
+ (and (< idx *branch-size*)
+ (or (visit-node (vector-ref node idx) shift i)
+ (let ((inc (ash 1 shift)))
+ (lp (+ (round-down i shift) inc) (1+ idx)))))))
+ (define (visit-node node shift i)
+ (and node
+ (if (= shift *leaf-bits*)
+ (visit-leaf node i)
+ (visit-branch node (- shift *branch-bits*) i))))
+ (match bs
+ (($ <intset> min shift root)
+ (let ((i (if (and i (< min i))
+ (- i min)
+ 0)))
+ (and (< i (ash 1 shift))
+ (let ((i (visit-node root shift i)))
+ (and i (+ min i))))))))
+
+(define (intset-size shift root)
+ (cond
+ ((not root) 0)
+ ((= *leaf-bits* shift) *leaf-size*)
+ (else
+ (let lp ((i (1- *branch-size*)))
+ (let ((node (vector-ref root i)))
+ (if node
+ (let ((shift (- shift *branch-bits*)))
+ (+ (intset-size shift node)
+ (* i (ash 1 shift))))
+ (lp (1- i))))))))
+
+(define (intset-union a b)
+ ;; Union leaves.
+ (define (union-leaves a b)
+ (logior (or a 0) (or b 0)))
+ ;; Union A and B from index I; the result will be fresh.
+ (define (union-branches/fresh shift a b i fresh)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (vector-set! fresh i (union shift a-child b-child))
+ (lp (1+ i))))
+ (else fresh))))
+ ;; Union A and B from index I; the result may be eq? to A.
+ (define (union-branches/a shift a b i)
+ (let lp ((i i))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (union shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (lp (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (union-branches/fresh shift a b (1+ i) result))))))))
+ (else a))))
+ ;; Union A and B; the may could be eq? to either.
+ (define (union-branches shift a b)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (union shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (union-branches/a shift a b (1+ i)))
+ ((eq? b-child child)
+ (union-branches/a shift b a (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (union-branches/fresh shift a b (1+ i) result))))))))
+ ;; Seems they are the same but not eq?. Odd.
+ (else a))))
+ (define (union shift a-node b-node)
+ (cond
+ ((not a-node) b-node)
+ ((not b-node) a-node)
+ ((eq? a-node b-node) a-node)
+ ((= shift *leaf-bits*) (union-leaves a-node b-node))
+ (else (union-branches (- shift *branch-bits*) a-node b-node))))
+ (match (cons a b)
+ ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
+ (cond
+ ((not (= b-shift a-shift))
+ ;; Hoist the set with the lowest shift to meet the one with the
+ ;; higher shift.
+ (if (< b-shift a-shift)
+ (intset-union a (add-level b-min b-shift b-root))
+ (intset-union (add-level a-min a-shift a-root) b)))
+ ((not (= b-min a-min))
+ ;; Nodes at the same shift but different minimums will cover
+ ;; disjoint ranges (due to the round-down call on min). Hoist
+ ;; both until they cover the same range.
+ (intset-union (add-level a-min a-shift a-root)
+ (add-level b-min b-shift b-root)))
+ (else
+ ;; At this point, A and B cover the same range.
+ (let ((root (union a-shift a-root b-root)))
+ (cond
+ ((eq? root a-root) a)
+ ((eq? root b-root) b)
+ (else (make-intset a-min a-shift root)))))))))
+
+(define (intset-intersect a b)
+ (define tmp (new-leaf))
+ ;; Intersect leaves.
+ (define (intersect-leaves a b)
+ (logand a b))
+ ;; Intersect A and B from index I; the result will be fresh.
+ (define (intersect-branches/fresh shift a b i fresh)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (vector-set! fresh i (intersect shift a-child b-child))
+ (lp (1+ i))))
+ ((branch-empty? fresh) #f)
+ (else fresh))))
+ ;; Intersect A and B from index I; the result may be eq? to A.
+ (define (intersect-branches/a shift a b i)
+ (let lp ((i i))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (intersect shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (lp (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (intersect-branches/fresh shift a b (1+ i) result))))))))
+ (else a))))
+ ;; Intersect A and B; the may could be eq? to either.
+ (define (intersect-branches shift a b)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (intersect shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (intersect-branches/a shift a b (1+ i)))
+ ((eq? b-child child)
+ (intersect-branches/a shift b a (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (intersect-branches/fresh shift a b (1+ i) result))))))))
+ ;; Seems they are the same but not eq?. Odd.
+ (else a))))
+ (define (intersect shift a-node b-node)
+ (cond
+ ((or (not a-node) (not b-node)) #f)
+ ((eq? a-node b-node) a-node)
+ ((= shift *leaf-bits*) (intersect-leaves a-node b-node))
+ (else (intersect-branches (- shift *branch-bits*) a-node b-node))))
+
+ (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?)
+ (cond
+ ((<= lo-shift hi-shift)
+ ;; If LO has a lower shift and a lower min, it is disjoint. If
+ ;; it has the same shift and a different min, it is also
+ ;; disjoint.
+ empty-intset)
+ (else
+ (let* ((lo-shift (- lo-shift *branch-bits*))
+ (lo-idx (ash (- hi-min lo-min) (- lo-shift))))
+ (cond
+ ((>= lo-idx *branch-size*)
+ ;; HI has a lower shift, but it not within LO.
+ empty-intset)
+ ((vector-ref lo-root lo-idx)
+ => (lambda (lo-root)
+ (let ((lo (make-intset (+ lo-min (ash lo-idx lo-shift))
+ lo-shift
+ lo-root)))
+ (if lo-is-a?
+ (intset-intersect lo hi)
+ (intset-intersect hi lo)))))
+ (else empty-intset))))))
+
+ (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?)
+ (cond
+ ((vector-ref hi-root 0)
+ => (lambda (hi-root)
+ (let ((hi (make-intset min
+ (- hi-shift *branch-bits*)
+ hi-root)))
+ (if lo-is-a?
+ (intset-intersect lo hi)
+ (intset-intersect hi lo)))))
+ (else empty-intset)))
+
+ (match (cons a b)
+ ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
+ (cond
+ ((< a-min b-min)
+ (different-mins a-min a-shift a-root b-min b-shift b #t))
+ ((< b-min a-min)
+ (different-mins b-min b-shift b-root a-min a-shift a #f))
+ ((< a-shift b-shift)
+ (different-shifts-same-min b-min b-shift b-root a #t))
+ ((< b-shift a-shift)
+ (different-shifts-same-min a-min a-shift a-root b #f))
+ (else
+ ;; At this point, A and B cover the same range.
+ (let ((root (intersect a-shift a-root b-root)))
+ (cond
+ ((eq? root a-root) a)
+ ((eq? root b-root) b)
+ (else (make-intset/prune a-min a-shift root)))))))))
+
+(define (intset-subtract a b)
+ (define tmp (new-leaf))
+ ;; Intersect leaves.
+ (define (subtract-leaves a b)
+ (logand a (lognot b)))
+ ;; Subtract B from A starting at index I; the result will be fresh.
+ (define (subtract-branches/fresh shift a b i fresh)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (vector-set! fresh i (subtract-nodes shift a-child b-child))
+ (lp (1+ i))))
+ ((branch-empty? fresh) #f)
+ (else fresh))))
+ ;; Subtract B from A. The result may be eq? to A.
+ (define (subtract-branches shift a b)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (let ((child (subtract-nodes shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (lp (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (subtract-branches/fresh shift a b (1+ i) result)))))))
+ (else a))))
+ (define (subtract-nodes shift a-node b-node)
+ (cond
+ ((or (not a-node) (not b-node)) a-node)
+ ((eq? a-node b-node) #f)
+ ((= shift *leaf-bits*) (subtract-leaves a-node b-node))
+ (else (subtract-branches (- shift *branch-bits*) a-node b-node))))
+
+ (match (cons a b)
+ ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
+ (define (return root)
+ (cond
+ ((eq? root a-root) a)
+ (else (make-intset/prune a-min a-shift root))))
+ (cond
+ ((<= a-shift b-shift)
+ (let lp ((b-min b-min) (b-shift b-shift) (b-root b-root))
+ (if (= a-shift b-shift)
+ (if (= a-min b-min)
+ (return (subtract-nodes a-shift a-root b-root))
+ a)
+ (let* ((b-shift (- b-shift *branch-bits*))
+ (b-idx (ash (- a-min b-min) (- b-shift)))
+ (b-min (+ b-min (ash b-idx b-shift)))
+ (b-root (and b-root
+ (<= 0 b-idx)
+ (< b-idx *branch-size*)
+ (vector-ref b-root b-idx))))
+ (lp b-min b-shift b-root)))))
+ (else
+ (return
+ (let lp ((a-min a-min) (a-shift a-shift) (a-root a-root))
+ (if (= a-shift b-shift)
+ (if (= a-min b-min)
+ (subtract-nodes a-shift a-root b-root)
+ a-root)
+ (let* ((a-shift (- a-shift *branch-bits*))
+ (a-idx (ash (- b-min a-min) (- a-shift)))
+ (a-min (+ a-min (ash a-idx a-shift)))
+ (old (and a-root
+ (<= 0 a-idx)
+ (< a-idx *branch-size*)
+ (vector-ref a-root a-idx)))
+ (new (lp a-min a-shift old)))
+ (if (eq? old new)
+ a-root
+ (clone-branch-and-set a-root a-idx new)))))))))))
+
+(define (bitvector->intset bv)
+ (define (finish-tail out min tail)
+ (if (zero? tail)
+ out
+ (intset-union out (make-intset min *leaf-bits* tail))))
+ (let lp ((out empty-intset) (min 0) (pos 0) (tail 0))
+ (let ((pos (bit-position #t bv pos)))
+ (cond
+ ((not pos)
+ (finish-tail out min tail))
+ ((< pos (+ min *leaf-size*))
+ (lp out min (1+ pos) (logior tail (ash 1 (- pos min)))))
+ (else
+ (let ((min* (round-down pos *leaf-bits*)))
+ (lp (finish-tail out min tail)
+ min* pos (ash 1 (- pos min*)))))))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 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
+
+;;; Commentary:
+;;;
+;;; Information about named primitives, as they appear in $prim and
+;;; $primcall.
+;;;
+;;; Code:
+
+(define-module (language cps primitives)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (srfi srfi-26)
+ #:use-module (language bytecode)
+ #:export (prim-instruction
+ branching-primitive?
+ prim-arity
+ ))
+
+(define *instruction-aliases*
+ '((+ . add) (1+ . add1)
+ (- . sub) (1- . sub1)
+ (* . mul) (/ . div)
+ (quotient . quo) (remainder . rem)
+ (modulo . mod)
+ (variable-ref . box-ref)
+ (variable-set! . box-set!)
+ (bytevector-u8-ref . bv-u8-ref)
+ (bytevector-u16-native-ref . bv-u16-ref)
+ (bytevector-u32-native-ref . bv-u32-ref)
+ (bytevector-u64-native-ref . bv-u64-ref)
+ (bytevector-s8-ref . bv-s8-ref)
+ (bytevector-s16-native-ref . bv-s16-ref)
+ (bytevector-s32-native-ref . bv-s32-ref)
+ (bytevector-s64-native-ref . bv-s64-ref)
+ (bytevector-ieee-single-native-ref . bv-f32-ref)
+ (bytevector-ieee-double-native-ref . bv-f64-ref)
+ (bytevector-u8-set! . bv-u8-set!)
+ (bytevector-u16-native-set! . bv-u16-set!)
+ (bytevector-u32-native-set! . bv-u32-set!)
+ (bytevector-u64-native-set! . bv-u64-set!)
+ (bytevector-s8-set! . bv-s8-set!)
+ (bytevector-s16-native-set! . bv-s16-set!)
+ (bytevector-s32-native-set! . bv-s32-set!)
+ (bytevector-s64-native-set! . bv-s64-set!)
+ (bytevector-ieee-single-native-set! . bv-f32-set!)
+ (bytevector-ieee-double-native-set! . bv-f64-set!)))
+
+(define *macro-instruction-arities*
+ '((cache-current-module! . (0 . 2))
+ (cached-toplevel-box . (1 . 3))
+ (cached-module-box . (1 . 4))))
+
+(define *branching-primcall-arities*
+ '((null? . (1 . 1))
+ (nil? . (1 . 1))
+ (pair? . (1 . 1))
+ (struct? . (1 . 1))
+ (string? . (1 . 1))
+ (vector? . (1 . 1))
+ (symbol? . (1 . 1))
+ (keyword? . (1 . 1))
+ (variable? . (1 . 1))
+ (bitvector? . (1 . 1))
+ (bytevector? . (1 . 1))
+ (char? . (1 . 1))
+ (eq? . (1 . 2))
+ (eqv? . (1 . 2))
+ (equal? . (1 . 2))
+ (= . (1 . 2))
+ (< . (1 . 2))
+ (> . (1 . 2))
+ (<= . (1 . 2))
+ (>= . (1 . 2))
+ (logtest . (1 . 2))))
+
+(define (compute-prim-instructions)
+ (let ((table (make-hash-table)))
+ (for-each
+ (match-lambda ((inst . _) (hashq-set! table inst inst)))
+ (instruction-list))
+ (for-each
+ (match-lambda ((prim . inst) (hashq-set! table prim inst)))
+ *instruction-aliases*)
+ (for-each
+ (match-lambda ((inst . arity) (hashq-set! table inst inst)))
+ *macro-instruction-arities*)
+ table))
+
+(define *prim-instructions* (delay (compute-prim-instructions)))
+
+;; prim -> instruction | #f
+(define (prim-instruction name)
+ (hashq-ref (force *prim-instructions*) name))
+
+(define (branching-primitive? name)
+ (and (assq name *branching-primcall-arities*) #t))
+
+(define *prim-arities* (make-hash-table))
+
+(define (prim-arity name)
+ (or (hashq-ref *prim-arities* name)
+ (let ((arity (cond
+ ((prim-instruction name) => instruction-arity)
+ ((assq name *branching-primcall-arities*) => cdr)
+ (else
+ (error "Primitive of unknown arity" name)))))
+ (hashq-set! *prim-arities* name arity)
+ arity)))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; A pass that prunes successors of expressions that bail out.
+;;;
+;;; Code:
+
+(define-module (language cps prune-bailouts)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:export (prune-bailouts))
+
+(define (module-box src module name public? bound? val-proc)
+ (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
+ (build-cps-term
+ ($letconst (('module module-sym module)
+ ('name name-sym name)
+ ('public? public?-sym public?)
+ ('bound? bound?-sym bound?))
+ ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
+ ($continue kbox src
+ ($primcall 'cached-module-box
+ (module-sym name-sym public?-sym bound?-sym))))))))
+
+(define (primitive-ref name k src)
+ (module-box #f '(guile) name #f #t
+ (lambda (box)
+ (build-cps-term
+ ($continue k src ($primcall 'box-ref (box)))))))
+
+(define (prune-bailouts* fun)
+ (define (visit-cont cont ktail)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kargs names vars body))
+ (label ($kargs names vars ,(visit-term body ktail))))
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail
+ ,(and clause (visit-cont clause ktail)))))
+ (($ $cont label ($ $kclause arity body alternate))
+ (label ($kclause ,arity ,(visit-cont body ktail)
+ ,(and alternate (visit-cont alternate ktail)))))
+ (_ ,cont)))
+
+ (define (visit-term term ktail)
+ (rewrite-cps-term term
+ (($ $letrec names vars funs body)
+ ($letrec names vars (map visit-fun funs)
+ ,(visit-term body ktail)))
+ (($ $letk conts body)
+ ($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
+ ,(visit-term body ktail)))
+ (($ $continue k src exp)
+ ,(visit-exp k src exp ktail))))
+
+ (define (visit-exp k src exp ktail)
+ (rewrite-cps-term exp
+ (($ $fun) ($continue k src ,(visit-fun exp)))
+ (($ $primcall (and name (or 'error 'scm-error 'throw)) args)
+ ,(if (eq? k ktail)
+ (build-cps-term ($continue k src ,exp))
+ (let-fresh (kprim kresult kreceive) (prim rest)
+ (build-cps-term
+ ($letk ((kresult ($kargs ('rest) (rest)
+ ($continue ktail src ($values ()))))
+ (kreceive ($kreceive '() 'rest kresult))
+ (kprim ($kargs ('prim) (prim)
+ ($continue kreceive src
+ ($call prim args)))))
+ ,(primitive-ref name kprim src))))))
+ (_ ($continue k src ,exp))))
+
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun free ,(prune-bailouts* body)))))
+
+ (rewrite-cps-cont fun
+ (($ $cont kfun
+ ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
+ (kfun ($kfun src meta self (ktail ($ktail))
+ ,(and clause (visit-cont clause ktail)))))))
+
+(define (prune-bailouts fun)
+ (with-fresh-name-state fun
+ (prune-bailouts* fun)))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2014 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
+
+;;; Commentary:
+;;;
+;;; A simple pass to prune unneeded top-level scopes.
+;;;
+;;; Code:
+
+(define-module (language cps prune-top-level-scopes)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:export (prune-top-level-scopes))
+
+(define (compute-referenced-scopes fun)
+ (let ((scope-name->used? (make-hash-table))
+ (scope-var->used? (make-hash-table))
+ (k->scope-var (make-hash-table)))
+ ;; Visit uses before defs. That way we know when visiting defs
+ ;; whether the scope is used or not.
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont k ($ $kargs (name) (var) body))
+ (visit-term body)
+ (when (hashq-get-handle scope-var->used? var)
+ (hashq-set! k->scope-var k var)))
+ (($ $cont k ($ $kargs names syms body))
+ (visit-term body))
+ (($ $cont k ($ $kfun src meta self tail clause))
+ (when clause (visit-cont clause)))
+ (($ $cont k ($ $kclause arity body alternate))
+ (visit-cont body)
+ (when alternate (visit-cont alternate)))
+ (($ $cont k ($ $kreceive))
+ #t)))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ (for-each visit-cont conts)
+ (visit-term body))
+ (($ $letrec names syms funs body)
+ (for-each visit-fun funs)
+ (visit-term body))
+ (($ $continue k src exp)
+ (match exp
+ (($ $fun) (visit-fun exp))
+ (($ $primcall 'cached-toplevel-box (scope name bound?))
+ (hashq-set! scope-var->used? scope #t))
+ (($ $primcall 'cache-current-module! (module scope))
+ (hashq-set! scope-var->used? scope #f))
+ (($ $const val)
+ ;; If there is an entry in the table for "k", it means "val"
+ ;; is a scope symbol, bound for use by cached-toplevel-box
+ ;; or cache-current-module!, or possibly both (though this
+ ;; is not currently the case).
+ (and=> (hashq-ref k->scope-var k)
+ (lambda (scope-var)
+ (when (hashq-ref scope-var->used? scope-var)
+ ;; We have a use via cached-toplevel-box. Mark
+ ;; this scope as used.
+ (hashq-set! scope-name->used? val #t))
+ (when (and (hashq-ref scope-name->used? val)
+ (not (hashq-ref scope-var->used? scope-var)))
+ ;; There is a use, and this sym is used by
+ ;; cache-current-module!.
+ (hashq-set! scope-var->used? scope-var #t)))))
+ (_ #t)))))
+ (define (visit-fun fun)
+ (match fun
+ (($ $fun free body)
+ (visit-cont body))))
+
+ (visit-cont fun)
+ scope-var->used?))
+
+(define (prune-top-level-scopes fun)
+ (let ((scope-var->used? (compute-referenced-scopes fun)))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (($ $cont sym ($ $kreceive))
+ ,cont)))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts) ,(visit-term body)))
+ (($ $letrec names syms funs body)
+ ($letrec names syms funs ,(visit-term body)))
+ (($ $continue k src
+ (and ($ $primcall 'cache-current-module! (module scope))
+ (? (lambda _
+ (not (hashq-ref scope-var->used? scope))))))
+ ($continue k src ($primcall 'values ())))
+ (($ $continue)
+ ,term)))
+ (visit-cont fun)))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; A pass to reify lone $prim's that were never folded into a
+;;; $primcall, and $primcall's to primitives that don't have a
+;;; corresponding VM op.
+;;;
+;;; Code:
+
+(define-module (language cps reify-primitives)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps primitives)
+ #:use-module (language bytecode)
+ #:export (reify-primitives))
+
+(define (module-box src module name public? bound? val-proc)
+ (let-fresh (kbox) (module-var name-var public?-var bound?-var box)
+ (build-cps-term
+ ($letconst (('module module-var module)
+ ('name name-var name)
+ ('public? public?-var public?)
+ ('bound? bound?-var bound?))
+ ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
+ ($continue kbox src
+ ($primcall 'cached-module-box
+ (module-var name-var public?-var bound?-var))))))))
+
+(define (primitive-module name)
+ (case name
+ ((bytevector-length
+
+ bytevector-u8-ref bytevector-u8-set!
+ bytevector-s8-ref bytevector-s8-set!
+
+ bytevector-u16-ref bytevector-u16-set!
+ bytevector-u16-native-ref bytevector-u16-native-set!
+ bytevector-s16-ref bytevector-s16-set!
+ bytevector-s16-native-ref bytevector-s16-native-set!
+
+ bytevector-u32-ref bytevector-u32-set!
+ bytevector-u32-native-ref bytevector-u32-native-set!
+ bytevector-s32-ref bytevector-s32-set!
+ bytevector-s32-native-ref bytevector-s32-native-set!
+
+ bytevector-u64-ref bytevector-u64-set!
+ bytevector-u64-native-ref bytevector-u64-native-set!
+ bytevector-s64-ref bytevector-s64-set!
+ bytevector-s64-native-ref bytevector-s64-native-set!
+
+ bytevector-ieee-single-ref bytevector-ieee-single-set!
+ bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
+ bytevector-ieee-double-ref bytevector-ieee-double-set!
+ bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!)
+ '(rnrs bytevectors))
+ ((class-of) '(oop goops))
+ (else '(guile))))
+
+(define (primitive-ref name k src)
+ (module-box #f (primitive-module name) name #f #t
+ (lambda (box)
+ (build-cps-term
+ ($continue k src ($primcall 'box-ref (box)))))))
+
+(define (builtin-ref idx k src)
+ (let-fresh () (idx-var)
+ (build-cps-term
+ ($letconst (('idx idx-var idx))
+ ($continue k src
+ ($primcall 'builtin-ref (idx-var)))))))
+
+(define (reify-clause ktail)
+ (let-fresh (kclause kbody kthrow) (wna false str eol throw)
+ (build-cps-cont
+ (kclause ($kclause ('() '() #f '() #f)
+ (kbody
+ ($kargs () ()
+ ($letconst (('wna wna 'wrong-number-of-args)
+ ('false false #f)
+ ('str str "Wrong number of arguments")
+ ('eol eol '()))
+ ($letk ((kthrow
+ ($kargs ('throw) (throw)
+ ($continue ktail #f
+ ($call throw
+ (wna false str eol false))))))
+ ,(primitive-ref 'throw kthrow #f)))))
+ ,#f)))))
+
+(define (reify-primitives/1 fun single-value-conts)
+ (define (visit-clause cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kclause arity body alternate))
+ (label ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-clause alternate)))))))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kargs (name) (var) body))
+ ,(begin
+ (bitvector-set! single-value-conts label #t)
+ (build-cps-cont
+ (label ($kargs (name) (var) ,(visit-term body))))))
+ (($ $cont label ($ $kargs names vars body))
+ (label ($kargs names vars ,(visit-term body))))
+ (($ $cont)
+ ,cont)))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ ;; Visit continuations before their uses.
+ (let ((conts (map visit-cont conts)))
+ (build-cps-term
+ ($letk ,conts ,(visit-term body)))))
+ (($ $continue k src exp)
+ (match exp
+ (($ $prim name)
+ (if (bitvector-ref single-value-conts k)
+ (cond
+ ((builtin-name->index name)
+ => (lambda (idx)
+ (builtin-ref idx k src)))
+ (else (primitive-ref name k src)))
+ (build-cps-term ($continue k src ($void)))))
+ (($ $primcall 'call-thunk/no-inline (proc))
+ (build-cps-term
+ ($continue k src ($call proc ()))))
+ (($ $primcall name args)
+ (cond
+ ((or (prim-instruction name) (branching-primitive? name))
+ ;; Assume arities are correct.
+ term)
+ (else
+ (let-fresh (k*) (v)
+ (build-cps-term
+ ($letk ((k* ($kargs (v) (v)
+ ($continue k src ($call v args)))))
+ ,(cond
+ ((builtin-name->index name)
+ => (lambda (idx)
+ (builtin-ref idx k* src)))
+ (else (primitive-ref name k* src)))))))))
+ (_ term)))))
+
+ (rewrite-cps-cont fun
+ (($ $cont label ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
+ ;; A case-lambda with no clauses. Reify a clause.
+ (label ($kfun src meta self ,tail ,(reify-clause ktail))))
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail ,(visit-clause clause))))))
+
+(define (reify-primitives term)
+ (with-fresh-name-state term
+ (let ((single-value-conts (make-bitvector (label-counter) #f)))
+ (rewrite-cps-term term
+ (($ $program procs)
+ ($program ,(map (lambda (cont)
+ (reify-primitives/1 cont single-value-conts))
+ procs)))))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2014 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
+
+;;; Commentary:
+;;;
+;;; A pass to renumber variables and continuation labels so that they
+;;; are contiguous within each function and, in the case of labels,
+;;; topologically sorted.
+;;;
+;;; Code:
+
+(define-module (language cps renumber)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (language cps)
+ #:export (renumber))
+
+;; Topologically sort the continuation tree starting at k0, using
+;; reverse post-order numbering.
+(define (sort-conts k0 conts new-k0 path-lengths)
+ (let ((next -1))
+ (let visit ((k k0))
+ (define (maybe-visit k)
+ (let ((entry (vector-ref conts k)))
+ ;; Visit the successor if it has not been
+ ;; visited yet.
+ (when (and entry (not (exact-integer? entry)))
+ (visit k))))
+
+ (let ((cont (vector-ref conts k)))
+ ;; Clear the cont table entry to mark this continuation as
+ ;; visited.
+ (vector-set! conts k #f)
+
+ (match cont
+ (($ $kargs names syms body)
+ (let lp ((body body))
+ (match body
+ (($ $letk conts body) (lp body))
+ (($ $letrec names syms funs body) (lp body))
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt escape? tag handler)
+ (maybe-visit handler)
+ (maybe-visit k))
+ (($ $branch kt)
+ ;; Visit the successor with the shortest path length
+ ;; to the tail first, so that if the branches are
+ ;; unsorted, the longer path length will appear
+ ;; first. This will move a loop exit out of a loop.
+ (let ((k-len (vector-ref path-lengths k))
+ (kt-len (vector-ref path-lengths kt)))
+ (cond
+ ((if kt-len
+ (or (not k-len)
+ (< k-len kt-len)
+ ;; If the path lengths are the
+ ;; same, preserve original order
+ ;; to avoid squirreliness.
+ (and (= k-len kt-len) (< kt k)))
+ (if k-len #f (< kt k)))
+ (maybe-visit k)
+ (maybe-visit kt))
+ (else
+ (maybe-visit kt)
+ (maybe-visit k)))))
+ (_
+ (maybe-visit k)))))))
+ (($ $kreceive arity k) (maybe-visit k))
+ (($ $kclause arity ($ $cont kbody) alt)
+ (match alt
+ (($ $cont kalt) (maybe-visit kalt))
+ (_ #f))
+ (maybe-visit kbody))
+ (($ $kfun src meta self tail clause)
+ (match clause
+ (($ $cont kclause) (maybe-visit kclause))
+ (_ #f)))
+ (_ #f))
+
+ ;; Chain this label to the label that will follow it in the sort
+ ;; order, and record this label as the new head of the order.
+ (vector-set! conts k next)
+ (set! next k)))
+
+ ;; Finally traverse the label chain, giving each label its final
+ ;; name.
+ (let lp ((n new-k0) (head next))
+ (if (< head 0)
+ n
+ (let ((next (vector-ref conts head)))
+ (vector-set! conts head n)
+ (lp (1+ n) next))))))
+
+(define (compute-tail-path-lengths preds ktail path-lengths)
+ (let visit ((k ktail) (length-in 0))
+ (let ((length (vector-ref path-lengths k)))
+ (unless (and length (<= length length-in))
+ (vector-set! path-lengths k length-in)
+ (let lp ((preds (vector-ref preds k)))
+ (match preds
+ (() #t)
+ ((pred . preds)
+ (visit pred (1+ length-in))
+ (lp preds))))))))
+
+(define (compute-new-labels-and-vars fun)
+ (call-with-values (lambda () (compute-max-label-and-var fun))
+ (lambda (max-label max-var)
+ (let ((labels (make-vector (1+ max-label) #f))
+ (next-label 0)
+ (vars (make-vector (1+ max-var) #f))
+ (next-var 0)
+ (preds (make-vector (1+ max-label) '()))
+ (path-lengths (make-vector (1+ max-label) #f)))
+ (define (add-predecessor! pred succ)
+ (vector-set! preds succ (cons pred (vector-ref preds succ))))
+ (define (rename! var)
+ (vector-set! vars var next-var)
+ (set! next-var (1+ next-var)))
+
+ (define (collect-conts fun)
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont label cont)
+ (vector-set! labels label cont)
+ (match cont
+ (($ $kargs names vars body)
+ (visit-term body label))
+ (($ $kfun src meta self tail clause)
+ (visit-cont tail)
+ (match clause
+ (($ $cont kclause)
+ (add-predecessor! label kclause)
+ (visit-cont clause))
+ (#f #f)))
+ (($ $kclause arity (and body ($ $cont kbody)) alternate)
+ (add-predecessor! label kbody)
+ (visit-cont body)
+ (match alternate
+ (($ $cont kalt)
+ (add-predecessor! label kalt)
+ (visit-cont alternate))
+ (#f #f)))
+ (($ $kreceive arity kargs)
+ (add-predecessor! label kargs))
+ (($ $ktail) #f)))))
+ (define (visit-term term label)
+ (match term
+ (($ $letk conts body)
+ (let lp ((conts conts))
+ (unless (null? conts)
+ (visit-cont (car conts))
+ (lp (cdr conts))))
+ (visit-term body label))
+ (($ $letrec names syms funs body)
+ (visit-term body label))
+ (($ $continue k src exp)
+ (add-predecessor! label k)
+ (match exp
+ (($ $branch kt)
+ (add-predecessor! label kt))
+ (($ $prompt escape? tag handler)
+ (add-predecessor! label handler))
+ (_ #f)))))
+ (visit-cont fun))
+
+ (define (compute-names-in-fun fun)
+ (define queue '())
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont label cont)
+ (let ((reachable? (exact-integer? (vector-ref labels label))))
+ ;; This cont is reachable if it was given a number.
+ ;; Otherwise the cont table entry still contains the
+ ;; cont itself; clear it out to indicate that the cont
+ ;; should not be residualized.
+ (unless reachable?
+ (vector-set! labels label #f))
+ (match cont
+ (($ $kargs names vars body)
+ (when reachable?
+ (for-each rename! vars))
+ (visit-term body reachable?))
+ (($ $kfun src meta self tail clause)
+ (unless reachable? (error "entry should be reachable"))
+ (rename! self)
+ (visit-cont tail)
+ (when clause
+ (visit-cont clause)))
+ (($ $kclause arity body alternate)
+ (unless reachable? (error "clause should be reachable"))
+ (visit-cont body)
+ (when alternate
+ (visit-cont alternate)))
+ (($ $ktail)
+ (unless reachable?
+ ;; It's possible for the tail to be unreachable,
+ ;; if all paths contify to infinite loops. Make
+ ;; sure we mark as reachable.
+ (vector-set! labels label next-label)
+ (set! next-label (1+ next-label))))
+ (($ $kreceive)
+ #f))))))
+ (define (visit-term term reachable?)
+ (match term
+ (($ $letk conts body)
+ (for-each visit-cont conts)
+ (visit-term body reachable?))
+ (($ $letrec names syms funs body)
+ (when reachable?
+ (for-each rename! syms)
+ (set! queue (fold (lambda (fun queue)
+ (match fun
+ (($ $fun free body)
+ (cons body queue))))
+ queue
+ funs)))
+ (visit-term body reachable?))
+ (($ $continue k src ($ $fun free body))
+ (when reachable?
+ (set! queue (cons body queue))))
+ (($ $continue) #f)))
+
+ (match fun
+ (($ $cont kfun ($ $kfun src meta self ($ $cont ktail)))
+ (collect-conts fun)
+ (compute-tail-path-lengths preds ktail path-lengths)
+ (set! next-label (sort-conts kfun labels next-label path-lengths))
+ (visit-cont fun)
+ (for-each compute-names-in-fun (reverse queue)))
+ (($ $program conts)
+ (for-each compute-names-in-fun conts))))
+
+ (compute-names-in-fun fun)
+ (values labels vars next-label next-var)))))
+
+(define (apply-renumbering term labels vars)
+ (define (relabel label) (vector-ref labels label))
+ (define (rename var) (vector-ref vars var))
+ (define (rename-kw-arity arity)
+ (match arity
+ (($ $arity req opt rest kw aok?)
+ (make-$arity req opt rest
+ (map (match-lambda
+ ((kw kw-name kw-var)
+ (list kw kw-name (rename kw-var))))
+ kw)
+ aok?))))
+ (define (must-visit-cont cont)
+ (or (visit-cont cont)
+ (error "internal error -- failed to visit cont")))
+ (define (visit-conts conts)
+ (match conts
+ (() '())
+ ((cont . conts)
+ (cond
+ ((visit-cont cont)
+ => (lambda (cont)
+ (cons cont (visit-conts conts))))
+ (else (visit-conts conts))))))
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont label cont)
+ (let ((label (relabel label)))
+ (and
+ label
+ (rewrite-cps-cont cont
+ (($ $kargs names vars body)
+ (label ($kargs names (map rename vars) ,(visit-term body))))
+ (($ $kfun src meta self tail clause)
+ (label
+ ($kfun src meta (rename self) ,(must-visit-cont tail)
+ ,(and clause (must-visit-cont clause)))))
+ (($ $ktail)
+ (label ($ktail)))
+ (($ $kclause arity body alternate)
+ (label
+ ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
+ ,(and alternate (must-visit-cont alternate)))))
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
+ (label ($kreceive req rest (relabel kargs))))))))))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ,(match (visit-conts conts)
+ (() (visit-term body))
+ (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
+ (($ $letrec names vars funs body)
+ ($letrec names (map rename vars) (map visit-fun funs)
+ ,(visit-term body)))
+ (($ $continue k src exp)
+ ($continue (relabel k) src ,(visit-exp exp)))))
+ (define (visit-exp exp)
+ (match exp
+ ((or ($ $void) ($ $const) ($ $prim))
+ exp)
+ (($ $closure k nfree)
+ (build-cps-exp ($closure (relabel k) nfree)))
+ (($ $fun)
+ (visit-fun exp))
+ (($ $values args)
+ (let ((args (map rename args)))
+ (build-cps-exp ($values args))))
+ (($ $call proc args)
+ (let ((args (map rename args)))
+ (build-cps-exp ($call (rename proc) args))))
+ (($ $callk k proc args)
+ (let ((args (map rename args)))
+ (build-cps-exp ($callk (relabel k) (rename proc) args))))
+ (($ $branch kt exp)
+ (build-cps-exp ($branch (relabel kt) ,(visit-exp exp))))
+ (($ $primcall name args)
+ (let ((args (map rename args)))
+ (build-cps-exp ($primcall name args))))
+ (($ $prompt escape? tag handler)
+ (build-cps-exp
+ ($prompt escape? (rename tag) (relabel handler))))))
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun (map rename free) ,(must-visit-cont body)))))
+
+ (match term
+ (($ $cont)
+ (must-visit-cont term))
+ (($ $program conts)
+ (build-cps-term
+ ($program ,(map must-visit-cont conts))))))
+
+(define (renumber term)
+ (call-with-values (lambda () (compute-new-labels-and-vars term))
+ (lambda (labels vars nlabels nvars)
+ (values (apply-renumbering term labels vars) nlabels nvars))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; A pass that prunes successors of expressions that bail out.
+;;;
+;;; Code:
+
+(define-module (language cps self-references)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:export (resolve-self-references))
+
+(define* (resolve-self-references fun #:optional (env '()))
+ (define (subst var)
+ (or (assq-ref env var) var))
+
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kargs names vars body))
+ (label ($kargs names vars ,(visit-term body))))
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail
+ ,(and clause (visit-cont clause)))))
+ (($ $cont label ($ $kclause arity body alternate))
+ (label ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (_ ,cont)))
+
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letrec names vars funs body)
+ ($letrec names vars (map visit-recursive-fun funs vars)
+ ,(visit-term body)))
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts)
+ ,(visit-term body)))
+ (($ $continue k src exp)
+ ($continue k src ,(visit-exp exp)))))
+
+ (define (visit-exp exp)
+ (rewrite-cps-exp exp
+ ((or ($ $void) ($ $const) ($ $prim)) ,exp)
+ (($ $fun free body)
+ ($fun free ,(resolve-self-references body env)))
+ (($ $call proc args)
+ ($call (subst proc) ,(map subst args)))
+ (($ $callk k proc args)
+ ($callk k (subst proc) ,(map subst args)))
+ (($ $primcall name args)
+ ($primcall name ,(map subst args)))
+ (($ $branch k exp)
+ ($branch k ,(visit-exp exp)))
+ (($ $values args)
+ ($values ,(map subst args)))
+ (($ $prompt escape? tag handler)
+ ($prompt escape? (subst tag) handler))))
+
+ (define (visit-recursive-fun fun var)
+ (rewrite-cps-exp fun
+ (($ $fun free (and cont ($ $cont _ ($ $kfun src meta self))))
+ ($fun free ,(resolve-self-references cont (acons var self env))))))
+
+ (visit-cont fun))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; The fundamental lambda calculus reductions, like beta and eta
+;;; reduction and so on. Pretty lame currently.
+;;;
+;;; Code:
+
+(define-module (language cps simplify)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps renumber)
+ #:export (simplify))
+
+(define (compute-eta-reductions fun)
+ (let ((table (make-hash-table)))
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont sym ($ $kargs names syms body))
+ (visit-term body sym syms))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (when clause (visit-cont clause)))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (visit-cont body)
+ (when alternate (visit-cont alternate)))
+ (($ $cont sym _) #f)))
+ (define (visit-term term term-k term-args)
+ (match term
+ (($ $letk conts body)
+ (for-each visit-cont conts)
+ (visit-term body term-k term-args))
+ (($ $letrec names syms funs body)
+ (for-each visit-fun funs)
+ (visit-term body term-k term-args))
+ (($ $continue k src ($ $values args))
+ (when (and (equal? term-args args) (not (eq? k term-k)))
+ (hashq-set! table term-k k)))
+ (($ $continue k src (and fun ($ $fun)))
+ (visit-fun fun))
+ (($ $continue k src _)
+ #f)))
+ (define (visit-fun fun)
+ (match fun
+ (($ $fun free body)
+ (visit-cont body))))
+ (visit-cont fun)
+ table))
+
+(define (eta-reduce fun)
+ (let ((table (compute-eta-reductions fun))
+ (dfg (compute-dfg fun)))
+ (define (reduce* k scope values?)
+ (match (hashq-ref table k)
+ (#f k)
+ (k*
+ (if (and (continuation-bound-in? k* scope dfg)
+ (or values?
+ (match (lookup-cont k* dfg)
+ (($ $kargs) #t)
+ (_ #f))))
+ (reduce* k* scope values?)
+ k))))
+ (define (reduce k scope)
+ (reduce* k scope #f))
+ (define (reduce-values k scope)
+ (reduce* k scope #t))
+ (define (reduce-const k src scope const)
+ (let lp ((k k) (seen '()) (const const))
+ (match (lookup-cont k dfg)
+ (($ $kargs (_) (arg) term)
+ (match (find-call term)
+ (($ $continue k* src* ($ $values (arg*)))
+ (and (eqv? arg arg*)
+ (not (memq k* seen))
+ (lp k* (cons k seen) const)))
+ (($ $continue k* src* ($ $primcall 'not (arg*)))
+ (and (eqv? arg arg*)
+ (not (memq k* seen))
+ (lp k* (cons k seen) (not const))))
+ (($ $continue k* src* ($ $branch kt ($ $values (arg*))))
+ (and (eqv? arg arg*)
+ (let ((k* (if const kt k*)))
+ (and (continuation-bound-in? k* scope dfg)
+ (build-cps-term
+ ($continue k* src ($values ())))))))
+ (_
+ (and (continuation-bound-in? k scope dfg)
+ (build-cps-term
+ ($continue k src ($const const)))))))
+ (_ #f))))
+ (define (visit-cont cont scope)
+ (rewrite-cps-cont cont
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body sym))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail
+ ,(and clause (visit-cont clause sym)))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body sym)
+ ,(and alternate (visit-cont alternate sym)))))
+ (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
+ (sym ($kreceive req rest (reduce kargs scope))))))
+ (define (visit-term term scope)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map (cut visit-cont <> scope) conts)
+ ,(visit-term body scope)))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body scope)))
+ (($ $continue k src ($ $values args))
+ ($continue (reduce-values k scope) src ($values args)))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue (reduce k scope) src ,(visit-fun fun)))
+ (($ $continue k src ($ $const const))
+ ,(let ((k (reduce k scope)))
+ (or (reduce-const k src scope const)
+ (build-cps-term ($continue k src ($const const))))))
+ (($ $continue k src exp)
+ ($continue (reduce k scope) src ,exp))))
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun free ,(visit-cont body #f)))))
+ (visit-cont fun #f)))
+
+(define (compute-beta-reductions fun)
+ ;; A continuation's body can be inlined in place of a $values
+ ;; expression if the continuation is a $kargs. It should only be
+ ;; inlined if it is used only once, and not recursively.
+ (let ((var-table (make-hash-table))
+ (k-table (make-hash-table))
+ (dfg (compute-dfg fun)))
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont sym ($ $kargs names syms body))
+ (visit-term body))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (when clause (visit-cont clause)))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (visit-cont body)
+ (when alternate (visit-cont alternate)))
+ (($ $cont sym (or ($ $ktail) ($ $kreceive)))
+ #f)))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ (for-each visit-cont conts)
+ (visit-term body))
+ (($ $letrec names syms funs body)
+ (for-each visit-fun funs)
+ (visit-term body))
+ (($ $continue k src ($ $values args))
+ (match (lookup-cont k dfg)
+ (($ $kargs names syms body)
+ (match (lookup-predecessors k dfg)
+ ((_)
+ ;; There is only one use, and it is this use. We assume
+ ;; it's not recursive, as there would to be some other
+ ;; use for control flow to reach this loop. Store the k
+ ;; -> body mapping in the table. Also store the
+ ;; substitutions for the variables bound by the inlined
+ ;; continuation.
+ (for-each (cut hashq-set! var-table <> <>) syms args)
+ (hashq-set! k-table k body))
+ (_ #f)))
+ (_ #f)))
+ (($ $continue k src (and fun ($ $fun)))
+ (visit-fun fun))
+ (($ $continue k src _)
+ #f)))
+ (define (visit-fun fun)
+ (match fun
+ (($ $fun free body)
+ (visit-cont body))))
+ (visit-cont fun)
+ (values var-table k-table)))
+
+(define (beta-reduce fun)
+ (let-values (((var-table k-table) (compute-beta-reductions fun)))
+ (define (subst var)
+ (cond ((hashq-ref var-table var) => subst)
+ (else var)))
+ (define (must-visit-cont cont)
+ (or (visit-cont cont)
+ (error "continuation must not be inlined" cont)))
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont sym cont)
+ (and (not (hashq-ref k-table sym))
+ (rewrite-cps-cont cont
+ (($ $kargs names syms body)
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $kfun src meta self tail clause)
+ (sym ($kfun src meta self ,tail
+ ,(and clause (must-visit-cont clause)))))
+ (($ $kclause arity body alternate)
+ (sym ($kclause ,arity ,(must-visit-cont body)
+ ,(and alternate (must-visit-cont alternate)))))
+ (($ $kreceive)
+ (sym ,cont)))))))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ (match (filter-map visit-cont conts)
+ (() (visit-term body))
+ (conts (build-cps-term
+ ($letk ,conts ,(visit-term body))))))
+ (($ $letrec names syms funs body)
+ (build-cps-term
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body))))
+ (($ $continue k src exp)
+ (cond
+ ((hashq-ref k-table k) => visit-term)
+ (else
+ (build-cps-term ($continue k src ,(visit-exp exp))))))))
+ (define (visit-exp exp)
+ (match exp
+ ((or ($ $void) ($ $const) ($ $prim)) exp)
+ (($ $fun) (visit-fun exp))
+ (($ $call proc args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($call (subst proc) args))))
+ (($ $callk k proc args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($callk k (subst proc) args))))
+ (($ $primcall name args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($primcall name args))))
+ (($ $values args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($values args))))
+ (($ $branch kt exp)
+ (build-cps-exp ($branch kt ,(visit-exp exp))))
+ (($ $prompt escape? tag handler)
+ (build-cps-exp ($prompt escape? (subst tag) handler)))))
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun (map subst free) ,(must-visit-cont body)))))
+ (must-visit-cont fun)))
+
+;; Rewrite the scope tree to reflect the dominator tree. Precondition:
+;; the fun has been renumbered, its min-label is 0, and its labels are
+;; packed.
+(define (redominate fun)
+ (let* ((dfg (compute-dfg fun))
+ (idoms (compute-idoms dfg 0 (dfg-label-count dfg)))
+ (doms (compute-dom-edges idoms 0)))
+ (define (visit-fun-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail
+ ,(and clause (visit-fun-cont clause)))))
+ (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
+ (label ($kclause ,arity ,(visit-cont kbody body)
+ ,(and alternate (visit-fun-cont alternate)))))))
+
+ (define (visit-cont label cont)
+ (rewrite-cps-cont cont
+ (($ $kargs names vars body)
+ (label ($kargs names vars ,(visit-term body label))))
+ (_ (label ,cont))))
+
+ (define (visit-exp k src exp)
+ (rewrite-cps-term exp
+ (($ $fun free body)
+ ($continue k src ($fun free ,(visit-fun-cont body))))
+ (_
+ ($continue k src ,exp))))
+
+ (define (visit-term term label)
+ (define (visit-dom-conts label)
+ (let ((cont (lookup-cont label dfg)))
+ (match cont
+ (($ $ktail) '())
+ (($ $kargs) (list (visit-cont label cont)))
+ (else
+ (cons (visit-cont label cont)
+ (visit-dom-conts* (vector-ref doms label)))))))
+
+ (define (visit-dom-conts* labels)
+ (match labels
+ (() '())
+ ((label . labels)
+ (append (visit-dom-conts label)
+ (visit-dom-conts* labels)))))
+
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ,(visit-term body label))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (let lp ((funs funs))
+ (match funs
+ (() '())
+ ((($ $fun free body) . funs)
+ (cons (build-cps-exp
+ ($fun free ,(visit-fun-cont body)))
+ (lp funs)))))
+ ,(visit-term body label)))
+ (($ $continue k src exp)
+ ,(let ((conts (visit-dom-conts* (vector-ref doms label))))
+ (if (null? conts)
+ (visit-exp k src exp)
+ (build-cps-term
+ ($letk ,conts ,(visit-exp k src exp))))))))
+
+ (visit-fun-cont fun)))
+
+(define (simplify fun)
+ ;; Renumbering prunes continuations that are made unreachable by
+ ;; eta/beta reductions.
+ (redominate (renumber (eta-reduce (beta-reduce fun)))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; A module to assign stack slots to variables in a CPS term.
+;;;
+;;; Code:
+
+(define-module (language cps slot-allocation)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps intset)
+ #:export (allocate-slots
+ lookup-slot
+ lookup-maybe-slot
+ lookup-constant-value
+ lookup-maybe-constant-value
+ lookup-nlocals
+ lookup-call-proc-slot
+ lookup-parallel-moves
+ lookup-dead-slot-map))
+
+(define-record-type $allocation
+ (make-allocation dfa slots
+ has-constv constant-values
+ call-allocations
+ nlocals)
+ allocation?
+
+ ;; A DFA records all variables bound in a function, and assigns them
+ ;; indices. The slot in which a variable is stored at runtime can be
+ ;; had by indexing into the SLOTS vector with the variable's index.
+ ;;
+ (dfa allocation-dfa)
+ (slots allocation-slots)
+
+ ;; Not all variables have slots allocated. Variables that are
+ ;; constant and that are only used by primcalls that can accept
+ ;; constants directly are not allocated to slots, and their SLOT value
+ ;; is false. Likewise constants that are only used by calls are not
+ ;; allocated into slots, to avoid needless copying. If a variable is
+ ;; constant, its constant value is set in the CONSTANT-VALUES vector
+ ;; and the corresponding bit in the HAS-CONSTV bitvector is set.
+ ;;
+ (has-constv allocation-has-constv)
+ (constant-values allocation-constant-values)
+
+ ;; Some continuations have additional associated information. This
+ ;; addition information is a /call allocation/. Call allocations
+ ;; record the way that functions are passed values, and how their
+ ;; return values are rebound to local variables.
+ ;;
+ ;; A call allocation contains three pieces of information: the call's
+ ;; /proc slot/, a set of /parallel moves/, and a /dead slot map/. The
+ ;; proc slot indicates the slot of a procedure in a procedure call, or
+ ;; where the procedure would be in a multiple-value return. The
+ ;; parallel moves shuffle locals into position for a call, or shuffle
+ ;; returned values back into place. Though they use the same slot,
+ ;; moves for a call are called "call moves", and moves to handle a
+ ;; return are "return moves". The dead slot map indicates, for a
+ ;; call, what slots should be ignored by GC when marking the frame.
+ ;;
+ ;; $kreceive continuations record a proc slot and a set of return moves
+ ;; to adapt multiple values from the stack to local variables.
+ ;;
+ ;; Tail calls record arg moves, but no proc slot.
+ ;;
+ ;; Non-tail calls record arg moves, a call slot, and a dead slot map.
+ ;; Multiple-valued returns will have an associated $kreceive
+ ;; continuation, which records the same proc slot, but has return
+ ;; moves and no dead slot map.
+ ;;
+ ;; $prompt handlers are $kreceive continuations like any other.
+ ;;
+ ;; $values expressions with more than 1 value record moves but have no
+ ;; proc slot or dead slot map.
+ ;;
+ ;; A set of moves is expressed as an ordered list of (SRC . DST)
+ ;; moves, where SRC and DST are slots. This may involve a temporary
+ ;; variable. A dead slot map is a bitfield, as an integer.
+ ;;
+ (call-allocations allocation-call-allocations)
+
+ ;; The number of locals for a $kclause.
+ ;;
+ (nlocals allocation-nlocals))
+
+(define-record-type $call-allocation
+ (make-call-allocation proc-slot moves dead-slot-map)
+ call-allocation?
+ (proc-slot call-allocation-proc-slot)
+ (moves call-allocation-moves)
+ (dead-slot-map call-allocation-dead-slot-map))
+
+(define (find-first-zero n)
+ ;; Naive implementation.
+ (let lp ((slot 0))
+ (if (logbit? slot n)
+ (lp (1+ slot))
+ slot)))
+
+(define (find-first-trailing-zero n)
+ (let lp ((slot (let lp ((count 2))
+ (if (< n (ash 1 (1- count)))
+ count
+ ;; Grow upper bound slower than factor 2 to avoid
+ ;; needless bignum allocation on 32-bit systems
+ ;; when there are more than 16 locals.
+ (lp (+ count (ash count -1)))))))
+ (if (or (zero? slot) (logbit? (1- slot) n))
+ slot
+ (lp (1- slot)))))
+
+(define (lookup-maybe-slot sym allocation)
+ (match allocation
+ (($ $allocation dfa slots)
+ (vector-ref slots (dfa-var-idx dfa sym)))))
+
+(define (lookup-slot sym allocation)
+ (or (lookup-maybe-slot sym allocation)
+ (error "Variable not allocated to a slot" sym)))
+
+(define (lookup-constant-value sym allocation)
+ (match allocation
+ (($ $allocation dfa slots has-constv constant-values)
+ (let ((idx (dfa-var-idx dfa sym)))
+ (if (bitvector-ref has-constv idx)
+ (vector-ref constant-values idx)
+ (error "Variable does not have constant value" sym))))))
+
+(define (lookup-maybe-constant-value sym allocation)
+ (match allocation
+ (($ $allocation dfa slots has-constv constant-values)
+ (let ((idx (dfa-var-idx dfa sym)))
+ (values (bitvector-ref has-constv idx)
+ (vector-ref constant-values idx))))))
+
+(define (lookup-call-allocation k allocation)
+ (or (hashq-ref (allocation-call-allocations allocation) k)
+ (error "Continuation not a call" k)))
+
+(define (lookup-call-proc-slot k allocation)
+ (or (call-allocation-proc-slot (lookup-call-allocation k allocation))
+ (error "Call has no proc slot" k)))
+
+(define (lookup-parallel-moves k allocation)
+ (or (call-allocation-moves (lookup-call-allocation k allocation))
+ (error "Call has no use parallel moves slot" k)))
+
+(define (lookup-dead-slot-map k allocation)
+ (or (call-allocation-dead-slot-map (lookup-call-allocation k allocation))
+ (error "Call has no dead slot map" k)))
+
+(define (lookup-nlocals k allocation)
+ (or (hashq-ref (allocation-nlocals allocation) k)
+ (error "Not a clause continuation" k)))
+
+(define (solve-parallel-move src dst tmp)
+ "Solve the parallel move problem between src and dst slot lists, which
+are comparable with eqv?. A tmp slot may be used."
+
+ ;; This algorithm is taken from: "Tilting at windmills with Coq:
+ ;; formal verification of a compilation algorithm for parallel moves"
+ ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
+ ;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
+
+ (define (split-move moves reg)
+ (let loop ((revhead '()) (tail moves))
+ (match tail
+ (((and s+d (s . d)) . rest)
+ (if (eqv? s reg)
+ (cons d (append-reverse revhead rest))
+ (loop (cons s+d revhead) rest)))
+ (_ #f))))
+
+ (define (replace-last-source reg moves)
+ (match moves
+ ((moves ... (s . d))
+ (append moves (list (cons reg d))))))
+
+ (let loop ((to-move (map cons src dst))
+ (being-moved '())
+ (moved '())
+ (last-source #f))
+ ;; 'last-source' should always be equivalent to:
+ ;; (and (pair? being-moved) (car (last being-moved)))
+ (match being-moved
+ (() (match to-move
+ (() (reverse moved))
+ (((and s+d (s . d)) . t1)
+ (if (or (eqv? s d) ; idempotent
+ (not s)) ; src is a constant and can be loaded directly
+ (loop t1 '() moved #f)
+ (loop t1 (list s+d) moved s)))))
+ (((and s+d (s . d)) . b)
+ (match (split-move to-move d)
+ ((r . t1) (loop t1 (acons d r being-moved) moved last-source))
+ (#f (match b
+ (() (loop to-move '() (cons s+d moved) #f))
+ (_ (if (eqv? d last-source)
+ (loop to-move
+ (replace-last-source tmp b)
+ (cons s+d (acons d tmp moved))
+ tmp)
+ (loop to-move b (cons s+d moved) last-source))))))))))
+
+(define (dead-after-def? k-idx v-idx dfa)
+ (not (intset-ref (dfa-k-in dfa k-idx) v-idx)))
+
+(define (dead-after-use? k-idx v-idx dfa)
+ (not (intset-ref (dfa-k-out dfa k-idx) v-idx)))
+
+(define (allocate-slots fun dfg)
+ (let* ((dfa (compute-live-variables fun dfg))
+ (min-label (dfg-min-label dfg))
+ (label-count (dfg-label-count dfg))
+ (usev (make-vector label-count '()))
+ (defv (make-vector label-count '()))
+ (slots (make-vector (dfa-var-count dfa) #f))
+ (constant-values (make-vector (dfa-var-count dfa) #f))
+ (has-constv (make-bitvector (dfa-var-count dfa) #f))
+ (has-slotv (make-bitvector (dfa-var-count dfa) #t))
+ (needs-slotv (make-bitvector (dfa-var-count dfa) #t))
+ (needs-hintv (make-bitvector (dfa-var-count dfa) #f))
+ (call-allocations (make-hash-table))
+ (nlocals 0) ; Mutable. It pains me.
+ (nlocals-table (make-hash-table)))
+
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+
+ (define (bump-nlocals! nlocals*)
+ (when (< nlocals nlocals*)
+ (set! nlocals nlocals*)))
+
+ (define (empty-live-slots)
+ #b0)
+
+ (define (add-live-slot slot live-slots)
+ (logior live-slots (ash 1 slot)))
+
+ (define (kill-dead-slot slot live-slots)
+ (logand live-slots (lognot (ash 1 slot))))
+
+ (define (compute-slot live-slots hint)
+ ;; Slots 253-255 are reserved for shuffling; see comments in
+ ;; assembler.scm.
+ (if (and hint (not (logbit? hint live-slots))
+ (or (< hint 253) (> hint 255)))
+ hint
+ (let ((slot (find-first-zero live-slots)))
+ (if (or (< slot 253) (> slot 255))
+ slot
+ (+ 256 (find-first-zero (ash live-slots -256)))))))
+
+ (define (compute-call-proc-slot live-slots)
+ (+ 2 (find-first-trailing-zero live-slots)))
+
+ (define (compute-prompt-handler-proc-slot live-slots)
+ (if (zero? live-slots)
+ 0
+ (1- (find-first-trailing-zero live-slots))))
+
+ (define (recompute-live-slots k nargs)
+ (let ((in (dfa-k-in dfa (label->idx k))))
+ (let lp ((v 0) (live-slots 0))
+ (let ((v (intset-next in v)))
+ (if v
+ (let ((slot (vector-ref slots v)))
+ (lp (1+ v)
+ (if slot
+ (add-live-slot slot live-slots)
+ live-slots)))
+ live-slots)))))
+
+ (define* (allocate! var-idx hint live)
+ (cond
+ ((not (bitvector-ref needs-slotv var-idx)) live)
+ ((vector-ref slots var-idx) => (cut add-live-slot <> live))
+ ((and (not hint) (bitvector-ref needs-hintv var-idx)) live)
+ (else
+ (let ((slot (compute-slot live hint)))
+ (bump-nlocals! (1+ slot))
+ (vector-set! slots var-idx slot)
+ (add-live-slot slot live)))))
+
+ ;; Although some parallel moves may proceed without a temporary
+ ;; slot, in general one is needed. That temporary slot must not be
+ ;; part of the source or destination sets, and that slot should not
+ ;; correspond to a live variable. Usually the source and
+ ;; destination sets are a subset of the union of the live sets
+ ;; before and after the move. However for stack slots that don't
+ ;; have names -- those slots that correspond to function arguments
+ ;; or to function return values -- it could be that they are out of
+ ;; the computed live set. In that case they need to be adjoined to
+ ;; the live set, used when choosing a temporary slot.
+ ;;
+ ;; Note that although we reserve slots 253-255 for shuffling
+ ;; operands that address less than the full 24-bit range of locals,
+ ;; that reservation doesn't apply here, because this temporary
+ ;; itself is used while doing parallel assignment via "mov", and
+ ;; "mov" does not need shuffling.
+ (define (compute-tmp-slot live stack-slots)
+ (find-first-zero (fold add-live-slot live stack-slots)))
+
+ (define (parallel-move src-slots dst-slots tmp-slot)
+ (let ((moves (solve-parallel-move src-slots dst-slots tmp-slot)))
+ (when (assv tmp-slot moves)
+ (bump-nlocals! (1+ tmp-slot)))
+ moves))
+
+ ;; Find variables that are actually constant, and determine which
+ ;; of those can avoid slot allocation.
+ (define (compute-constants!)
+ (let lp ((n 0))
+ (when (< n (vector-length constant-values))
+ (let ((sym (dfa-var-sym dfa n)))
+ (call-with-values (lambda () (find-constant-value sym dfg))
+ (lambda (has-const? const)
+ (when has-const?
+ (bitvector-set! has-constv n has-const?)
+ (vector-set! constant-values n const)
+ (when (not (constant-needs-allocation? sym const dfg))
+ (bitvector-set! needs-slotv n #f)))
+ (lp (1+ n))))))))
+
+ ;; Record uses and defs, as lists of variable indexes, indexed by
+ ;; label index.
+ (define (compute-uses-and-defs!)
+ (let lp ((n 0))
+ (when (< n (vector-length usev))
+ (match (lookup-cont (idx->label n) dfg)
+ (($ $kfun src meta self)
+ (vector-set! defv n (list (dfa-var-idx dfa self))))
+ (($ $kargs names syms body)
+ (vector-set! defv n (map (cut dfa-var-idx dfa <>) syms))
+ (vector-set! usev n
+ (map (cut dfa-var-idx dfa <>)
+ (match (find-expression body)
+ (($ $call proc args)
+ (cons proc args))
+ (($ $callk k proc args)
+ (cons proc args))
+ (($ $primcall name args)
+ args)
+ (($ $branch kt ($ $primcall name args))
+ args)
+ (($ $branch kt ($ $values args))
+ args)
+ (($ $values args)
+ args)
+ (($ $prompt escape? tag handler)
+ (list tag))
+ (_ '())))))
+ (_ #f))
+ (lp (1+ n)))))
+
+ ;; Results of function calls that are not used don't need to be
+ ;; allocated to slots.
+ (define (compute-unused-results!)
+ (define (kreceive-get-kargs kreceive)
+ (match (lookup-cont kreceive dfg)
+ (($ $kreceive arity kargs) kargs)
+ (_ #f)))
+ (let ((candidates (make-bitvector label-count #f)))
+ ;; Find all $kargs that are the successors of $kreceive nodes.
+ (let lp ((n 0))
+ (when (< n label-count)
+ (and=> (kreceive-get-kargs (idx->label n))
+ (lambda (kargs)
+ (bitvector-set! candidates (label->idx kargs) #t)))
+ (lp (1+ n))))
+ ;; For $kargs that only have $kreceive predecessors, remove unused
+ ;; variables from the needs-slotv set.
+ (let lp ((n 0))
+ (let ((n (bit-position #t candidates n)))
+ (when n
+ (match (lookup-predecessors (idx->label n) dfg)
+ ;; At least one kreceive is in the predecessor set, so we
+ ;; only need to do the check for nodes with >1
+ ;; predecessor.
+ ((or (_) ((? kreceive-get-kargs) ...))
+ (for-each (lambda (var)
+ (when (dead-after-def? n var dfa)
+ (bitvector-set! needs-slotv var #f)))
+ (vector-ref defv n)))
+ (_ #f))
+ (lp (1+ n)))))))
+
+ ;; Compute the set of variables whose allocation should be delayed
+ ;; until a "hint" is known about where to allocate them. This is
+ ;; the case for some procedure arguments.
+ ;;
+ ;; This algorithm used is a conservative approximation of what
+ ;; really should happen, which would be eager allocation of call
+ ;; frames as soon as it's known that a call will happen. It would
+ ;; be nice to recast this as a proper data-flow problem.
+ (define (compute-needs-hint!)
+ (define (live-before n)
+ (dfa-k-in dfa n))
+ (define (live-after n)
+ (dfa-k-out dfa n))
+ (define needs-slot
+ (bitvector->intset needs-slotv))
+
+ ;; Walk backwards. At a call, compute the set of variables that
+ ;; have allocated slots and are live before but not after. This
+ ;; set contains candidates for needs-hintv.
+ (define (scan-for-call n)
+ (when (<= 0 n)
+ (match (lookup-cont (idx->label n) dfg)
+ (($ $kargs names syms body)
+ (match (find-expression body)
+ ((or ($ $call) ($ $callk))
+ (let* ((args (intset-subtract (live-before n) (live-after n)))
+ (args-needing-slots (intset-intersect args needs-slot)))
+ (if (intset-next args-needing-slots #f)
+ (scan-for-hints (1- n) args-needing-slots)
+ (scan-for-call (1- n)))))
+ (_ (scan-for-call (1- n)))))
+ (_ (scan-for-call (1- n))))))
+
+ ;; Walk backwards in the current basic block. Stop when the block
+ ;; ends, we reach a call, or when an expression kills a value.
+ (define (scan-for-hints n args)
+ (when (< 0 n)
+ (match (lookup-cont (idx->label n) dfg)
+ (($ $kargs names syms body)
+ (match (lookup-predecessors (idx->label (1+ n)) dfg)
+ (((? (cut eqv? <> (idx->label n))))
+ ;; If we are indeed in the same basic block, then if we
+ ;; are finished with the scan, we kill uses of the
+ ;; terminator, but leave its definitions.
+ (match (find-expression body)
+ ((or ($ $void) ($ $const) ($ $prim) ($ $closure)
+ ($ $primcall) ($ $prompt)
+ ;; If $values has more than one argument, it may
+ ;; use a temporary, which would invalidate our
+ ;; assumptions that slots not allocated are not
+ ;; used.
+ ($ $values (or () (_))))
+ (let ((killed (intset-subtract (live-before n) (live-after n))))
+ (if (intset-next (intset-intersect killed needs-slot) #f)
+ (finish-hints n (live-before n) args)
+ (scan-for-hints (1- n) args))))
+ ((or ($ $call) ($ $callk) ($ $values) ($ $branch))
+ (finish-hints n (live-before n) args))))
+ ;; Otherwise we kill uses of the block entry.
+ (_ (finish-hints n (live-before (1+ n)) args))))
+ (_ (finish-hints n (live-before (1+ n)) args)))))
+
+ ;; Add definitions ARGS minus KILL to NEED-HINTS, and go back to
+ ;; looking for calls.
+ (define (finish-hints n kill args)
+ (let ((new-hints (intset-subtract args kill)))
+ (let lp ((n 0))
+ (let ((n (intset-next new-hints n)))
+ (when n
+ (bitvector-set! needs-hintv n #t)
+ (lp (1+ n))))))
+ (scan-for-call n))
+
+ (scan-for-call (1- label-count)))
+
+ (define (allocate-call label k uses pre-live post-live)
+ (match (lookup-cont k dfg)
+ (($ $ktail)
+ (let* ((tail-nlocals (length uses))
+ (tail-slots (iota tail-nlocals))
+ (pre-live (fold allocate! pre-live uses tail-slots))
+ (moves (parallel-move (map (cut vector-ref slots <>) uses)
+ tail-slots
+ (compute-tmp-slot pre-live tail-slots))))
+ (bump-nlocals! tail-nlocals)
+ (hashq-set! call-allocations label
+ (make-call-allocation #f moves #f))))
+ (($ $kreceive arity kargs)
+ (let* ((proc-slot (compute-call-proc-slot post-live))
+ (call-slots (map (cut + proc-slot <>) (iota (length uses))))
+ (pre-live (fold allocate! pre-live uses call-slots))
+ (arg-moves (parallel-move (map (cut vector-ref slots <>) uses)
+ call-slots
+ (compute-tmp-slot pre-live
+ call-slots)))
+ (result-vars (vector-ref defv (label->idx kargs)))
+ (value-slots (map (cut + proc-slot 1 <>)
+ (iota (length result-vars))))
+ ;; Shuffle the first result down to the lowest slot, and
+ ;; leave any remaining results where they are. This
+ ;; strikes a balance between avoiding shuffling,
+ ;; especially for unused extra values, and avoiding
+ ;; frame size growth due to sparse locals.
+ (result-live (match (cons result-vars value-slots)
+ ((() . ()) post-live)
+ (((var . vars) . (slot . slots))
+ (fold allocate!
+ (allocate! var #f post-live)
+ vars slots))))
+ (result-slots (map (cut vector-ref slots <>) result-vars))
+ ;; Filter out unused results.
+ (value-slots (filter-map (lambda (val result) (and result val))
+ value-slots result-slots))
+ (result-slots (filter (lambda (x) x) result-slots))
+ (result-moves (parallel-move value-slots
+ result-slots
+ (compute-tmp-slot result-live
+ value-slots)))
+ (dead-slot-map (logand (1- (ash 1 (- proc-slot 2)))
+ (lognot post-live))))
+ (bump-nlocals! (+ proc-slot (length uses)))
+ (hashq-set! call-allocations label
+ (make-call-allocation proc-slot arg-moves dead-slot-map))
+ (hashq-set! call-allocations k
+ (make-call-allocation proc-slot result-moves #f))))
+
+ (_
+ (let* ((proc-slot (compute-call-proc-slot post-live))
+ (call-slots (map (cut + proc-slot <>) (iota (length uses))))
+ (pre-live (fold allocate! pre-live uses call-slots))
+ (arg-moves (parallel-move (map (cut vector-ref slots <>) uses)
+ call-slots
+ (compute-tmp-slot pre-live
+ call-slots))))
+ (bump-nlocals! (+ proc-slot (length uses)))
+ (hashq-set! call-allocations label
+ (make-call-allocation proc-slot arg-moves #f))))))
+
+ (define (allocate-values label k uses pre-live post-live)
+ (match (lookup-cont k dfg)
+ (($ $ktail)
+ (let* ((src-slots (map (cut vector-ref slots <>) uses))
+ (tail-nlocals (1+ (length uses)))
+ (dst-slots (cdr (iota tail-nlocals)))
+ (moves (parallel-move src-slots dst-slots
+ (compute-tmp-slot pre-live dst-slots))))
+ (bump-nlocals! tail-nlocals)
+ (hashq-set! call-allocations label
+ (make-call-allocation #f moves #f))))
+ (($ $kargs (_) (_))
+ ;; When there is only one value in play, we allow the dst to be
+ ;; hinted (see scan-for-hints). If the src doesn't have a
+ ;; slot, then the actual slot for the dst would end up being
+ ;; decided by the call that uses it. Because we don't know the
+ ;; slot, we can't really compute the parallel moves in that
+ ;; case, so just bail and rely on the bytecode emitter to
+ ;; handle the one-value case specially.
+ (match (cons uses (vector-ref defv (label->idx k)))
+ (((src) . (dst))
+ (allocate! dst (vector-ref slots src) post-live))))
+ (($ $kargs)
+ (let* ((src-slots (map (cut vector-ref slots <>) uses))
+ (dst-vars (vector-ref defv (label->idx k)))
+ (result-live (fold allocate! post-live dst-vars src-slots))
+ (dst-slots (map (cut vector-ref slots <>) dst-vars))
+ (moves (parallel-move src-slots dst-slots
+ (compute-tmp-slot (logior pre-live result-live)
+ '()))))
+ (hashq-set! call-allocations label
+ (make-call-allocation #f moves #f))))))
+
+ (define (allocate-prompt label k handler nargs)
+ (match (lookup-cont handler dfg)
+ (($ $kreceive arity kargs)
+ (let* ((handler-live (recompute-live-slots handler nargs))
+ (proc-slot (compute-prompt-handler-proc-slot handler-live))
+ (result-vars (vector-ref defv (label->idx kargs)))
+ (value-slots (map (cut + proc-slot 1 <>)
+ (iota (length result-vars))))
+ (result-live (fold allocate!
+ handler-live result-vars value-slots))
+ (result-slots (map (cut vector-ref slots <>) result-vars))
+ ;; Filter out unused results.
+ (value-slots (filter-map (lambda (val result) (and result val))
+ value-slots result-slots))
+ (result-slots (filter (lambda (x) x) result-slots))
+ (moves (parallel-move value-slots
+ result-slots
+ (compute-tmp-slot result-live
+ value-slots))))
+ (bump-nlocals! (+ proc-slot 1 (length result-vars)))
+ (hashq-set! call-allocations handler
+ (make-call-allocation proc-slot moves #f))))))
+
+ (define (allocate-defs! n live)
+ (fold (cut allocate! <> #f <>) live (vector-ref defv n)))
+
+ ;; This traversal will visit definitions before uses, as
+ ;; definitions dominate uses and a block's dominator will appear
+ ;; before it, in reverse post-order.
+ (define (visit-clause n nargs live)
+ (let lp ((n n) (live (recompute-live-slots (idx->label n) nargs)))
+ (define (kill-dead live vars-by-label-idx pred)
+ (fold (lambda (v live)
+ (let ((slot (vector-ref slots v)))
+ (if (and slot (pred n v dfa))
+ (kill-dead-slot slot live)
+ live)))
+ live
+ (vector-ref vars-by-label-idx n)))
+ (define (kill-dead-defs live)
+ (kill-dead live defv dead-after-def?))
+ (define (kill-dead-uses live)
+ (kill-dead live usev dead-after-use?))
+ (if (= n label-count)
+ n
+ (let* ((label (idx->label n))
+ (live (if (control-point? label dfg)
+ (recompute-live-slots label nargs)
+ live))
+ (live (kill-dead-defs (allocate-defs! n live)))
+ (post-live (kill-dead-uses live)))
+ ;; LIVE are the live slots coming into the term.
+ ;; POST-LIVE is the subset that is still live after the
+ ;; term uses its inputs.
+ (match (lookup-cont (idx->label n) dfg)
+ (($ $kclause) n)
+ (($ $kargs names syms body)
+ (define (compute-k-live k)
+ (match (lookup-predecessors k dfg)
+ ((_) post-live)
+ (_ (recompute-live-slots k nargs))))
+ (let ((uses (vector-ref usev n)))
+ (match (find-call body)
+ (($ $continue k src (or ($ $call) ($ $callk)))
+ (allocate-call label k uses live (compute-k-live k)))
+ (($ $continue k src ($ $primcall)) #t)
+ (($ $continue k src ($ $values))
+ (allocate-values label k uses live (compute-k-live k)))
+ (($ $continue k src ($ $prompt escape? tag handler))
+ (allocate-prompt label k handler nargs))
+ (_ #f)))
+ (lp (1+ n) post-live))
+ ((or ($ $kreceive) ($ $ktail))
+ (lp (1+ n) post-live)))))))
+
+ (define (visit-entry)
+ (define (visit-clauses n live)
+ (unless (eqv? live (add-live-slot 0 (empty-live-slots)))
+ (error "Unexpected clause live set"))
+ (set! nlocals 1)
+ (match (lookup-cont (idx->label n) dfg)
+ (($ $kclause arity ($ $cont kbody ($ $kargs names)) alternate)
+ (unless (eq? (idx->label (1+ n)) kbody)
+ (error "Unexpected label order"))
+ (let* ((nargs (length names))
+ (next (visit-clause (1+ n)
+ nargs
+ (fold allocate! live
+ (vector-ref defv (1+ n))
+ (cdr (iota (1+ nargs)))))))
+ (hashq-set! nlocals-table (idx->label n) nlocals)
+ (when (< next label-count)
+ (match alternate
+ (($ $cont kalt)
+ (unless (eq? kalt (idx->label next))
+ (error "Unexpected clause order"))))
+ (visit-clauses next live))))))
+ (match (lookup-cont (idx->label 0) dfg)
+ (($ $kfun src meta self)
+ (visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
+
+ (compute-constants!)
+ (compute-uses-and-defs!)
+ (compute-unused-results!)
+ (compute-needs-hint!)
+ (visit-entry)
+
+ (make-allocation dfa slots
+ has-constv constant-values
+ call-allocations
+ nlocals-table)))
-;;; Guile Virtual Machine Assembly
+;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013 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 (language assembly spec)
+(define-module (language cps spec)
#:use-module (system base language)
- #:use-module (language assembly compile-bytecode)
- #:use-module (language assembly decompile-bytecode)
- #:export (assembly))
+ #:use-module (language cps)
+ #:use-module (language cps compile-bytecode)
+ #:export (cps))
-(define-language assembly
- #:title "Guile Virtual Machine Assembly Language"
+(define* (write-cps exp #:optional (port (current-output-port)))
+ (write (unparse-cps exp) port))
+
+(define-language cps
+ #:title "CPS Intermediate Language"
#:reader (lambda (port env) (read port))
- #:printer write
- #:parser read ;; fixme: make a verifier?
+ #:printer write-cps
+ #:parser parse-cps
#:compilers `((bytecode . ,compile-bytecode))
- #:decompilers `((bytecode . ,decompile-bytecode))
#:for-humans? #f
)
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; Some bytecode operations can encode an immediate as an operand.
+;;; This pass tranforms generic primcalls to these specialized
+;;; primcalls, if possible.
+;;;
+;;; Code:
+
+(define-module (language cps specialize-primcalls)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:export (specialize-primcalls))
+
+(define (specialize-primcalls fun)
+ (let ((dfg (compute-dfg fun #:global? #t)))
+ (with-fresh-name-state-from-dfg dfg
+ (define (immediate-u8? sym)
+ (call-with-values (lambda () (find-constant-value sym dfg))
+ (lambda (has-const? val)
+ (and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail
+ ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (($ $cont)
+ ,cont)))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts)
+ ,(visit-term body)))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body)))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue k src ,(visit-fun fun)))
+ (($ $continue k src ($ $primcall name args))
+ ,(visit-primcall k src name args))
+ (($ $continue)
+ ,term)))
+ (define (visit-primcall k src name args)
+ ;; If we introduce a VM op from a primcall without a VM op, we
+ ;; will need to ensure that the return arity matches. Rely on the
+ ;; elide-values pass to clean up.
+ (define-syntax-rule (adapt-void exp)
+ (let-fresh (k* kvoid) (val)
+ (build-cps-term
+ ($letk ((k* ($kargs ('val) (val)
+ ($continue k src ($primcall 'values (val)))))
+ (kvoid ($kargs () ()
+ ($continue k* src ($void)))))
+ ($continue kvoid src exp)))))
+ (define-syntax-rule (adapt-val exp)
+ (let-fresh (k*) (val)
+ (build-cps-term
+ ($letk ((k* ($kargs ('val) (val)
+ ($continue k src ($primcall 'values (val))))))
+ ($continue k* src exp)))))
+ (match (cons name args)
+ (('make-vector (? immediate-u8? n) init)
+ (adapt-val ($primcall 'make-vector/immediate (n init))))
+ (('vector-ref v (? immediate-u8? n))
+ (build-cps-term
+ ($continue k src ($primcall 'vector-ref/immediate (v n)))))
+ (('vector-set! v (? immediate-u8? n) x)
+ (build-cps-term
+ ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
+ (('allocate-struct v (? immediate-u8? n))
+ (adapt-val ($primcall 'allocate-struct/immediate (v n))))
+ (('struct-ref s (? immediate-u8? n))
+ (adapt-val ($primcall 'struct-ref/immediate (s n))))
+ (('struct-set! s (? immediate-u8? n) x)
+ (build-cps-term
+ ($continue k src ($primcall 'struct-set!/immediate (s n x)))))
+ (_
+ (build-cps-term ($continue k src ($primcall name args))))))
+
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun free ,(visit-cont body)))))
+
+ (visit-cont fun))))
--- /dev/null
+;;; Abstract constant folding on CPS
+;;; Copyright (C) 2014 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; This pass uses the abstract interpretation provided by type analysis
+;;; to fold constant values and type predicates. It is most profitably
+;;; run after CSE, to take advantage of scalar replacement.
+;;;
+;;; Code:
+
+(define-module (language cps type-fold)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps renumber)
+ #:use-module (language cps types)
+ #:use-module (system base target)
+ #:export (type-fold))
+
+
+\f
+
+;; Branch folders.
+
+(define &scalar-types
+ (logior &exact-integer &flonum &char &unspecified &false &true &nil &null))
+
+(define *branch-folders* (make-hash-table))
+
+(define-syntax-rule (define-branch-folder name f)
+ (hashq-set! *branch-folders* 'name f))
+
+(define-syntax-rule (define-branch-folder-alias to from)
+ (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from)))
+
+(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...)
+ (define-branch-folder name (lambda (arg min max) body ...)))
+
+(define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0
+ arg1 min1 max1)
+ body ...)
+ (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...)))
+
+(define-syntax-rule (define-unary-type-predicate-folder name &type)
+ (define-unary-branch-folder (name type min max)
+ (let ((type* (logand type &type)))
+ (cond
+ ((zero? type*) (values #t #f))
+ ((eqv? type type*) (values #t #t))
+ (else (values #f #f))))))
+
+;; All the cases that are in compile-bytecode.
+(define-unary-type-predicate-folder pair? &pair)
+(define-unary-type-predicate-folder null? &null)
+(define-unary-type-predicate-folder nil? &nil)
+(define-unary-type-predicate-folder symbol? &symbol)
+(define-unary-type-predicate-folder variable? &box)
+(define-unary-type-predicate-folder vector? &vector)
+(define-unary-type-predicate-folder struct? &struct)
+(define-unary-type-predicate-folder string? &string)
+(define-unary-type-predicate-folder number? &number)
+(define-unary-type-predicate-folder char? &char)
+
+(define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1)
+ (cond
+ ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0))
+ (values #t #f))
+ ((and (eqv? type0 type1)
+ (eqv? min0 min1 max0 max1)
+ (zero? (logand type0 (1- type0)))
+ (not (zero? (logand type0 &scalar-types))))
+ (values #t #t))
+ (else
+ (values #f #f))))
+(define-branch-folder-alias eqv? eq?)
+(define-branch-folder-alias equal? eq?)
+
+(define (compare-ranges type0 min0 max0 type1 min1 max1)
+ (and (zero? (logand (logior type0 type1) (lognot &real)))
+ (cond ((< max0 min1) '<)
+ ((> min0 max1) '>)
+ ((= min0 max0 min1 max1) '=)
+ ((<= max0 min1) '<=)
+ ((>= min0 max1) '>=)
+ (else #f))))
+
+(define-binary-branch-folder (< type0 min0 max0 type1 min1 max1)
+ (case (compare-ranges type0 min0 max0 type1 min1 max1)
+ ((<) (values #t #t))
+ ((= >= >) (values #t #f))
+ (else (values #f #f))))
+
+(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
+ (case (compare-ranges type0 min0 max0 type1 min1 max1)
+ ((< <= =) (values #t #t))
+ ((>) (values #t #f))
+ (else (values #f #f))))
+
+(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
+ (case (compare-ranges type0 min0 max0 type1 min1 max1)
+ ((=) (values #t #t))
+ ((< >) (values #t #f))
+ (else (values #f #f))))
+
+(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
+ (case (compare-ranges type0 min0 max0 type1 min1 max1)
+ ((> >= =) (values #t #t))
+ ((<) (values #t #f))
+ (else (values #f #f))))
+
+(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
+ (case (compare-ranges type0 min0 max0 type1 min1 max1)
+ ((>) (values #t #t))
+ ((= <= <) (values #t #f))
+ (else (values #f #f))))
+
+(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
+ (define (logand-min a b)
+ (if (< a b 0)
+ (min a b)
+ 0))
+ (define (logand-max a b)
+ (if (< a b 0)
+ 0
+ (max a b)))
+ (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer))
+ (values #t (logtest min0 min1))
+ (values #f #f)))
+
+
+\f
+
+;; Strength reduction.
+
+(define *primcall-reducers* (make-hash-table))
+
+(define-syntax-rule (define-primcall-reducer name f)
+ (hashq-set! *primcall-reducers* 'name f))
+
+(define-syntax-rule (define-unary-primcall-reducer (name dfg k src
+ arg type min max)
+ body ...)
+ (define-primcall-reducer name
+ (lambda (dfg k src arg type min max) body ...)))
+
+(define-syntax-rule (define-binary-primcall-reducer (name dfg k src
+ arg0 type0 min0 max0
+ arg1 type1 min1 max1)
+ body ...)
+ (define-primcall-reducer name
+ (lambda (dfg k src arg0 type0 min0 max0 arg1 type1 min1 max1) body ...)))
+
+(define-binary-primcall-reducer (mul dfg k src
+ arg0 type0 min0 max0
+ arg1 type1 min1 max1)
+ (define (negate arg)
+ (let-fresh (kzero) (zero)
+ (build-cps-term
+ ($letk ((kzero ($kargs (#f) (zero)
+ ($continue k src ($primcall 'sub (zero arg))))))
+ ($continue kzero src ($const 0))))))
+ (define (zero)
+ (build-cps-term ($continue k src ($const 0))))
+ (define (identity arg)
+ (build-cps-term ($continue k src ($values (arg)))))
+ (define (double arg)
+ (build-cps-term ($continue k src ($primcall 'add (arg arg)))))
+ (define (power-of-two constant arg)
+ (let ((n (let lp ((bits 0) (constant constant))
+ (if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
+ (let-fresh (kbits) (bits)
+ (build-cps-term
+ ($letk ((kbits ($kargs (#f) (bits)
+ ($continue k src ($primcall 'ash (arg bits))))))
+ ($continue kbits src ($const n)))))))
+ (define (mul/constant constant constant-type arg arg-type)
+ (and (or (= constant-type &exact-integer) (= constant-type arg-type))
+ (case constant
+ ;; (* arg -1) -> (- 0 arg)
+ ((-1) (negate arg))
+ ;; (* arg 0) -> 0 if arg is not a flonum or complex
+ ((0) (and (= constant-type &exact-integer)
+ (zero? (logand arg-type
+ (lognot (logior &flonum &complex))))
+ (zero)))
+ ;; (* arg 1) -> arg
+ ((1) (identity arg))
+ ;; (* arg 2) -> (+ arg arg)
+ ((2) (double arg))
+ (else (and (= constant-type arg-type &exact-integer)
+ (positive? constant)
+ (zero? (logand constant (1- constant)))
+ (power-of-two constant arg))))))
+ (cond
+ ((logtest (logior type0 type1) (lognot &number)) #f)
+ ((= min0 max0) (mul/constant min0 type0 arg1 type1))
+ ((= min1 max1) (mul/constant min1 type1 arg0 type0))
+ (else #f)))
+
+(define-binary-primcall-reducer (logbit? dfg k src
+ arg0 type0 min0 max0
+ arg1 type1 min1 max1)
+ (define (convert-to-logtest bool-term)
+ (let-fresh (kt kf kmask kbool) (mask bool)
+ (build-cps-term
+ ($letk ((kt ($kargs () ()
+ ($continue kbool src ($const #t))))
+ (kf ($kargs () ()
+ ($continue kbool src ($const #f))))
+ (kbool ($kargs (#f) (bool)
+ ,(bool-term bool)))
+ (kmask ($kargs (#f) (mask)
+ ($continue kf src
+ ($branch kt ($primcall 'logtest (mask arg1)))))))
+ ,(if (eq? min0 max0)
+ ($continue kmask src ($const (ash 1 min0)))
+ (let-fresh (kone) (one)
+ (build-cps-term
+ ($letk ((kone ($kargs (#f) (one)
+ ($continue kmask src
+ ($primcall 'ash (one arg0))))))
+ ($continue kone src ($const 1))))))))))
+ ;; Hairiness because we are converting from a primcall with unknown
+ ;; arity to a branching primcall.
+ (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3)))
+ (and (= type0 &exact-integer)
+ (<= 0 min0 positive-fixnum-bits)
+ (<= 0 max0 positive-fixnum-bits)
+ (match (lookup-cont k dfg)
+ (($ $kreceive arity kargs)
+ (match arity
+ (($ $arity (_) () (not #f) () #f)
+ (convert-to-logtest
+ (lambda (bool)
+ (let-fresh (knil) (nil)
+ (build-cps-term
+ ($letk ((knil ($kargs (#f) (nil)
+ ($continue kargs src
+ ($values (bool nil))))))
+ ($continue knil src ($const '()))))))))
+ (_
+ (convert-to-logtest
+ (lambda (bool)
+ (build-cps-term
+ ($continue k src ($primcall 'values (bool)))))))))
+ (($ $ktail)
+ (convert-to-logtest
+ (lambda (bool)
+ (build-cps-term
+ ($continue k src ($primcall 'return (bool)))))))))))
+
+
+\f
+
+;;
+
+(define (fold-and-reduce fun dfg min-label min-var)
+ (define (scalar-value type val)
+ (cond
+ ((eqv? type &exact-integer) val)
+ ((eqv? type &flonum) (exact->inexact val))
+ ((eqv? type &char) (integer->char val))
+ ((eqv? type &unspecified) *unspecified*)
+ ((eqv? type &false) #f)
+ ((eqv? type &true) #t)
+ ((eqv? type &nil) #nil)
+ ((eqv? type &null) '())
+ (else (error "unhandled type" type val))))
+ (let* ((typev (infer-types fun dfg))
+ (label-count ((make-local-cont-folder label-count)
+ (lambda (k cont label-count) (1+ label-count))
+ fun 0))
+ (folded? (make-bitvector label-count #f))
+ (folded-values (make-vector label-count #f))
+ (reduced-terms (make-vector label-count #f)))
+ (define (label->idx label) (- label min-label))
+ (define (var->idx var) (- var min-var))
+ (define (maybe-reduce-primcall! label k src name args)
+ (let* ((reducer (hashq-ref *primcall-reducers* name)))
+ (when reducer
+ (vector-set!
+ reduced-terms
+ (label->idx label)
+ (match args
+ ((arg0)
+ (call-with-values (lambda () (lookup-pre-type typev label arg0))
+ (lambda (type0 min0 max0)
+ (reducer dfg k src arg0 type0 min0 max0))))
+ ((arg0 arg1)
+ (call-with-values (lambda () (lookup-pre-type typev label arg0))
+ (lambda (type0 min0 max0)
+ (call-with-values (lambda () (lookup-pre-type typev label arg1))
+ (lambda (type1 min1 max1)
+ (reducer dfg k src arg0 type0 min0 max0
+ arg1 type1 min1 max1))))))
+ (_ #f))))))
+ (define (maybe-fold-value! label name def)
+ (call-with-values (lambda () (lookup-post-type typev label def 0))
+ (lambda (type min max)
+ (cond
+ ((and (not (zero? type))
+ (zero? (logand type (1- type)))
+ (zero? (logand type (lognot &scalar-types)))
+ (eqv? min max))
+ (bitvector-set! folded? (label->idx label) #t)
+ (vector-set! folded-values (label->idx label)
+ (scalar-value type min))
+ #t)
+ (else #f)))))
+ (define (maybe-fold-unary-branch! label name arg)
+ (let* ((folder (hashq-ref *branch-folders* name)))
+ (when folder
+ (call-with-values (lambda () (lookup-pre-type typev label arg))
+ (lambda (type min max)
+ (call-with-values (lambda () (folder type min max))
+ (lambda (f? v)
+ (bitvector-set! folded? (label->idx label) f?)
+ (vector-set! folded-values (label->idx label) v))))))))
+ (define (maybe-fold-binary-branch! label name arg0 arg1)
+ (let* ((folder (hashq-ref *branch-folders* name)))
+ (when folder
+ (call-with-values (lambda () (lookup-pre-type typev label arg0))
+ (lambda (type0 min0 max0)
+ (call-with-values (lambda () (lookup-pre-type typev label arg1))
+ (lambda (type1 min1 max1)
+ (call-with-values (lambda ()
+ (folder type0 min0 max0 type1 min1 max1))
+ (lambda (f? v)
+ (bitvector-set! folded? (label->idx label) f?)
+ (vector-set! folded-values (label->idx label) v))))))))))
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont label ($ $kargs _ _ body))
+ (visit-term body label))
+ (($ $cont label ($ $kclause arity body alternate))
+ (visit-cont body)
+ (visit-cont alternate))
+ (_ #f)))
+ (define (visit-term term label)
+ (match term
+ (($ $letk conts body)
+ (for-each visit-cont conts)
+ (visit-term body label))
+ (($ $letrec _ _ _ body)
+ (visit-term body label))
+ (($ $continue k src ($ $primcall name args))
+ ;; We might be able to fold primcalls that define a value.
+ (match (lookup-cont k dfg)
+ (($ $kargs (_) (def))
+ ;(pk 'maybe-fold-value src name args)
+ (unless (maybe-fold-value! label name def)
+ (maybe-reduce-primcall! label k src name args)))
+ (_
+ (maybe-reduce-primcall! label k src name args))))
+ (($ $continue kf src ($ $branch kt ($ $primcall name args)))
+ ;; We might be able to fold primcalls that branch.
+ ;(pk 'maybe-fold-branch label src name args)
+ (match args
+ ((arg)
+ (maybe-fold-unary-branch! label name arg))
+ ((arg0 arg1)
+ (maybe-fold-binary-branch! label name arg0 arg1))))
+ (_ #f)))
+ (when typev
+ (match fun
+ (($ $cont kfun ($ $kfun src meta self tail clause))
+ (visit-cont clause))))
+ (values folded? folded-values reduced-terms)))
+
+(define (fold-constants* fun dfg)
+ (match fun
+ (($ $cont min-label ($ $kfun _ _ min-var))
+ (call-with-values (lambda () (fold-and-reduce fun dfg min-label min-var))
+ (lambda (folded? folded-values reduced-terms)
+ (define (label->idx label) (- label min-label))
+ (define (var->idx var) (- var min-var))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kargs names syms body))
+ (label ($kargs names syms ,(visit-term body label))))
+ (($ $cont label ($ $kclause arity body alternate))
+ (label ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (_ ,cont)))
+ (define (visit-term term label)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts)
+ ,(visit-term body label)))
+ (($ $letrec names vars funs body)
+ ($letrec names vars (map visit-fun funs)
+ ,(visit-term body label)))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue k src ,(visit-fun fun)))
+ (($ $continue k src (and primcall ($ $primcall name args)))
+ ,(cond
+ ((bitvector-ref folded? (label->idx label))
+ (let ((val (vector-ref folded-values (label->idx label))))
+ ;; Uncomment for debugging.
+ ;; (pk 'folded src primcall val)
+ (let-fresh (k*) (v*)
+ ;; Rely on DCE to elide this expression, if
+ ;; possible.
+ (build-cps-term
+ ($letk ((k* ($kargs (#f) (v*)
+ ($continue k src ($const val)))))
+ ($continue k* src ,primcall))))))
+ (else
+ (or (vector-ref reduced-terms (label->idx label))
+ term))))
+ (($ $continue kf src ($ $branch kt ($ $primcall)))
+ ,(if (bitvector-ref folded? (label->idx label))
+ ;; Folded branch.
+ (let ((val (vector-ref folded-values (label->idx label))))
+ (build-cps-term
+ ($continue (if val kt kf) src ($values ()))))
+ term))
+ (_ ,term)))
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun free ,(fold-constants* body dfg)))))
+ (rewrite-cps-cont fun
+ (($ $cont kfun ($ $kfun src meta self tail clause))
+ (kfun ($kfun src meta self ,tail ,(visit-cont clause))))))))))
+
+(define (type-fold fun)
+ (let* ((fun (renumber fun))
+ (dfg (compute-dfg fun)))
+ (with-fresh-name-state-from-dfg dfg
+ (fold-constants* fun dfg))))
--- /dev/null
+;;; Type analysis on CPS
+;;; Copyright (C) 2014, 2015 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 program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; Type analysis computes the possible types and ranges that values may
+;;; have at all program positions. This analysis can help to prove that
+;;; a primcall has no side-effects, if its arguments have the
+;;; appropriate type and range. It can also enable constant folding of
+;;; type predicates and, in the future, enable the compiler to choose
+;;; untagged, unboxed representations for numbers.
+;;;
+;;; For the purposes of this analysis, a "type" is an aspect of a value
+;;; that will not change. Guile's CPS intermediate language does not
+;;; carry manifest type information that asserts properties about given
+;;; values; instead, we recover this information via flow analysis,
+;;; garnering properties from type predicates, constant literals,
+;;; primcall results, and primcalls that assert that their arguments are
+;;; of particular types.
+;;;
+;;; A range denotes a subset of the set of values in a type, bounded by
+;;; a minimum and a maximum. The precise meaning of a range depends on
+;;; the type. For real numbers, the range indicates an inclusive lower
+;;; and upper bound on the integer value of a type. For vectors, the
+;;; range indicates the length of the vector. The range is limited to a
+;;; signed 32-bit value, with the smallest and largest values indicating
+;;; -inf.0 and +inf.0, respectively. For some types, like pairs, the
+;;; concept of "range" makes no sense. In these cases we consider the
+;;; range to be -inf.0 to +inf.0.
+;;;
+;;; Types are represented as a bitfield. Fewer bits means a more precise
+;;; type. Although normally only values that have a single type will
+;;; have an associated range, this is not enforced. The range applies
+;;; to all types in the bitfield. When control flow meets, the types and
+;;; ranges meet with the union operator.
+;;;
+;;; It is not practical to precisely compute value ranges in all cases.
+;;; For example, in the following case:
+;;;
+;;; (let lp ((n 0)) (when (foo) (lp (1+ n))))
+;;;
+;;; The first time that range analysis visits the program, N is
+;;; determined to be the exact integer 0. The second time, it is an
+;;; exact integer in the range [0, 1]; the third, [0, 2]; and so on.
+;;; This analysis will terminate, but only after the positive half of
+;;; the 32-bit range has been fully explored and we decide that the
+;;; range of N is [0, +inf.0]. At the same time, we want to do range
+;;; analysis and type analysis at the same time, as there are
+;;; interactions between them, notably in the case of `sqrt' which
+;;; returns a complex number if its argument cannot be proven to be
+;;; non-negative. So what we do is, once the types reach a fixed point,
+;;; we cause control-flow joins that would expand the range of a value
+;;; to saturate that range towards positive or infinity (as
+;;; appropriate).
+;;;
+;;; A naive approach to type analysis would build up a table that has
+;;; entries for all variables at all program points, but this has
+;;; N-squared complexity and quickly grows unmanageable. Instead, we
+;;; use _intmaps_ from (language cps intmap) to share state between
+;;; connected program points.
+;;;
+;;; Code:
+
+(define-module (language cps types)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps intmap)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:export (;; Specific types.
+ &exact-integer
+ &flonum
+ &complex
+ &fraction
+
+ &char
+ &unspecified
+ &unbound
+ &false
+ &true
+ &nil
+ &null
+ &symbol
+ &keyword
+
+ &procedure
+
+ &pointer
+ &fluid
+ &pair
+ &vector
+ &box
+ &struct
+ &string
+ &bytevector
+ &bitvector
+ &array
+ &hash-table
+
+ ;; Union types.
+ &number &real
+
+ infer-types
+ lookup-pre-type
+ lookup-post-type
+ primcall-types-check?))
+
+(define-syntax define-flags
+ (lambda (x)
+ (syntax-case x ()
+ ((_ all shift name ...)
+ (let ((count (length #'(name ...))))
+ (with-syntax (((n ...) (iota count))
+ (count count))
+ #'(begin
+ (define-syntax name (identifier-syntax (ash 1 n)))
+ ...
+ (define-syntax all (identifier-syntax (1- (ash 1 count))))
+ (define-syntax shift (identifier-syntax count)))))))))
+
+;; More precise types have fewer bits.
+(define-flags &all-types &type-bits
+ &exact-integer
+ &flonum
+ &complex
+ &fraction
+
+ &char
+ &unspecified
+ &unbound
+ &false
+ &true
+ &nil
+ &null
+ &symbol
+ &keyword
+
+ &procedure
+
+ &pointer
+ &fluid
+ &pair
+ &vector
+ &box
+ &struct
+ &string
+ &bytevector
+ &bitvector
+ &array
+ &hash-table)
+
+(define-syntax &no-type (identifier-syntax 0))
+
+(define-syntax &number
+ (identifier-syntax (logior &exact-integer &flonum &complex &fraction)))
+(define-syntax &real
+ (identifier-syntax (logior &exact-integer &flonum &fraction)))
+
+(define-syntax *max-s32* (identifier-syntax (- (ash 1 31) 1)))
+(define-syntax *min-s32* (identifier-syntax (- 0 (ash 1 31))))
+
+;; Versions of min and max that do not coerce exact numbers to become
+;; inexact.
+(define min
+ (case-lambda
+ ((a b) (if (< a b) a b))
+ ((a b c) (min (min a b) c))
+ ((a b c d) (min (min a b) c d))))
+(define max
+ (case-lambda
+ ((a b) (if (> a b) a b))
+ ((a b c) (max (max a b) c))
+ ((a b c d) (max (max a b) c d))))
+
+\f
+
+(define-syntax-rule (define-compile-time-value name val)
+ (define-syntax name
+ (make-variable-transformer
+ (lambda (x)
+ (syntax-case x (set!)
+ (var (identifier? #'var)
+ (datum->syntax #'var val)))))))
+
+(define-compile-time-value min-fixnum most-negative-fixnum)
+(define-compile-time-value max-fixnum most-positive-fixnum)
+
+(define-inlinable (make-unclamped-type-entry type min max)
+ (vector type min max))
+(define-inlinable (type-entry-type tentry)
+ (vector-ref tentry 0))
+(define-inlinable (type-entry-clamped-min tentry)
+ (vector-ref tentry 1))
+(define-inlinable (type-entry-clamped-max tentry)
+ (vector-ref tentry 2))
+
+(define-syntax-rule (clamp-range val)
+ (cond
+ ((< val min-fixnum) min-fixnum)
+ ((< max-fixnum val) max-fixnum)
+ (else val)))
+
+(define-inlinable (make-type-entry type min max)
+ (vector type (clamp-range min) (clamp-range max)))
+(define-inlinable (type-entry-min tentry)
+ (let ((min (type-entry-clamped-min tentry)))
+ (if (eq? min min-fixnum) -inf.0 min)))
+(define-inlinable (type-entry-max tentry)
+ (let ((max (type-entry-clamped-max tentry)))
+ (if (eq? max max-fixnum) +inf.0 max)))
+
+(define all-types-entry (make-type-entry &all-types -inf.0 +inf.0))
+
+(define* (var-type-entry typeset var #:optional (default all-types-entry))
+ (or (intmap-ref typeset var) default))
+
+(define (var-type typeset var)
+ (type-entry-type (var-type-entry typeset var)))
+(define (var-min typeset var)
+ (type-entry-min (var-type-entry typeset var)))
+(define (var-max typeset var)
+ (type-entry-max (var-type-entry typeset var)))
+
+;; Is the type entry A contained entirely within B?
+(define (type-entry<=? a b)
+ (match (cons a b)
+ ((#(a-type a-min a-max) . #(b-type b-min b-max))
+ (and (eqv? b-type (logior a-type b-type))
+ (<= b-min a-min)
+ (>= b-max a-max)))))
+
+(define (type-entry-union a b)
+ (cond
+ ((type-entry<=? b a) a)
+ ((type-entry<=? a b) b)
+ (else (make-type-entry
+ (logior (type-entry-type a) (type-entry-type b))
+ (min (type-entry-clamped-min a) (type-entry-clamped-min b))
+ (max (type-entry-clamped-max a) (type-entry-clamped-max b))))))
+
+(define (type-entry-intersection a b)
+ (cond
+ ((type-entry<=? a b) a)
+ ((type-entry<=? b a) b)
+ (else (make-type-entry
+ (logand (type-entry-type a) (type-entry-type b))
+ (max (type-entry-clamped-min a) (type-entry-clamped-min b))
+ (min (type-entry-clamped-max a) (type-entry-clamped-max b))))))
+
+(define (adjoin-var typeset var entry)
+ (intmap-add typeset var entry type-entry-union))
+
+(define (restrict-var typeset var entry)
+ (intmap-add typeset var entry type-entry-intersection))
+
+(define (constant-type val)
+ "Compute the type and range of VAL. Return three values: the type,
+minimum, and maximum."
+ (define (return type val)
+ (if val
+ (make-type-entry type val val)
+ (make-type-entry type -inf.0 +inf.0)))
+ (cond
+ ((number? val)
+ (cond
+ ((exact-integer? val) (return &exact-integer val))
+ ((eqv? (imag-part val) 0)
+ (if (nan? val)
+ (make-type-entry &flonum -inf.0 +inf.0)
+ (make-type-entry
+ (if (exact? val) &fraction &flonum)
+ (if (rational? val) (inexact->exact (floor val)) val)
+ (if (rational? val) (inexact->exact (ceiling val)) val))))
+ (else (return &complex #f))))
+ ((eq? val '()) (return &null #f))
+ ((eq? val #nil) (return &nil #f))
+ ((eq? val #t) (return &true #f))
+ ((eq? val #f) (return &false #f))
+ ((char? val) (return &char (char->integer val)))
+ ((eqv? val *unspecified*) (return &unspecified #f))
+ ((symbol? val) (return &symbol #f))
+ ((keyword? val) (return &keyword #f))
+ ((pair? val) (return &pair #f))
+ ((vector? val) (return &vector (vector-length val)))
+ ((string? val) (return &string (string-length val)))
+ ((bytevector? val) (return &bytevector (bytevector-length val)))
+ ((bitvector? val) (return &bitvector (bitvector-length val)))
+ ((array? val) (return &array (array-rank val)))
+ ((not (variable-bound? (make-variable val))) (return &unbound #f))
+
+ (else (error "unhandled constant" val))))
+
+(define *type-checkers* (make-hash-table))
+(define *type-inferrers* (make-hash-table))
+
+(define-syntax-rule (define-type-helper name)
+ (define-syntax-parameter name
+ (lambda (stx)
+ (syntax-violation 'name
+ "macro used outside of define-type"
+ stx))))
+(define-type-helper define!)
+(define-type-helper restrict!)
+(define-type-helper &type)
+(define-type-helper &min)
+(define-type-helper &max)
+
+(define-syntax-rule (define-type-checker (name arg ...) body ...)
+ (hashq-set!
+ *type-checkers*
+ 'name
+ (lambda (typeset arg ...)
+ (syntax-parameterize
+ ((&type (syntax-rules () ((_ val) (var-type typeset val))))
+ (&min (syntax-rules () ((_ val) (var-min typeset val))))
+ (&max (syntax-rules () ((_ val) (var-max typeset val)))))
+ body ...))))
+
+(define-syntax-rule (check-type arg type min max)
+ ;; If the arg is negative, it is a closure variable.
+ (and (>= arg 0)
+ (zero? (logand (lognot type) (&type arg)))
+ (<= min (&min arg))
+ (<= (&max arg) max)))
+
+(define-syntax-rule (define-type-inferrer* (name succ var ...) body ...)
+ (hashq-set!
+ *type-inferrers*
+ 'name
+ (lambda (in succ var ...)
+ (let ((out in))
+ (syntax-parameterize
+ ((define!
+ (syntax-rules ()
+ ((_ val type min max)
+ (set! out (adjoin-var out val
+ (make-type-entry type min max))))))
+ (restrict!
+ (syntax-rules ()
+ ((_ val type min max)
+ (set! out (restrict-var out val
+ (make-type-entry type min max))))))
+ (&type (syntax-rules () ((_ val) (var-type in val))))
+ (&min (syntax-rules () ((_ val) (var-min in val))))
+ (&max (syntax-rules () ((_ val) (var-max in val)))))
+ body ...
+ out)))))
+
+(define-syntax-rule (define-type-inferrer (name arg ...) body ...)
+ (define-type-inferrer* (name succ arg ...) body ...))
+
+(define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...)
+ (define-type-inferrer* (name succ arg ...)
+ (let ((true? (not (zero? succ))))
+ body ...)))
+
+(define-syntax define-simple-type-checker
+ (lambda (x)
+ (define (parse-spec l)
+ (syntax-case l ()
+ (() '())
+ (((type min max) . l) (cons #'(type min max) (parse-spec #'l)))
+ (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l)))
+ ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l)))))
+ (syntax-case x ()
+ ((_ (name arg-spec ...) result-spec ...)
+ (with-syntax
+ (((arg ...) (generate-temporaries #'(arg-spec ...)))
+ (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...))))
+ #'(define-type-checker (name arg ...)
+ (and (check-type arg arg-type arg-min arg-max)
+ ...)))))))
+
+(define-syntax define-simple-type-inferrer
+ (lambda (x)
+ (define (parse-spec l)
+ (syntax-case l ()
+ (() '())
+ (((type min max) . l) (cons #'(type min max) (parse-spec #'l)))
+ (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l)))
+ ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l)))))
+ (syntax-case x ()
+ ((_ (name arg-spec ...) result-spec ...)
+ (with-syntax
+ (((arg ...) (generate-temporaries #'(arg-spec ...)))
+ (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...)))
+ ((res ...) (generate-temporaries #'(result-spec ...)))
+ (((res-type res-min res-max) ...) (parse-spec #'(result-spec ...))))
+ #'(define-type-inferrer (name arg ... res ...)
+ (restrict! arg arg-type arg-min arg-max)
+ ...
+ (define! res res-type res-min res-max)
+ ...))))))
+
+(define-syntax-rule (define-simple-type (name arg-spec ...) result-spec ...)
+ (begin
+ (define-simple-type-checker (name arg-spec ...))
+ (define-simple-type-inferrer (name arg-spec ...) result-spec ...)))
+
+(define-syntax-rule (define-simple-types
+ ((name arg-spec ...) result-spec ...)
+ ...)
+ (begin
+ (define-simple-type (name arg-spec ...) result-spec ...)
+ ...))
+
+(define-syntax-rule (define-type-checker-aliases orig alias ...)
+ (let ((check (hashq-ref *type-checkers* 'orig)))
+ (hashq-set! *type-checkers* 'alias check)
+ ...))
+(define-syntax-rule (define-type-inferrer-aliases orig alias ...)
+ (let ((check (hashq-ref *type-inferrers* 'orig)))
+ (hashq-set! *type-inferrers* 'alias check)
+ ...))
+(define-syntax-rule (define-type-aliases orig alias ...)
+ (begin
+ (define-type-checker-aliases orig alias ...)
+ (define-type-inferrer-aliases orig alias ...)))
+
+
+\f
+
+;;; This list of primcall type definitions follows the order of
+;;; effects-analysis.scm; please keep it in a similar order.
+;;;
+;;; There is no need to add checker definitions for expressions that do
+;;; not exhibit the &type-check effect, as callers should not ask if
+;;; such an expression does or does not type-check. For those that do
+;;; exhibit &type-check, you should define a type inferrer unless the
+;;; primcall will never typecheck.
+;;;
+;;; Likewise there is no need to define inferrers for primcalls which
+;;; return &all-types values and which never raise exceptions from which
+;;; we can infer the types of incoming values.
+
+
+\f
+
+;;;
+;;; Generic effect-free predicates.
+;;;
+
+(define-predicate-inferrer (eq? a b true?)
+ ;; We can only propagate information down the true leg.
+ (when true?
+ (let ((type (logand (&type a) (&type b)))
+ (min (max (&min a) (&min b)))
+ (max (min (&max a) (&max b))))
+ (restrict! a type min max)
+ (restrict! b type min max))))
+(define-type-inferrer-aliases eq? eqv? equal?)
+
+(define-syntax-rule (define-simple-predicate-inferrer predicate type)
+ (define-predicate-inferrer (predicate val true?)
+ (let ((type (if true?
+ type
+ (logand (&type val) (lognot type)))))
+ (restrict! val type -inf.0 +inf.0))))
+(define-simple-predicate-inferrer pair? &pair)
+(define-simple-predicate-inferrer null? &null)
+(define-simple-predicate-inferrer nil? &nil)
+(define-simple-predicate-inferrer symbol? &symbol)
+(define-simple-predicate-inferrer variable? &box)
+(define-simple-predicate-inferrer vector? &vector)
+(define-simple-predicate-inferrer struct? &struct)
+(define-simple-predicate-inferrer string? &string)
+(define-simple-predicate-inferrer bytevector? &bytevector)
+(define-simple-predicate-inferrer bitvector? &bitvector)
+(define-simple-predicate-inferrer keyword? &keyword)
+(define-simple-predicate-inferrer number? &number)
+(define-simple-predicate-inferrer char? &char)
+(define-simple-predicate-inferrer procedure? &procedure)
+(define-simple-predicate-inferrer thunk? &procedure)
+
+\f
+
+;;;
+;;; Fluids. Note that we can't track bound-ness of fluids, as pop-fluid
+;;; can change boundness.
+;;;
+
+(define-simple-types
+ ((fluid-ref (&fluid 1)) &all-types)
+ ((fluid-set! (&fluid 0 1) &all-types))
+ ((push-fluid (&fluid 0 1) &all-types))
+ ((pop-fluid)))
+
+
+\f
+
+;;;
+;;; Prompts. (Nothing to do.)
+;;;
+
+
+\f
+
+;;;
+;;; Pairs.
+;;;
+
+(define-simple-types
+ ((cons &all-types &all-types) &pair)
+ ((car &pair) &all-types)
+ ((set-car! &pair &all-types))
+ ((cdr &pair) &all-types)
+ ((set-cdr! &pair &all-types)))
+
+
+\f
+
+;;;
+;;; Variables.
+;;;
+
+(define-simple-types
+ ((box &all-types) (&box 1))
+ ((box-ref (&box 1)) &all-types))
+
+(define-simple-type-checker (box-set! (&box 0 1) &all-types))
+(define-type-inferrer (box-set! box val)
+ (restrict! box &box 1 1))
+
+
+\f
+
+;;;
+;;; Vectors.
+;;;
+
+;; This max-vector-len computation is a hack.
+(define *max-vector-len* (ash most-positive-fixnum -5))
+
+(define-simple-type-checker (make-vector (&exact-integer 0 *max-vector-len*)
+ &all-types))
+(define-type-inferrer (make-vector size init result)
+ (restrict! size &exact-integer 0 *max-vector-len*)
+ (define! result &vector (max (&min size) 0) (&max size)))
+
+(define-type-checker (vector-ref v idx)
+ (and (check-type v &vector 0 *max-vector-len*)
+ (check-type idx &exact-integer 0 (1- (&min v)))))
+(define-type-inferrer (vector-ref v idx result)
+ (restrict! v &vector (1+ (&min idx)) +inf.0)
+ (restrict! idx &exact-integer 0 (1- (&max v)))
+ (define! result &all-types -inf.0 +inf.0))
+
+(define-type-checker (vector-set! v idx val)
+ (and (check-type v &vector 0 *max-vector-len*)
+ (check-type idx &exact-integer 0 (1- (&min v)))))
+(define-type-inferrer (vector-set! v idx val)
+ (restrict! v &vector (1+ (&min idx)) +inf.0)
+ (restrict! idx &exact-integer 0 (1- (&max v))))
+
+(define-type-aliases make-vector make-vector/immediate)
+(define-type-aliases vector-ref vector-ref/immediate)
+(define-type-aliases vector-set! vector-set!/immediate)
+
+(define-simple-type-checker (vector-length &vector))
+(define-type-inferrer (vector-length v result)
+ (restrict! v &vector 0 *max-vector-len*)
+ (define! result &exact-integer (max (&min v) 0)
+ (min (&max v) *max-vector-len*)))
+
+
+\f
+
+;;;
+;;; Structs.
+;;;
+
+;; No type-checker for allocate-struct, as we can't currently check that
+;; vt is actually a vtable.
+(define-type-inferrer (allocate-struct vt size result)
+ (restrict! vt &struct vtable-offset-user +inf.0)
+ (restrict! size &exact-integer 0 +inf.0)
+ (define! result &struct (max (&min size) 0) (&max size)))
+
+(define-type-checker (struct-ref s idx)
+ (and (check-type s &struct 0 +inf.0)
+ (check-type idx &exact-integer 0 +inf.0)
+ ;; FIXME: is the field readable?
+ (< (&max idx) (&min s))))
+(define-type-inferrer (struct-ref s idx result)
+ (restrict! s &struct (1+ (&min idx)) +inf.0)
+ (restrict! idx &exact-integer 0 (1- (&max s)))
+ (define! result &all-types -inf.0 +inf.0))
+
+(define-type-checker (struct-set! s idx val)
+ (and (check-type s &struct 0 +inf.0)
+ (check-type idx &exact-integer 0 +inf.0)
+ ;; FIXME: is the field writable?
+ (< (&max idx) (&min s))))
+(define-type-inferrer (struct-set! s idx val)
+ (restrict! s &struct (1+ (&min idx)) +inf.0)
+ (restrict! idx &exact-integer 0 (1- (&max s))))
+
+(define-type-aliases allocate-struct allocate-struct/immediate)
+(define-type-aliases struct-ref struct-ref/immediate)
+(define-type-aliases struct-set! struct-set!/immediate)
+
+(define-simple-type (struct-vtable (&struct 0 +inf.0))
+ (&struct vtable-offset-user +inf.0))
+
+
+\f
+
+;;;
+;;; Strings.
+;;;
+
+(define *max-char* (1- (ash 1 24)))
+
+(define-type-checker (string-ref s idx)
+ (and (check-type s &string 0 +inf.0)
+ (check-type idx &exact-integer 0 +inf.0)
+ (< (&max idx) (&min s))))
+(define-type-inferrer (string-ref s idx result)
+ (restrict! s &string (1+ (&min idx)) +inf.0)
+ (restrict! idx &exact-integer 0 (1- (&max s)))
+ (define! result &char 0 *max-char*))
+
+(define-type-checker (string-set! s idx val)
+ (and (check-type s &string 0 +inf.0)
+ (check-type idx &exact-integer 0 +inf.0)
+ (check-type val &char 0 *max-char*)
+ (< (&max idx) (&min s))))
+(define-type-inferrer (string-set! s idx val)
+ (restrict! s &string (1+ (&min idx)) +inf.0)
+ (restrict! idx &exact-integer 0 (1- (&max s)))
+ (restrict! val &char 0 *max-char*))
+
+(define-simple-type-checker (string-length &string))
+(define-type-inferrer (string-length s result)
+ (restrict! s &string 0 +inf.0)
+ (define! result &exact-integer (max (&min s) 0) (&max s)))
+
+(define-simple-type (number->string &number) (&string 0 +inf.0))
+(define-simple-type (string->number (&string 0 +inf.0))
+ ((logior &number &false) -inf.0 +inf.0))
+
+
+\f
+
+;;;
+;;; Bytevectors.
+;;;
+
+(define-simple-type-checker (bytevector-length &bytevector))
+(define-type-inferrer (bytevector-length bv result)
+ (restrict! bv &bytevector 0 +inf.0)
+ (define! result &exact-integer (max (&min bv) 0) (&max bv)))
+
+(define-syntax-rule (define-bytevector-accessors ref set type size min max)
+ (begin
+ (define-type-checker (ref bv idx)
+ (and (check-type bv &bytevector 0 +inf.0)
+ (check-type idx &exact-integer 0 +inf.0)
+ (< (&max idx) (- (&min bv) size))))
+ (define-type-inferrer (ref bv idx result)
+ (restrict! bv &bytevector (+ (&min idx) size) +inf.0)
+ (restrict! idx &exact-integer 0 (- (&max bv) size))
+ (define! result type min max))
+ (define-type-checker (set bv idx val)
+ (and (check-type bv &bytevector 0 +inf.0)
+ (check-type idx &exact-integer 0 +inf.0)
+ (check-type val type min max)
+ (< (&max idx) (- (&min bv) size))))
+ (define-type-inferrer (set! bv idx val)
+ (restrict! bv &bytevector (+ (&min idx) size) +inf.0)
+ (restrict! idx &exact-integer 0 (- (&max bv) size))
+ (restrict! val type min max))))
+
+(define-syntax-rule (define-short-bytevector-accessors ref set size signed?)
+ (define-bytevector-accessors ref set &exact-integer size
+ (if signed? (- (ash 1 (1- (* size 8)))) 0)
+ (1- (ash 1 (if signed? (1- (* size 8)) (* size 8))))))
+
+(define-short-bytevector-accessors bv-u8-ref bv-u8-set! 1 #f)
+(define-short-bytevector-accessors bv-s8-ref bv-s8-set! 1 #t)
+(define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f)
+(define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t)
+
+;; The range analysis only works on signed 32-bit values, so some limits
+;; are out of range.
+(define-bytevector-accessors bv-u32-ref bv-u32-set! &exact-integer 4 0 +inf.0)
+(define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 -inf.0 +inf.0)
+(define-bytevector-accessors bv-u64-ref bv-u64-set! &exact-integer 8 0 +inf.0)
+(define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 -inf.0 +inf.0)
+(define-bytevector-accessors bv-f32-ref bv-f32-set! &real 4 -inf.0 +inf.0)
+(define-bytevector-accessors bv-f64-ref bv-f64-set! &real 8 -inf.0 +inf.0)
+
+
+\f
+
+;;;
+;;; Numbers.
+;;;
+
+;; First, branching primitives with no results.
+(define-simple-type-checker (= &number &number))
+(define-predicate-inferrer (= a b true?)
+ (when (and true?
+ (zero? (logand (logior (&type a) (&type b)) (lognot &number))))
+ (let ((min (max (&min a) (&min b)))
+ (max (min (&max a) (&max b))))
+ (restrict! a &number min max)
+ (restrict! b &number min max))))
+
+(define-simple-type-checker (< &real &real))
+(define-predicate-inferrer (< a b true?)
+ (when (zero? (logand (logior (&type a) (&type b)) (lognot &number)))
+ (restrict! a &real -inf.0 +inf.0)
+ (restrict! b &real -inf.0 +inf.0)))
+(define-type-aliases < <= > >=)
+
+;; Arithmetic.
+(define-syntax-rule (define-unary-result! a result min max)
+ (let ((min* min)
+ (max* max)
+ (type (logand (&type a) &number)))
+ (cond
+ ((not (= type (&type a)))
+ ;; Not a number. Punt and do nothing.
+ (define! result &all-types -inf.0 +inf.0))
+ ;; Complex numbers don't have a range.
+ ((eqv? type &complex)
+ (define! result &complex -inf.0 +inf.0))
+ (else
+ (define! result type min* max*)))))
+
+(define-syntax-rule (define-binary-result! a b result closed? min max)
+ (let ((min* min)
+ (max* max)
+ (a-type (logand (&type a) &number))
+ (b-type (logand (&type b) &number)))
+ (cond
+ ((or (not (= a-type (&type a))) (not (= b-type (&type b))))
+ ;; One input not a number. Perhaps we end up dispatching to
+ ;; GOOPS.
+ (define! result &all-types -inf.0 +inf.0))
+ ;; Complex and floating-point numbers are contagious.
+ ((or (eqv? a-type &complex) (eqv? b-type &complex))
+ (define! result &complex -inf.0 +inf.0))
+ ((or (eqv? a-type &flonum) (eqv? b-type &flonum))
+ (define! result &flonum min* max*))
+ ;; Exact integers are closed under some operations.
+ ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer))
+ (define! result &exact-integer min* max*))
+ (else
+ ;; Fractions may become integers.
+ (let ((type (logior a-type b-type)))
+ (define! result
+ (if (zero? (logand type &fraction))
+ type
+ (logior type &exact-integer))
+ min* max*))))))
+
+(define-simple-type-checker (add &number &number))
+(define-type-inferrer (add a b result)
+ (define-binary-result! a b result #t
+ (+ (&min a) (&min b))
+ (+ (&max a) (&max b))))
+
+(define-simple-type-checker (sub &number &number))
+(define-type-inferrer (sub a b result)
+ (define-binary-result! a b result #t
+ (- (&min a) (&max b))
+ (- (&max a) (&min b))))
+
+(define-simple-type-checker (mul &number &number))
+(define-type-inferrer (mul a b result)
+ (let ((min-a (&min a)) (max-a (&max a))
+ (min-b (&min b)) (max-b (&max b)))
+ (define (nan* a b)
+ ;; We only really get +inf.0 at runtime for flonums and compnums.
+ ;; If we have inferred that the arguments are not flonums and not
+ ;; compnums, then the result of (* +inf.0 0) at range inference
+ ;; time is 0 and not +nan.0.
+ (if (or (and (inf? a) (zero? b))
+ (and (zero? a) (inf? b))
+ (not (logtest (logior (&type a) (&type b))
+ (logior &flonum &complex))))
+ 0
+ (* a b)))
+ (let ((-- (nan* min-a min-b))
+ (-+ (nan* min-a max-b))
+ (++ (nan* max-a max-b))
+ (+- (nan* max-a min-b)))
+ (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-))))
+ (define-binary-result! a b result #t
+ (cond
+ ((eqv? a b) 0)
+ (has-nan? -inf.0)
+ (else (min -- -+ ++ +-)))
+ (if has-nan?
+ +inf.0
+ (max -- -+ ++ +-)))))))
+
+(define-type-checker (div a b)
+ (and (check-type a &number -inf.0 +inf.0)
+ (check-type b &number -inf.0 +inf.0)
+ ;; We only know that there will not be an exception if b is not
+ ;; zero.
+ (not (<= (&min b) 0 (&max b)))))
+(define-type-inferrer (div a b result)
+ (let ((min-a (&min a)) (max-a (&max a))
+ (min-b (&min b)) (max-b (&max b)))
+ (call-with-values
+ (lambda ()
+ (if (<= min-b 0 max-b)
+ ;; If the range of the divisor crosses 0, the result spans
+ ;; the whole range.
+ (values -inf.0 +inf.0)
+ ;; Otherwise min-b and max-b have the same sign, and cannot both
+ ;; be infinity.
+ (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b)))
+ (-+- (if (inf? max-b) 0 (floor/ min-a max-b)))
+ (++- (if (inf? max-b) 0 (floor/ max-a max-b)))
+ (+-- (if (inf? min-b) 0 (floor/ max-a min-b)))
+ (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b)))
+ (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b)))
+ (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b)))
+ (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b))))
+ (values (min (min --- -+- ++- +--)
+ (min --+ -++ +++ +-+))
+ (max (max --- -+- ++- +--)
+ (max --+ -++ +++ +-+))))))
+ (lambda (min max)
+ (define-binary-result! a b result #f min max)))))
+
+(define-simple-type-checker (add1 &number))
+(define-type-inferrer (add1 a result)
+ (define-unary-result! a result (1+ (&min a)) (1+ (&max a))))
+
+(define-simple-type-checker (sub1 &number))
+(define-type-inferrer (sub1 a result)
+ (define-unary-result! a result (1- (&min a)) (1- (&max a))))
+
+(define-type-checker (quo a b)
+ (and (check-type a &exact-integer -inf.0 +inf.0)
+ (check-type b &exact-integer -inf.0 +inf.0)
+ ;; We only know that there will not be an exception if b is not
+ ;; zero.
+ (not (<= (&min b) 0 (&max b)))))
+(define-type-inferrer (quo a b result)
+ (restrict! a &exact-integer -inf.0 +inf.0)
+ (restrict! b &exact-integer -inf.0 +inf.0)
+ (define! result &exact-integer -inf.0 +inf.0))
+
+(define-type-checker-aliases quo rem)
+(define-type-inferrer (rem a b result)
+ (restrict! a &exact-integer -inf.0 +inf.0)
+ (restrict! b &exact-integer -inf.0 +inf.0)
+ ;; Same sign as A.
+ (let ((max-abs-rem (1- (max (abs (&min b)) (abs (&max b))))))
+ (cond
+ ((< (&min a) 0)
+ (if (< 0 (&max a))
+ (define! result &exact-integer (- max-abs-rem) max-abs-rem)
+ (define! result &exact-integer (- max-abs-rem) 0)))
+ (else
+ (define! result &exact-integer 0 max-abs-rem)))))
+
+(define-type-checker-aliases quo mod)
+(define-type-inferrer (mod a b result)
+ (restrict! a &exact-integer -inf.0 +inf.0)
+ (restrict! b &exact-integer -inf.0 +inf.0)
+ ;; Same sign as B.
+ (let ((max-abs-mod (1- (max (abs (&min b)) (abs (&max b))))))
+ (cond
+ ((< (&min b) 0)
+ (if (< 0 (&max b))
+ (define! result &exact-integer (- max-abs-mod) max-abs-mod)
+ (define! result &exact-integer (- max-abs-mod) 0)))
+ (else
+ (define! result &exact-integer 0 max-abs-mod)))))
+
+;; Predicates.
+(define-syntax-rule (define-number-kind-predicate-inferrer name type)
+ (define-type-inferrer (name val result)
+ (cond
+ ((zero? (logand (&type val) type))
+ (define! result &false 0 0))
+ ((zero? (logand (&type val) (lognot type)))
+ (define! result &true 0 0))
+ (else
+ (define! result (logior &true &false) 0 0)))))
+(define-number-kind-predicate-inferrer complex? &number)
+(define-number-kind-predicate-inferrer real? &real)
+(define-number-kind-predicate-inferrer rational?
+ (logior &exact-integer &fraction))
+(define-number-kind-predicate-inferrer integer?
+ (logior &exact-integer &flonum))
+(define-number-kind-predicate-inferrer exact-integer?
+ &exact-integer)
+
+(define-simple-type-checker (exact? &number))
+(define-type-inferrer (exact? val result)
+ (restrict! val &number -inf.0 +inf.0)
+ (cond
+ ((zero? (logand (&type val) (logior &exact-integer &fraction)))
+ (define! result &false 0 0))
+ ((zero? (logand (&type val) (lognot (logior &exact-integer &fraction))))
+ (define! result &true 0 0))
+ (else
+ (define! result (logior &true &false) 0 0))))
+
+(define-simple-type-checker (inexact? &number))
+(define-type-inferrer (inexact? val result)
+ (restrict! val &number -inf.0 +inf.0)
+ (cond
+ ((zero? (logand (&type val) (logior &flonum &complex)))
+ (define! result &false 0 0))
+ ((zero? (logand (&type val) (logand &number
+ (lognot (logior &flonum &complex)))))
+ (define! result &true 0 0))
+ (else
+ (define! result (logior &true &false) 0 0))))
+
+(define-simple-type-checker (inf? &real))
+(define-type-inferrer (inf? val result)
+ (restrict! val &real -inf.0 +inf.0)
+ (cond
+ ((or (zero? (logand (&type val) (logior &flonum &complex)))
+ (and (not (inf? (&min val))) (not (inf? (&max val)))))
+ (define! result &false 0 0))
+ (else
+ (define! result (logior &true &false) 0 0))))
+
+(define-type-aliases inf? nan?)
+
+(define-simple-type (even? &exact-integer)
+ ((logior &true &false) 0 0))
+(define-type-aliases even? odd?)
+
+;; Bit operations.
+(define-simple-type-checker (ash &exact-integer &exact-integer))
+(define-type-inferrer (ash val count result)
+ (define (ash* val count)
+ ;; As we can only represent a 32-bit range, don't bother inferring
+ ;; shifts that might exceed that range.
+ (cond
+ ((inf? val) val) ; Preserves sign.
+ ((< -32 count 32) (ash val count))
+ ((zero? val) 0)
+ ((positive? val) +inf.0)
+ (else -inf.0)))
+ (restrict! val &exact-integer -inf.0 +inf.0)
+ (restrict! count &exact-integer -inf.0 +inf.0)
+ (let ((-- (ash* (&min val) (&min count)))
+ (-+ (ash* (&min val) (&max count)))
+ (++ (ash* (&max val) (&max count)))
+ (+- (ash* (&max val) (&min count))))
+ (define! result &exact-integer
+ (min -- -+ ++ +-)
+ (max -- -+ ++ +-))))
+
+(define (next-power-of-two n)
+ (let lp ((out 1))
+ (if (< n out)
+ out
+ (lp (ash out 1)))))
+
+(define-simple-type-checker (logand &exact-integer &exact-integer))
+(define-type-inferrer (logand a b result)
+ (define (logand-min a b)
+ (if (and (negative? a) (negative? b))
+ (min a b)
+ 0))
+ (define (logand-max a b)
+ (if (and (positive? a) (positive? b))
+ (min a b)
+ 0))
+ (restrict! a &exact-integer -inf.0 +inf.0)
+ (restrict! b &exact-integer -inf.0 +inf.0)
+ (define! result &exact-integer
+ (logand-min (&min a) (&min b))
+ (logand-max (&max a) (&max b))))
+
+(define-simple-type-checker (logior &exact-integer &exact-integer))
+(define-type-inferrer (logior a b result)
+ ;; Saturate all bits of val.
+ (define (saturate val)
+ (1- (next-power-of-two val)))
+ (define (logior-min a b)
+ (cond ((and (< a 0) (<= 0 b)) a)
+ ((and (< b 0) (<= 0 a)) b)
+ (else (max a b))))
+ (define (logior-max a b)
+ ;; If either operand is negative, just assume the max is -1.
+ (cond
+ ((or (< a 0) (< b 0)) -1)
+ ((or (inf? a) (inf? b)) +inf.0)
+ (else (saturate (logior a b)))))
+ (restrict! a &exact-integer -inf.0 +inf.0)
+ (restrict! b &exact-integer -inf.0 +inf.0)
+ (define! result &exact-integer
+ (logior-min (&min a) (&min b))
+ (logior-max (&max a) (&max b))))
+
+;; For our purposes, treat logxor the same as logior.
+(define-type-aliases logior logxor)
+
+(define-simple-type-checker (lognot &exact-integer))
+(define-type-inferrer (lognot a result)
+ (restrict! a &exact-integer -inf.0 +inf.0)
+ (define! result &exact-integer
+ (- -1 (&max a))
+ (- -1 (&min a))))
+
+(define-simple-type-checker (logtest &exact-integer &exact-integer))
+(define-predicate-inferrer (logtest a b true?)
+ (restrict! a &exact-integer -inf.0 +inf.0)
+ (restrict! b &exact-integer -inf.0 +inf.0))
+
+(define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer))
+(define-type-inferrer (logbit? a b result)
+ (let ((a-min (&min a))
+ (a-max (&max a))
+ (b-min (&min b))
+ (b-max (&max b)))
+ (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min))
+ (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min)))
+ (let ((type (if (logbit? a-min b-min) &true &false)))
+ (define! result type 0 0))
+ (define! result (logior &true &false) 0 0))))
+
+;; Flonums.
+(define-simple-type-checker (sqrt &number))
+(define-type-inferrer (sqrt x result)
+ (let ((type (&type x)))
+ (cond
+ ((and (zero? (logand type &complex)) (<= 0 (&min x)))
+ (define! result
+ (logior type &flonum)
+ (inexact->exact (floor (sqrt (&min x))))
+ (if (inf? (&max x))
+ +inf.0
+ (inexact->exact (ceiling (sqrt (&max x)))))))
+ (else
+ (define! result (logior type &flonum &complex) -inf.0 +inf.0)))))
+
+(define-simple-type-checker (abs &real))
+(define-type-inferrer (abs x result)
+ (let ((type (&type x)))
+ (cond
+ ((eqv? type (logand type &number))
+ (restrict! x &real -inf.0 +inf.0)
+ (define! result (logand type &real)
+ (min (abs (&min x)) (abs (&max x)))
+ (max (abs (&min x)) (abs (&max x)))))
+ (else
+ (define! result (logior (logand (&type x) (lognot &number))
+ (logand (&type x) &real))
+ (max (&min x) 0)
+ (max (abs (&min x)) (abs (&max x))))))))
+
+
+\f
+
+;;;
+;;; Characters.
+;;;
+
+(define-simple-type (char<? &char &char)
+ ((logior &true &false) 0 0))
+(define-type-aliases char<? char<=? char>=? char>?)
+
+(define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff)))
+(define-type-inferrer (integer->char i result)
+ (restrict! i &exact-integer 0 #x10ffff)
+ (define! result &char (max (&min i) 0) (min (&max i) #x10ffff)))
+
+(define-simple-type-checker (char->integer &char))
+(define-type-inferrer (char->integer c result)
+ (restrict! c &char 0 #x10ffff)
+ (define! result &exact-integer (max (&min c) 0) (min (&max c) #x10ffff)))
+
+
+\f
+
+;;;
+;;; Type flow analysis: the meet (ahem) of the algorithm.
+;;;
+
+(define (infer-types* dfg min-label label-count)
+ "Compute types for all variables in @var{fun}. Returns a hash table
+mapping symbols to types."
+ (let ((typev (make-vector label-count))
+ (idoms (compute-idoms dfg min-label label-count))
+ (revisit-label #f)
+ (types-changed? #f)
+ (saturate-ranges? #f))
+ (define (label->idx label) (- label min-label))
+
+ (define (get-entry label) (vector-ref typev (label->idx label)))
+
+ (define (in-types entry) (vector-ref entry 0))
+ (define (out-types entry succ) (vector-ref entry (1+ succ)))
+
+ (define (update-in-types! entry types)
+ (vector-set! entry 0 types))
+ (define (update-out-types! entry succ types)
+ (vector-set! entry (1+ succ) types))
+
+ (define (prepare-initial-state!)
+ ;; The result is a vector with an entry for each label. Each entry
+ ;; is a vector. The first slot in the entry vector corresponds to
+ ;; the types that flow into the labelled expression. The following
+ ;; slot is for the types that flow out to the first successor, and
+ ;; so on for additional successors.
+ (let lp ((label min-label))
+ (when (< label (+ min-label label-count))
+ (let* ((nsuccs (match (lookup-cont label dfg)
+ (($ $kargs _ _ term)
+ (match (find-call term)
+ (($ $continue k src (or ($ $branch) ($ $prompt))) 2)
+ (_ 1)))
+ (($ $kfun src meta self tail clause) (if clause 1 0))
+ (($ $kclause arity body alt) (if alt 2 1))
+ (($ $kreceive) 1)
+ (($ $ktail) 0)))
+ (entry (make-vector (1+ nsuccs) #f)))
+ (vector-set! typev (label->idx label) entry)
+ (lp (1+ label)))))
+
+ ;; Initial state: nothing flows into the $kfun.
+ (let ((entry (get-entry min-label)))
+ (update-in-types! entry empty-intmap)))
+
+ (define (adjoin-vars types vars entry)
+ (match vars
+ (() types)
+ ((var . vars)
+ (adjoin-vars (adjoin-var types var entry) vars entry))))
+
+ (define (infer-primcall types succ name args result)
+ (cond
+ ((hashq-ref *type-inferrers* name)
+ => (lambda (inferrer)
+ ;; FIXME: remove the apply?
+ ;(pk 'primcall name args result)
+ (apply inferrer types succ
+ (if result
+ (append args (list result))
+ args))))
+ (result
+ (adjoin-var types result all-types-entry))
+ (else
+ types)))
+
+ (define (type-entry-saturating-union a b)
+ (cond
+ ((type-entry<=? b a) a)
+ #;
+ ((and (not saturate-ranges?)
+ (eqv? (a-type ))
+ (type-entry<=? a b)) b)
+ (else (make-type-entry
+ (let* ((a-type (type-entry-type a))
+ (b-type (type-entry-type b))
+ (type (logior a-type b-type)))
+ (unless (eqv? a-type type)
+ (set! types-changed? #t))
+ type)
+ (let ((a-min (type-entry-clamped-min a))
+ (b-min (type-entry-clamped-min b)))
+ (if (< b-min a-min)
+ (if saturate-ranges? min-fixnum b-min)
+ a-min))
+ (let ((a-max (type-entry-clamped-max a))
+ (b-max (type-entry-clamped-max b)))
+ (if (> b-max a-max)
+ (if saturate-ranges? max-fixnum b-max)
+ a-max))))))
+
+ (define (propagate-types! pred-label pred-entry succ-idx succ-label out)
+ ;; Update "in" set of continuation.
+ (let ((succ-entry (get-entry succ-label)))
+ (match (lookup-predecessors succ-label dfg)
+ ((_)
+ ;; A normal edge.
+ (update-in-types! succ-entry out))
+ (_
+ ;; A control-flow join.
+ (let* ((succ-dom-label (vector-ref idoms (label->idx succ-label)))
+ (succ-dom-entry (get-entry succ-dom-label))
+ (old-in (in-types succ-entry))
+ (in (if old-in
+ (intmap-intersect old-in out
+ type-entry-saturating-union)
+ out)))
+ ;; If the "in" set changed, update the entry and possibly
+ ;; arrange to iterate again.
+ (unless (eq? old-in in)
+ (update-in-types! succ-entry in)
+ ;; If the changed successor is a back-edge, ensure that
+ ;; we revisit the function.
+ (when (<= succ-label pred-label)
+ (unless (and revisit-label (<= revisit-label succ-label))
+ ;; (pk 'marking-revisit pred-label succ-label)
+ (set! revisit-label succ-label))))))))
+ ;; Finally update "out" set for current expression.
+ (update-out-types! pred-entry succ-idx out))
+
+ (define (visit-exp label entry k types exp)
+ (define (propagate! succ-idx succ-label types)
+ (propagate-types! label entry succ-idx succ-label types))
+ ;; Each of these branches must propagate! to its successors.
+ (match exp
+ (($ $branch kt ($ $values (arg)))
+ ;; The "normal" continuation is the #f branch.
+ (let ((types (restrict-var types arg
+ (make-type-entry (logior &false &nil)
+ 0
+ 0))))
+ (propagate! 0 k types))
+ (let ((types (restrict-var types arg
+ (make-type-entry
+ (logand &all-types
+ (lognot (logior &false &nil)))
+ -inf.0 +inf.0))))
+ (propagate! 1 kt types)))
+ (($ $branch kt ($ $primcall name args))
+ ;; The "normal" continuation is the #f branch.
+ (let ((types (infer-primcall types 0 name args #f)))
+ (propagate! 0 k types))
+ (let ((types (infer-primcall types 1 name args #f)))
+ (propagate! 1 kt types)))
+ (($ $prompt escape? tag handler)
+ ;; The "normal" continuation enters the prompt.
+ (propagate! 0 k types)
+ (propagate! 1 handler types))
+ (($ $primcall name args)
+ (propagate! 0 k
+ (match (lookup-cont k dfg)
+ (($ $kargs _ defs)
+ (infer-primcall types 0 name args
+ (match defs ((var) var) (() #f))))
+ (_
+ ;(pk 'warning-no-restrictions name)
+ types))))
+ (($ $values args)
+ (match (lookup-cont k dfg)
+ (($ $kargs _ defs)
+ (let ((in types))
+ (let lp ((defs defs) (args args) (out types))
+ (match (cons defs args)
+ ((() . ())
+ (propagate! 0 k out))
+ (((def . defs) . (arg . args))
+ (lp defs args
+ (adjoin-var out def (var-type-entry in arg))))))))
+ (_
+ (propagate! 0 k types))))
+ ((or ($ $call) ($ $callk))
+ (propagate! 0 k types))
+ (_
+ (match (lookup-cont k dfg)
+ (($ $kargs (_) (var))
+ (let ((entry (match exp
+ (($ $void)
+ (make-type-entry &unspecified -inf.0 +inf.0))
+ (($ $const val)
+ (constant-type val))
+ ((or ($ $prim) ($ $fun) ($ $closure))
+ ;; Could be more precise here.
+ (make-type-entry &procedure -inf.0 +inf.0)))))
+ (propagate! 0 k (adjoin-var types var entry))))))))
+
+ (prepare-initial-state!)
+
+ ;; Iterate over all labelled expressions in the function,
+ ;; propagating types and ranges to all successors.
+ (let lp ((label min-label))
+ ;(pk 'visit label)
+ (cond
+ ((< label (+ min-label label-count))
+ (let* ((entry (vector-ref typev (label->idx label)))
+ (types (in-types entry)))
+ (define (propagate! succ-idx succ-label types)
+ (propagate-types! label entry succ-idx succ-label types))
+ ;; Add types for new definitions, and restrict types of
+ ;; existing variables due to side effects.
+ (match (lookup-cont label dfg)
+ (($ $kargs names vars term)
+ (let visit-term ((term term) (types types))
+ (match term
+ (($ $letrec names vars funs term)
+ (visit-term term
+ (adjoin-vars types vars
+ (make-type-entry &procedure
+ -inf.0 +inf.0))))
+ (($ $letk conts term)
+ (visit-term term types))
+ (($ $continue k src exp)
+ (visit-exp label entry k types exp)))))
+ (($ $kreceive arity k)
+ (match (lookup-cont k dfg)
+ (($ $kargs names vars)
+ (propagate! 0 k
+ (adjoin-vars types vars all-types-entry)))))
+ (($ $kfun src meta self tail clause)
+ (let ((types (adjoin-var types self all-types-entry)))
+ (match clause
+ (#f #f)
+ (($ $cont kclause)
+ (propagate! 0 kclause types)))))
+ (($ $kclause arity ($ $cont kbody ($ $kargs names vars)) alt)
+ (propagate! 0 kbody
+ (adjoin-vars types vars all-types-entry))
+ (match alt
+ (#f #f)
+ (($ $cont kclause)
+ (propagate! 1 kclause types))))
+ (($ $ktail) #t)))
+
+ ;; And loop.
+ (lp (1+ label)))
+
+ ;; Iterate until we reach a fixed point.
+ (revisit-label
+ ;; Once the types have a fixed point, iterate until ranges also
+ ;; reach a fixed point, saturating ranges to accelerate
+ ;; convergence.
+ (unless types-changed?
+ (set! saturate-ranges? #t))
+ (set! types-changed? #f)
+ (let ((label revisit-label))
+ (set! revisit-label #f)
+ ;(pk 'looping)
+ (lp label)))
+
+ ;; All done! Return the computed types.
+ (else typev)))))
+
+(define-record-type <type-analysis>
+ (make-type-analysis min-label label-count types)
+ type-analysis?
+ (min-label type-analysis-min-label)
+ (label-count type-analysis-label-count)
+ (types type-analysis-types))
+
+(define (infer-types fun dfg)
+ ;; Fun must be renumbered.
+ (match fun
+ (($ $cont min-label ($ $kfun))
+ (let ((label-count ((make-local-cont-folder label-count)
+ (lambda (k cont label-count) (1+ label-count))
+ fun 0)))
+ (make-type-analysis min-label label-count
+ (infer-types* dfg min-label label-count))))))
+
+(define (lookup-pre-type analysis label def)
+ (match analysis
+ (($ <type-analysis> min-label label-count typev)
+ (let* ((entry (vector-ref typev (- label min-label)))
+ (tentry (var-type-entry (vector-ref entry 0) def)))
+ (values (type-entry-type tentry)
+ (type-entry-min tentry)
+ (type-entry-max tentry))))))
+
+(define (lookup-post-type analysis label def succ-idx)
+ (match analysis
+ (($ <type-analysis> min-label label-count typev)
+ (let* ((entry (vector-ref typev (- label min-label)))
+ (tentry (var-type-entry (vector-ref entry (1+ succ-idx)) def)))
+ (values (type-entry-type tentry)
+ (type-entry-min tentry)
+ (type-entry-max tentry))))))
+
+(define (primcall-types-check? analysis label name args)
+ (match (hashq-ref *type-checkers* name)
+ (#f #f)
+ (checker
+ (match analysis
+ (($ <type-analysis> min-label label-count typev)
+ (let ((entry (vector-ref typev (- label min-label))))
+ (apply checker (vector-ref entry 0) args)))))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;;
+;;; Code:
+
+(define-module (language cps verify)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:export (verify-cps))
+
+(define (verify-cps fun)
+ (define seen-labels (make-hash-table))
+ (define seen-vars (make-hash-table))
+
+ (define (add sym seen env)
+ (when (hashq-ref seen sym)
+ (error "duplicate gensym" sym))
+ (hashq-set! seen sym #t)
+ (cons sym env))
+
+ (define (add-env new seen env)
+ (if (null? new)
+ env
+ (add-env (cdr new) seen (add (car new) seen env))))
+
+ (define (add-vars new env)
+ (unless (and-map exact-integer? new)
+ (error "bad vars" new))
+ (add-env new seen-vars env))
+
+ (define (add-labels new env)
+ (unless (and-map exact-integer? new)
+ (error "bad labels" new))
+ (add-env new seen-labels env))
+
+ (define (check-ref sym seen env)
+ (cond
+ ((not (hashq-ref seen sym))
+ (error "unbound lexical" sym))
+ ((not (memq sym env))
+ (error "displaced lexical" sym))))
+
+ (define (check-label sym env)
+ (check-ref sym seen-labels env))
+
+ (define (check-var sym env)
+ (check-ref sym seen-vars env))
+
+ (define (check-src src)
+ (if (and src (not (and (list? src) (and-map pair? src)
+ (and-map symbol? (map car src)))))
+ (error "bad src")))
+
+ (define (visit-cont-body cont k-env v-env)
+ (match cont
+ (($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
+ (check-label k k-env))
+ (($ $kargs (name ...) (sym ...) body)
+ (unless (= (length name) (length sym))
+ (error "name and sym lengths don't match" name sym))
+ (visit-term body k-env (add-vars sym v-env)))
+ (_
+ ;; $kclause, $kfun, and $ktail are only ever seen in $fun.
+ (error "unexpected cont body" cont))))
+
+ (define (visit-clause clause k-env v-env)
+ (match clause
+ (($ $cont kclause
+ ($ $kclause
+ ($ $arity
+ ((? symbol? req) ...)
+ ((? symbol? opt) ...)
+ (and rest (or #f (? symbol?)))
+ (((? keyword? kw) (? symbol? kwname) kwsym) ...)
+ (or #f #t))
+ ($ $cont kbody (and body ($ $kargs names syms _)))
+ alternate))
+ (for-each (lambda (sym)
+ (unless (memq sym syms)
+ (error "bad keyword sym" sym)))
+ kwsym)
+ ;; FIXME: It is technically possible for kw syms to alias other
+ ;; syms.
+ (unless (equal? (append req opt (if rest (list rest) '()) kwname)
+ names)
+ (error "clause body names do not match arity names" exp))
+ (let ((k-env (add-labels (list kclause kbody) k-env)))
+ (visit-cont-body body k-env v-env))
+ (when alternate
+ (visit-clause alternate k-env v-env)))
+ (_
+ (error "unexpected clause" clause))))
+
+ (define (visit-entry entry k-env v-env)
+ (match entry
+ (($ $cont kbody
+ ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
+ (when (and meta (not (and (list? meta) (and-map pair? meta))))
+ (error "meta should be alist" meta))
+ (check-src src)
+ ;; Reset the continuation environment, because Guile's
+ ;; continuations are local.
+ (let ((v-env (add-vars (list self) v-env))
+ (k-env (add-labels (list ktail) '())))
+ (when clause
+ (visit-clause clause k-env v-env))))
+ (_ (error "unexpected $kfun" entry))))
+
+ (define (visit-fun fun k-env v-env)
+ (match fun
+ (($ $fun (free ...) entry)
+ (for-each (cut check-var <> v-env) free)
+ (visit-entry '() v-env))
+ (_
+ (error "unexpected $fun" fun))))
+
+ (define (visit-expression exp k-env v-env)
+ (match exp
+ (($ $void)
+ #t)
+ (($ $const val)
+ #t)
+ (($ $prim (? symbol? name))
+ #t)
+ (($ $closure kfun n)
+ #t)
+ (($ $fun)
+ (visit-fun exp k-env v-env))
+ (($ $call proc (arg ...))
+ (check-var proc v-env)
+ (for-each (cut check-var <> v-env) arg))
+ (($ $callk k* proc (arg ...))
+ ;; We don't check that k* is in scope; it's actually inside some
+ ;; other function, probably. We rely on the transformation that
+ ;; introduces the $callk to be correct, and the linker to resolve
+ ;; the reference.
+ (check-var proc v-env)
+ (for-each (cut check-var <> v-env) arg))
+ (($ $branch kt ($ $primcall (? symbol? name) (arg ...)))
+ (check-var kt k-env)
+ (for-each (cut check-var <> v-env) arg))
+ (($ $branch kt ($ $values (arg ...)))
+ (check-var kt k-env)
+ (for-each (cut check-var <> v-env) arg))
+ (($ $primcall (? symbol? name) (arg ...))
+ (for-each (cut check-var <> v-env) arg))
+ (($ $values (arg ...))
+ (for-each (cut check-var <> v-env) arg))
+ (($ $prompt escape? tag handler)
+ (unless (boolean? escape?) (error "escape? should be boolean" escape?))
+ (check-var tag v-env)
+ (check-label handler k-env))
+ (_
+ (error "unexpected expression" exp))))
+
+ (define (visit-term term k-env v-env)
+ (match term
+ (($ $letk (($ $cont k cont) ...) body)
+ (let ((k-env (add-labels k k-env)))
+ (for-each (cut visit-cont-body <> k-env v-env) cont)
+ (visit-term body k-env v-env)))
+
+ (($ $letrec (name ...) (sym ...) (fun ...) body)
+ (unless (= (length name) (length sym) (length fun))
+ (error "letrec syms, names, and funs not same length" term))
+ (let ((v-env (add-vars sym v-env)))
+ (for-each (cut visit-fun <> k-env v-env) fun)
+ (visit-term body k-env v-env)))
+
+ (($ $continue k src exp)
+ (check-label k k-env)
+ (check-src src)
+ (visit-expression exp k-env v-env))
+
+ (_
+ (error "unexpected term" term))))
+
+ (visit-entry fun '() '())
+ fun)
(-> (@ '(language ecmascript impl) 'sym)))
(define-syntax-rule (@impl sym arg ...)
- (-> (apply (@implv sym) arg ...)))
+ (-> (call (@implv sym) arg ...)))
(define (empty-lexical-environment)
'())
(parameterize ((current-return-tag
(-> (lexical 'return tag))))
(-> (let '(return) (list tag)
- (list (-> (apply (-> (primitive 'make-prompt-tag)))))
- (-> (prompt (current-return-tag)
+ (list (-> (primcall 'make-prompt-tag)))
+ (-> (prompt #t
+ (current-return-tag)
(body-thunk)
(let ((val (gensym "val")))
- (-> (lambda-case
- `(((k val) #f #f #f () (,(gensym) ,val))
- ,(-> (lexical 'val val)))))))))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `(((k val) #f #f #f () (,(gensym) ,val))
+ ,(-> (lexical 'val val)))))))))))))))
(define (comp x e)
(let ((l (location x)))
(this
(@impl get-this))
((+ ,a)
- (-> (apply (-> (primitive '+))
- (@impl ->number (comp a e))
- (-> (const 0)))))
+ (-> (call (-> (primitive '+))
+ (@impl ->number (comp a e))
+ (-> (const 0)))))
((- ,a)
- (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
+ (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
((~ ,a)
(@impl bitwise-not (comp a e)))
((! ,a)
(@impl logical-not (comp a e)))
((+ ,a ,b)
- (-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
((- ,a ,b)
- (-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
((/ ,a ,b)
- (-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
((* ,a ,b)
- (-> (apply (-> (primitive '*)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
((% ,a ,b)
(@impl mod (comp a e) (comp b e)))
((<< ,a ,b)
((>> ,a ,b)
(@impl shift (comp a e) (comp `(- ,b) e)))
((< ,a ,b)
- (-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
((<= ,a ,b)
- (-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
((> ,a ,b)
- (-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
((>= ,a ,b)
- (-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
((in ,a ,b)
(@impl has-property? (comp a e) (comp b e)))
((== ,a ,b)
- (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
((!= ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'equal?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'equal?))
+ (comp a e) (comp b e))))))
((=== ,a ,b)
- (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
((!== ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'eqv?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'eqv?))
+ (comp a e) (comp b e))))))
((& ,a ,b)
(@impl band (comp a e) (comp b e)))
((^ ,a ,b)
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set! (lookup foo e)
- (-> (apply (-> (primitive '+))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postinc (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (lexical propvar propvar))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
((postdec (ref ,foo))
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set (lookup foo e)
- (-> (apply (-> (primitive '-))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postdec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '-))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postdec (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '+))
- v
- (-> (const 1))))))
+ (-> (call (-> (primitive '+))
+ v
+ (-> (const 1))))))
v))))
((preinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput (-> (lexical objvar objvar))
(-> (const prop))
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '-))
+ (-> (call (-> (primitive '-))
v
(-> (const 1))))))
v))))
((predec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (lambda '()
`(lambda-case
((() #f #f #f () ())
- (apply ,(@impl pget obj prop) ,@args)))))))
+ (call ,(@impl pget obj prop) ,@args)))))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (const prop))
,@(map (lambda (x) (comp x e)) args))
e))
((call ,proc ,args)
- `(apply ,(comp proc e)
- ,@(map (lambda (x) (comp x e)) args)))
+ `(call ,(comp proc e)
+ ,@(map (lambda (x) (comp x e)) args)))
((return ,expr)
(return (comp expr e)))
((array . ,args)
- `(apply ,(@implv new-array)
- ,@(map (lambda (x) (comp x e)) args)))
+ `(call ,(@implv new-array)
+ ,@(map (lambda (x) (comp x e)) args)))
((object . ,args)
- `(apply ,(@implv new-object)
- ,@(map (lambda (x)
- (pmatch x
- ((,prop ,val)
- (-> (apply (-> (primitive 'cons))
- (-> (const prop))
- (comp val e))))
- (else
- (error "bad prop-val pair" x))))
- args)))
+ `(call ,(@implv new-object)
+ ,@(map (lambda (x)
+ (pmatch x
+ ((,prop ,val)
+ (-> (call (-> (primitive 'cons))
+ (-> (const prop))
+ (comp val e))))
+ (else
+ (error "bad prop-val pair" x))))
+ args)))
((pref ,obj ,prop)
(@impl pget
(comp obj e)
`((() #f #f #f () ())
,(-> (begin
(comp statement e)
- (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))))
(-> (lambda '()
(-> (lambda-case
`((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e))
- (-> (apply (-> (lexical '%loop %loop))))
+ (-> (call (-> (lexical '%loop %loop))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%loop %loop)))))))))
+ (-> (call (-> (lexical '%loop %loop)))))))))
((while ,test ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
`((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e))
(-> (begin (comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
((for ,init ,test ,inc ,statement)
(let ((%continue (gensym "%continue ")))
(comp 'true e))
(-> (begin (comp statement e)
(comp (or inc '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
(-> (begin (comp (or init '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))))
((for-in ,var ,object ,statement)
(let ((%enum (gensym "%enum "))
,(-> (const 'pop))))
e)
(comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
((block ,x)
(comp x e))
;;; Code:
(define-module (language elisp bindings)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
#:export (make-bindings
- mark-global-needed!
- map-globals-needed
with-lexical-bindings
with-dynamic-bindings
- get-lexical-binding))
+ with-function-bindings
+ get-lexical-binding
+ get-function-binding))
;;; This module defines routines to handle analysis of symbol bindings
;;; used during elisp compilation. This data allows to collect the
;;; symbols, for which globals need to be created, or mark certain
;;; symbols as lexically bound.
;;;
-;;; Needed globals are stored in an association-list that stores a list
-;;; of symbols for each module they are needed in.
-;;;
;;; The lexical bindings of symbols are stored in a hash-table that
;;; associates symbols to fluids; those fluids are used in the
;;; with-lexical-binding and with-dynamic-binding routines to associate
;;; Record type used to hold the data necessary.
-(define bindings-type
- (make-record-type 'bindings '(needed-globals lexical-bindings)))
+(define-record-type bindings
+ (%make-bindings lexical-bindings function-bindings)
+ bindings?
+ (lexical-bindings lexical-bindings)
+ (function-bindings function-bindings))
;;; Construct an 'empty' instance of the bindings data structure to be
;;; used at the start of a fresh compilation.
(define (make-bindings)
- ((record-constructor bindings-type) '() (make-hash-table)))
-
-;;; Mark that a given symbol is needed as global in the specified
-;;; slot-module.
-
-(define (mark-global-needed! bindings sym module)
- (let* ((old-needed ((record-accessor bindings-type 'needed-globals)
- bindings))
- (old-in-module (or (assoc-ref old-needed module) '()))
- (new-in-module (if (memq sym old-in-module)
- old-in-module
- (cons sym old-in-module)))
- (new-needed (assoc-set! old-needed module new-in-module)))
- ((record-modifier bindings-type 'needed-globals)
- bindings
- new-needed)))
-
-;;; Cycle through all globals needed in order to generate the code for
-;;; their creation or some other analysis.
-
-(define (map-globals-needed bindings proc)
- (let ((needed ((record-accessor bindings-type 'needed-globals)
- bindings)))
- (let iterate-modules ((mod-tail needed)
- (mod-result '()))
- (if (null? mod-tail)
- mod-result
- (iterate-modules
- (cdr mod-tail)
- (let* ((aentry (car mod-tail))
- (module (car aentry))
- (symbols (cdr aentry)))
- (let iterate-symbols ((sym-tail symbols)
- (sym-result mod-result))
- (if (null? sym-tail)
- sym-result
- (iterate-symbols (cdr sym-tail)
- (cons (proc module (car sym-tail))
- sym-result))))))))))
+ (%make-bindings (make-hash-table) (make-hash-table)))
;;; Get the current lexical binding (gensym it should refer to in the
;;; current scope) for a symbol or #f if it is dynamically bound.
(define (get-lexical-binding bindings sym)
- (let* ((lex ((record-accessor bindings-type 'lexical-bindings)
- bindings))
+ (let* ((lex (lexical-bindings bindings))
(slot (hash-ref lex sym #f)))
(if slot
(fluid-ref slot)
#f)))
+(define (get-function-binding bindings symbol)
+ (and=> (hash-ref (function-bindings bindings) symbol)
+ fluid-ref))
+
;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc.
(if (or (not (list? syms))
(not (and-map symbol? syms)))
(error "can't bind non-symbols" syms))
- (let ((lex ((record-accessor bindings-type 'lexical-bindings)
- bindings)))
+ (let ((lex (lexical-bindings bindings)))
(for-each (lambda (sym)
(if (not (hash-ref lex sym))
(hash-set! lex sym (make-fluid))))
syms
(map (lambda (el) #f) syms)
proc))
+
+(define (with-function-bindings bindings symbols gensyms thunk)
+ (let ((fb (function-bindings bindings)))
+ (for-each (lambda (symbol)
+ (if (not (hash-ref fb symbol))
+ (hash-set! fb symbol (make-fluid))))
+ symbols)
+ (with-fluids* (map (cut hash-ref fb <>) symbols)
+ gensyms
+ thunk)))
--- /dev/null
+;;; Guile Emacs Lisp -*- lexical-binding: t -*-
+
+;;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;;; This library is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public 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:
+
+(defmacro @ (module symbol)
+ `(guile-ref ,module ,symbol))
+
+(defmacro eval-and-compile (&rest body)
+ `(progn
+ (eval-when-compile ,@body)
+ (progn ,@body)))
+
+(eval-and-compile
+ (defun null (object)
+ (if object nil t))
+ (defun consp (object)
+ (%funcall (@ (guile) pair?) object))
+ (defun listp (object)
+ (if object (consp object) t))
+ (defun car (list)
+ (if list (%funcall (@ (guile) car) list) nil))
+ (defun cdr (list)
+ (if list (%funcall (@ (guile) cdr) list) nil))
+ (defun make-symbol (name)
+ (%funcall (@ (guile) make-symbol) name))
+ (defun signal (error-symbol data)
+ (%funcall (@ (guile) throw) 'elisp-condition error-symbol data)))
+
+(defmacro lambda (&rest cdr)
+ `#'(lambda ,@cdr))
+
+(defmacro prog1 (first &rest body)
+ (let ((temp (make-symbol "prog1-temp")))
+ `(let ((,temp ,first))
+ (declare (lexical ,temp))
+ ,@body
+ ,temp)))
+
+(defmacro prog2 (form1 form2 &rest body)
+ `(progn ,form1 (prog1 ,form2 ,@body)))
+
+(defmacro cond (&rest clauses)
+ (if (null clauses)
+ nil
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (listp first)
+ (let ((condition (car first))
+ (body (cdr first)))
+ (if (null body)
+ (let ((temp (make-symbol "cond-temp")))
+ `(let ((,temp ,condition))
+ (declare (lexical ,temp))
+ (if ,temp
+ ,temp
+ (cond ,@rest))))
+ `(if ,condition
+ (progn ,@body)
+ (cond ,@rest))))
+ (signal 'wrong-type-argument `(listp ,first))))))
+
+(defmacro and (&rest conditions)
+ (cond ((null conditions) t)
+ ((null (cdr conditions)) (car conditions))
+ (t `(if ,(car conditions)
+ (and ,@(cdr conditions))
+ nil))))
+
+(defmacro or (&rest conditions)
+ (cond ((null conditions) nil)
+ ((null (cdr conditions)) (car conditions))
+ (t (let ((temp (make-symbol "or-temp")))
+ `(let ((,temp ,(car conditions)))
+ (declare (lexical ,temp))
+ (if ,temp
+ ,temp
+ (or ,@(cdr conditions))))))))
+
+(defmacro lexical-let (bindings &rest body)
+ (labels ((loop (list vars)
+ (if (null list)
+ `(let ,bindings
+ (declare (lexical ,@vars))
+ ,@body)
+ (loop (cdr list)
+ (if (consp (car list))
+ `(,(car (car list)) ,@vars)
+ `(,(car list) ,@vars))))))
+ (loop bindings '())))
+
+(defmacro lexical-let* (bindings &rest body)
+ (labels ((loop (list vars)
+ (if (null list)
+ `(let* ,bindings
+ (declare (lexical ,@vars))
+ ,@body)
+ (loop (cdr list)
+ (if (consp (car list))
+ (cons (car (car list)) vars)
+ (cons (car list) vars))))))
+ (loop bindings '())))
+
+(defmacro while (test &rest body)
+ (let ((loop (make-symbol "loop")))
+ `(labels ((,loop ()
+ (if ,test
+ (progn ,@body (,loop))
+ nil)))
+ (,loop))))
+
+(defmacro unwind-protect (bodyform &rest unwindforms)
+ `(funcall (@ (guile) dynamic-wind)
+ #'(lambda () nil)
+ #'(lambda () ,bodyform)
+ #'(lambda () ,@unwindforms)))
+
+(defmacro when (cond &rest body)
+ `(if ,cond
+ (progn ,@body)))
+
+(defmacro unless (cond &rest body)
+ `(when (not ,cond)
+ ,@body))
+
+(defun symbolp (object)
+ (%funcall (@ (guile) symbol?) object))
+
+(defun functionp (object)
+ (%funcall (@ (guile) procedure?) object))
+
+(defun symbol-function (symbol)
+ (let ((f (%funcall (@ (language elisp runtime) symbol-function)
+ symbol)))
+ (if (%funcall (@ (language elisp falias) falias?) f)
+ (%funcall (@ (language elisp falias) falias-object) f)
+ f)))
+
+(defun eval (form)
+ (%funcall (@ (system base compile) compile)
+ form
+ (%funcall (@ (guile) symbol->keyword) 'from)
+ 'elisp
+ (%funcall (@ (guile) symbol->keyword) 'to)
+ 'value))
+
+(defun %indirect-function (object)
+ (cond
+ ((functionp object)
+ object)
+ ((symbolp object) ;++ cycle detection
+ (%indirect-function (symbol-function object)))
+ ((listp object)
+ (eval `(function ,object)))
+ (t
+ (signal 'invalid-function `(,object)))))
+
+(defun apply (function &rest arguments)
+ (%funcall (@ (guile) apply)
+ (@ (guile) apply)
+ (%indirect-function function)
+ arguments))
+
+(defun funcall (function &rest arguments)
+ (%funcall (@ (guile) apply)
+ (%indirect-function function)
+ arguments))
+
+(defun fset (symbol definition)
+ (funcall (@ (language elisp runtime) set-symbol-function!)
+ symbol
+ (if (functionp definition)
+ definition
+ (funcall (@ (language elisp falias) make-falias)
+ #'(lambda (&rest args) (apply definition args))
+ definition)))
+ definition)
+
+(defun load (file)
+ (funcall (@ (system base compile) compile-file)
+ file
+ (funcall (@ (guile) symbol->keyword) 'from)
+ 'elisp
+ (funcall (@ (guile) symbol->keyword) 'to)
+ 'value)
+ t)
+
+;;; Equality predicates
+
+(defun eq (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) eq?) obj1 obj2)
+ (null obj2)))
+
+(defun eql (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) eqv?) obj1 obj2)
+ (null obj2)))
+
+(defun equal (obj1 obj2)
+ (if obj1
+ (funcall (@ (guile) equal?) obj1 obj2)
+ (null obj2)))
+
+;;; Symbols
+
+;;; `symbolp' and `symbol-function' are defined above.
+
+(fset 'symbol-name (@ (guile) symbol->string))
+(fset 'symbol-value (@ (language elisp runtime) symbol-value))
+(fset 'set (@ (language elisp runtime) set-symbol-value!))
+(fset 'makunbound (@ (language elisp runtime) makunbound!))
+(fset 'fmakunbound (@ (language elisp runtime) fmakunbound!))
+(fset 'boundp (@ (language elisp runtime) symbol-bound?))
+(fset 'fboundp (@ (language elisp runtime) symbol-fbound?))
+(fset 'intern (@ (guile) string->symbol))
+
+(defun defvaralias (new-alias base-variable &optional docstring)
+ (let ((fluid (funcall (@ (language elisp runtime) symbol-fluid)
+ base-variable)))
+ (funcall (@ (language elisp runtime) set-symbol-fluid!)
+ new-alias
+ fluid)
+ base-variable))
+
+;;; Numerical type predicates
+
+(defun floatp (object)
+ (and (funcall (@ (guile) real?) object)
+ (or (funcall (@ (guile) inexact?) object)
+ (null (funcall (@ (guile) integer?) object)))))
+
+(defun integerp (object)
+ (and (funcall (@ (guile) integer?) object)
+ (funcall (@ (guile) exact?) object)))
+
+(defun numberp (object)
+ (funcall (@ (guile) real?) object))
+
+(defun wholenump (object)
+ (and (integerp object) (>= object 0)))
+
+(defun zerop (object)
+ (= object 0))
+
+;;; Numerical comparisons
+
+(fset '= (@ (guile) =))
+
+(defun /= (num1 num2)
+ (null (= num1 num2)))
+
+(fset '< (@ (guile) <))
+(fset '<= (@ (guile) <=))
+(fset '> (@ (guile) >))
+(fset '>= (@ (guile) >=))
+
+(defun max (&rest numbers)
+ (apply (@ (guile) max) numbers))
+
+(defun min (&rest numbers)
+ (apply (@ (guile) min) numbers))
+
+;;; Arithmetic functions
+
+(fset '1+ (@ (guile) 1+))
+(fset '1- (@ (guile) 1-))
+(fset '+ (@ (guile) +))
+(fset '- (@ (guile) -))
+(fset '* (@ (guile) *))
+(fset '% (@ (guile) modulo))
+(fset 'abs (@ (guile) abs))
+
+;;; Floating-point rounding
+
+(fset 'ffloor (@ (guile) floor))
+(fset 'fceiling (@ (guile) ceiling))
+(fset 'ftruncate (@ (guile) truncate))
+(fset 'fround (@ (guile) round))
+
+;;; Numeric conversion
+
+(defun float (arg)
+ (if (numberp arg)
+ (funcall (@ (guile) exact->inexact) arg)
+ (signal 'wrong-type-argument `(numberp ,arg))))
+
+;;; List predicates
+
+(fset 'not #'null)
+
+(defun atom (object)
+ (null (consp object)))
+
+(defun nlistp (object)
+ (null (listp object)))
+
+;;; Lists
+
+(fset 'cons (@ (guile) cons))
+(fset 'list (@ (guile) list))
+(fset 'make-list (@ (guile) make-list))
+(fset 'append (@ (guile) append))
+(fset 'reverse (@ (guile) reverse))
+(fset 'nreverse (@ (guile) reverse!))
+
+(defun car-safe (object)
+ (if (consp object)
+ (car object)
+ nil))
+
+(defun cdr-safe (object)
+ (if (consp object)
+ (cdr object)
+ nil))
+
+(defun setcar (cell newcar)
+ (if (consp cell)
+ (progn
+ (funcall (@ (guile) set-car!) cell newcar)
+ newcar)
+ (signal 'wrong-type-argument `(consp ,cell))))
+
+(defun setcdr (cell newcdr)
+ (if (consp cell)
+ (progn
+ (funcall (@ (guile) set-cdr!) cell newcdr)
+ newcdr)
+ (signal 'wrong-type-argument `(consp ,cell))))
+
+(defun nthcdr (n list)
+ (let ((i 0))
+ (while (< i n)
+ (setq list (cdr list)
+ i (+ i 1)))
+ list))
+
+(defun nth (n list)
+ (car (nthcdr n list)))
+
+(defun %member (elt list test)
+ (cond
+ ((null list) nil)
+ ((consp list)
+ (if (funcall test elt (car list))
+ list
+ (%member elt (cdr list) test)))
+ (t (signal 'wrong-type-argument `(listp ,list)))))
+
+(defun member (elt list)
+ (%member elt list #'equal))
+
+(defun memql (elt list)
+ (%member elt list #'eql))
+
+(defun memq (elt list)
+ (%member elt list #'eq))
+
+(defun assoc (key list)
+ (funcall (@ (srfi srfi-1) assoc) key list #'equal))
+
+(defun assq (key list)
+ (funcall (@ (srfi srfi-1) assoc) key list #'eq))
+
+(defun rplaca (cell newcar)
+ (funcall (@ (guile) set-car!) cell newcar)
+ newcar)
+
+(defun rplacd (cell newcdr)
+ (funcall (@ (guile) set-cdr!) cell newcdr)
+ newcdr)
+
+(defun caar (x)
+ (car (car x)))
+
+(defun cadr (x)
+ (car (cdr x)))
+
+(defun cdar (x)
+ (cdr (car x)))
+
+(defun cddr (x)
+ (cdr (cdr x)))
+
+(defmacro dolist (spec &rest body)
+ (apply #'(lambda (var list &optional result)
+ `(mapc #'(lambda (,var)
+ ,@body
+ ,result)
+ ,list))
+ spec))
+
+;;; Strings
+
+(defun string (&rest characters)
+ (funcall (@ (guile) list->string)
+ (mapcar (@ (guile) integer->char) characters)))
+
+(defun stringp (object)
+ (funcall (@ (guile) string?) object))
+
+(defun string-equal (s1 s2)
+ (let ((s1 (if (symbolp s1) (symbol-name s1) s1))
+ (s2 (if (symbolp s2) (symbol-name s2) s2)))
+ (funcall (@ (guile) string=?) s1 s2)))
+
+(fset 'string= 'string-equal)
+
+(defun substring (string from &optional to)
+ (apply (@ (guile) substring) string from (if to (list to) nil)))
+
+(defun upcase (obj)
+ (funcall (@ (guile) string-upcase) obj))
+
+(defun downcase (obj)
+ (funcall (@ (guile) string-downcase) obj))
+
+(defun string-match (regexp string &optional start)
+ (let ((m (funcall (@ (ice-9 regex) string-match)
+ regexp
+ string
+ (or start 0))))
+ (if m
+ (funcall (@ (ice-9 regex) match:start) m 0)
+ nil)))
+
+;; Vectors
+
+(defun make-vector (length init)
+ (funcall (@ (guile) make-vector) length init))
+
+;;; Sequences
+
+(defun length (sequence)
+ (funcall (if (listp sequence)
+ (@ (guile) length)
+ (@ (guile) generalized-vector-length))
+ sequence))
+
+(defun mapcar (function sequence)
+ (funcall (@ (guile) map) function sequence))
+
+(defun mapc (function sequence)
+ (funcall (@ (guile) for-each) function sequence)
+ sequence)
+
+(defun aref (array idx)
+ (funcall (@ (guile) generalized-vector-ref) array idx))
+
+(defun aset (array idx newelt)
+ (funcall (@ (guile) generalized-vector-set!) array idx newelt)
+ newelt)
+
+(defun concat (&rest sequences)
+ (apply (@ (guile) string-append) sequences))
+
+;;; Property lists
+
+(defun %plist-member (plist property test)
+ (cond
+ ((null plist) nil)
+ ((consp plist)
+ (if (funcall test (car plist) property)
+ (cdr plist)
+ (%plist-member (cdr (cdr plist)) property test)))
+ (t (signal 'wrong-type-argument `(listp ,plist)))))
+
+(defun %plist-get (plist property test)
+ (car (%plist-member plist property test)))
+
+(defun %plist-put (plist property value test)
+ (let ((x (%plist-member plist property test)))
+ (if x
+ (progn (setcar x value) plist)
+ (cons property (cons value plist)))))
+
+(defun plist-get (plist property)
+ (%plist-get plist property #'eq))
+
+(defun plist-put (plist property value)
+ (%plist-put plist property value #'eq))
+
+(defun plist-member (plist property)
+ (%plist-member plist property #'eq))
+
+(defun lax-plist-get (plist property)
+ (%plist-get plist property #'equal))
+
+(defun lax-plist-put (plist property value)
+ (%plist-put plist property value #'equal))
+
+(defvar plist-function (funcall (@ (guile) make-object-property)))
+
+(defun symbol-plist (symbol)
+ (funcall plist-function symbol))
+
+(defun setplist (symbol plist)
+ (funcall (funcall (@ (guile) setter) plist-function) symbol plist))
+
+(defun get (symbol propname)
+ (plist-get (symbol-plist symbol) propname))
+
+(defun put (symbol propname value)
+ (setplist symbol (plist-put (symbol-plist symbol) propname value)))
+
+;;; Nonlocal exits
+
+(defmacro condition-case (var bodyform &rest handlers)
+ (let ((key (make-symbol "key"))
+ (error-symbol (make-symbol "error-symbol"))
+ (data (make-symbol "data"))
+ (conditions (make-symbol "conditions")))
+ (flet ((handler->cond-clause (handler)
+ `((or ,@(mapcar #'(lambda (c) `(memq ',c ,conditions))
+ (if (consp (car handler))
+ (car handler)
+ (list (car handler)))))
+ ,@(cdr handler))))
+ `(funcall (@ (guile) catch)
+ 'elisp-condition
+ #'(lambda () ,bodyform)
+ #'(lambda (,key ,error-symbol ,data)
+ (declare (lexical ,key ,error-symbol ,data))
+ (let ((,conditions
+ (get ,error-symbol 'error-conditions))
+ ,@(if var
+ `((,var (cons ,error-symbol ,data)))
+ '()))
+ (declare (lexical ,conditions
+ ,@(if var `(,var) '())))
+ (cond ,@(mapcar #'handler->cond-clause handlers)
+ (t (signal ,error-symbol ,data)))))))))
+
+(put 'error 'error-conditions '(error))
+(put 'wrong-type-argument 'error-conditions '(wrong-type-argument error))
+(put 'invalid-function 'error-conditions '(invalid-function error))
+(put 'no-catch 'error-conditions '(no-catch error))
+(put 'throw 'error-conditions '(throw))
+
+(defvar %catch nil)
+
+(defmacro catch (tag &rest body)
+ (let ((tag-value (make-symbol "tag-value"))
+ (c (make-symbol "c"))
+ (data (make-symbol "data")))
+ `(let ((,tag-value ,tag))
+ (declare (lexical ,tag-value))
+ (condition-case ,c
+ (let ((%catch t))
+ ,@body)
+ (throw
+ (let ((,data (cdr ,c)))
+ (declare (lexical ,data))
+ (if (eq (car ,data) ,tag-value)
+ (car (cdr ,data))
+ (apply #'throw ,data))))))))
+
+(defun throw (tag value)
+ (signal (if %catch 'throw 'no-catch) (list tag value)))
+
+;;; I/O
+
+(defun princ (object)
+ (funcall (@ (guile) display) object))
+
+(defun print (object)
+ (funcall (@ (guile) write) object))
+
+(defun terpri ()
+ (funcall (@ (guile) newline)))
+
+(defun format* (stream string &rest args)
+ (apply (@ (guile) format) stream string args))
+
+(defun send-string-to-terminal (string)
+ (princ string))
+
+(defun read-from-minibuffer (prompt &rest ignore)
+ (princ prompt)
+ (let ((value (funcall (@ (ice-9 rdelim) read-line))))
+ (if (funcall (@ (guile) eof-object?) value)
+ ""
+ value)))
+
+(defun prin1-to-string (object)
+ (format* nil "~S" object))
+
+;; Random number generation
+
+(defvar %random-state (funcall (@ (guile) copy-random-state)
+ (@ (guile) *random-state*)))
+
+(defun random (&optional limit)
+ (if (eq limit t)
+ (setq %random-state
+ (funcall (@ (guile) random-state-from-platform))))
+ (funcall (@ (guile) random)
+ (if (wholenump limit)
+ limit
+ (@ (guile) most-positive-fixnum))
+ %random-state))
-;;; Guile Emacs Lisp
-
-;; Copyright (C) 2009, 2010 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, 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.
-
-;;; Code:
-
-(define-module (language elisp compile-tree-il)
- #:use-module (language elisp bindings)
- #:use-module (language elisp runtime)
- #:use-module (language tree-il)
- #:use-module (system base pmatch)
- #:use-module (system base compile)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-8)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:export (compile-tree-il
- compile-progn
- compile-if
- compile-defconst
- compile-defvar
- compile-setq
- compile-let
- compile-lexical-let
- compile-flet
- compile-let*
- compile-lexical-let*
- compile-flet*
- compile-without-void-checks
- compile-with-always-lexical
- compile-guile-ref
- compile-guile-primitive
- compile-while
- compile-function
- compile-defmacro
- compile-defun
- #{compile-`}#
- compile-quote))
-
-;;; Certain common parameters (like the bindings data structure or
-;;; compiler options) are not always passed around but accessed using
-;;; fluids to simulate dynamic binding (hey, this is about elisp).
-
-;;; The bindings data structure to keep track of symbol binding related
-;;; data.
-
-(define bindings-data (make-fluid))
-
-;;; Store for which symbols (or all/none) void checks are disabled.
-
-(define disable-void-check (make-fluid))
-
-;;; Store which symbols (or all/none) should always be bound lexically,
-;;; even with ordinary let and as lambda arguments.
-
-(define always-lexical (make-fluid))
-
-;;; Find the source properties of some parsed expression if there are
-;;; any associated with it.
-
-(define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- props))))
-
-;;; Values to use for Elisp's nil and t.
-
-(define (nil-value loc)
- (make-const loc (@ (language elisp runtime) nil-value)))
-
-(define (t-value loc)
- (make-const loc (@ (language elisp runtime) t-value)))
-
-;;; Modules that contain the value and function slot bindings.
-
-(define runtime '(language elisp runtime))
-
-(define value-slot (@ (language elisp runtime) value-slot-module))
-
-(define function-slot (@ (language elisp runtime) function-slot-module))
-
-;;; The backquoting works the same as quasiquotes in Scheme, but the
-;;; forms are named differently; to make easy adaptions, we define these
-;;; predicates checking for a symbol being the car of an
-;;; unquote/unquote-splicing/backquote form.
-
-(define (unquote? sym)
- (and (symbol? sym) (eq? sym '#{,}#)))
-
-(define (unquote-splicing? sym)
- (and (symbol? sym) (eq? sym '#{,@}#)))
-
-;;; Build a call to a primitive procedure nicely.
-
-(define (call-primitive loc sym . args)
- (make-application loc (make-primitive-ref loc sym) args))
-
-;;; Error reporting routine for syntax/compilation problems or build
-;;; code for a runtime-error output.
-
-(define (report-error loc . args)
- (apply error args))
-
-(define (runtime-error loc msg . args)
- (make-application loc
- (make-primitive-ref loc 'error)
- (cons (make-const loc msg) args)))
-
-;;; Generate code to ensure a global symbol is there for further use of
-;;; a given symbol. In general during the compilation, those needed are
-;;; only tracked with the bindings data structure. Afterwards, however,
-;;; for all those needed symbols the globals are really generated with
-;;; this routine.
-
-(define (generate-ensure-global loc sym module)
- (make-application loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc module)
- (make-const loc sym))))
-
-(define (ensuring-globals loc bindings body)
- (make-sequence
- loc
- `(,@(map-globals-needed (fluid-ref bindings)
- (lambda (mod sym)
- (generate-ensure-global loc sym mod)))
- ,body)))
-
-;;; Build a construct that establishes dynamic bindings for certain
-;;; variables. We may want to choose between binding with fluids and
-;;; with-fluids* and using just ordinary module symbols and
-;;; setting/reverting their values with a dynamic-wind.
-
-(define (let-dynamic loc syms module vals body)
- (call-primitive
- loc
- 'with-fluids*
- (make-application loc
- (make-primitive-ref loc 'list)
- (map (lambda (sym)
- (make-module-ref loc module sym #t))
- syms))
- (make-application loc (make-primitive-ref loc 'list) vals)
- (make-lambda loc
- '()
- (make-lambda-case #f '() #f #f #f '() '() body #f))))
-
-;;; Handle access to a variable (reference/setting) correctly depending
-;;; on whether it is currently lexically or dynamically bound. lexical
-;;; access is done only for references to the value-slot module!
-
-(define (access-variable loc
- sym
- module
- handle-global
- handle-lexical
- handle-dynamic)
- (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
- (cond
- (lexical (handle-lexical lexical))
- ((equal? module function-slot) (handle-global))
- (else (handle-dynamic)))))
-
-;;; Generate code to reference a variable. For references in the
-;;; value-slot module, we may want to generate a lexical reference
-;;; instead if the variable has a lexical binding.
-
-(define (reference-variable loc sym module)
- (access-variable
- loc
- sym
- module
- (lambda () (make-module-ref loc module sym #t))
- (lambda (lexical) (make-lexical-ref loc lexical lexical))
- (lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
- (call-primitive loc
- 'fluid-ref
- (make-module-ref loc module sym #t)))))
-
-;;; Generate code to set a variable. Just as with reference-variable, in
-;;; case of a reference to value-slot, we want to generate a lexical set
-;;; when the variable has a lexical binding.
-
-(define (set-variable! loc sym module value)
- (access-variable
- loc
- sym
- module
- (lambda ()
- (make-application
- loc
- (make-module-ref loc runtime 'set-variable! #t)
- (list (make-const loc module) (make-const loc sym) value)))
- (lambda (lexical) (make-lexical-set loc lexical lexical value))
- (lambda ()
- (mark-global-needed! (fluid-ref bindings-data) sym module)
- (call-primitive loc
- 'fluid-set!
- (make-module-ref loc module sym #t)
- value))))
-
-;;; Process the bindings part of a let or let* expression; that is,
-;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
-;;; . val2) ...).
-
-(define (process-let-bindings loc bindings)
- (map
- (lambda (b)
- (if (symbol? b)
- (cons b 'nil)
- (if (or (not (list? b))
- (not (= (length b) 2)))
- (report-error
- loc
- "expected symbol or list of 2 elements in let")
- (if (not (symbol? (car b)))
- (report-error loc "expected symbol in let")
- (cons (car b) (cadr b))))))
- bindings))
-
-;;; Split the let bindings into a list to be done lexically and one
-;;; dynamically. A symbol will be bound lexically if and only if: We're
-;;; processing a lexical-let (i.e. module is 'lexical), OR we're
-;;; processing a value-slot binding AND the symbol is already lexically
-;;; bound or is always lexical, OR we're processing a function-slot
-;;; binding.
-
-(define (bind-lexically? sym module)
- (or (eq? module 'lexical)
- (eq? module function-slot)
- (and (equal? module value-slot)
- (let ((always (fluid-ref always-lexical)))
- (or (eq? always 'all)
- (memq sym always)
- (get-lexical-binding (fluid-ref bindings-data) sym))))))
-
-(define (split-let-bindings bindings module)
- (let iterate ((tail bindings)
- (lexical '())
- (dynamic '()))
- (if (null? tail)
- (values (reverse lexical) (reverse dynamic))
- (if (bind-lexically? (caar tail) module)
- (iterate (cdr tail) (cons (car tail) lexical) dynamic)
- (iterate (cdr tail) lexical (cons (car tail) dynamic))))))
-
-;;; Compile let and let* expressions. The code here is used both for
-;;; let/let* and flet/flet*, just with a different bindings module.
-;;;
-;;; A special module value 'lexical means that we're doing a lexical-let
-;;; instead and the bindings should not be saved to globals at all but
-;;; be done with the lexical framework instead.
-
-;;; Let is done with a single call to let-dynamic binding them locally
-;;; to new values all "at once". If there is at least one variable to
-;;; bind lexically among the bindings, we first do a let for all of them
-;;; to evaluate all values before any bindings take place, and then call
-;;; let-dynamic for the variables to bind dynamically.
-
-(define (generate-let loc module bindings body)
- (let ((bind (process-let-bindings loc bindings)))
- (call-with-values
- (lambda () (split-let-bindings bind module))
- (lambda (lexical dynamic)
- (for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- module))
- (map car dynamic))
- (let ((make-values (lambda (for)
- (map (lambda (el) (compile-expr (cdr el)))
- for)))
- (make-body (lambda ()
- (make-sequence loc (map compile-expr body)))))
- (if (null? lexical)
- (let-dynamic loc (map car dynamic) module
- (make-values dynamic) (make-body))
- (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
- (dynamic-syms (map (lambda (el) (gensym)) dynamic))
- (all-syms (append lexical-syms dynamic-syms))
- (vals (append (make-values lexical)
- (make-values dynamic))))
- (make-let loc
- all-syms
- all-syms
- vals
- (with-lexical-bindings
- (fluid-ref bindings-data)
- (map car lexical) lexical-syms
- (lambda ()
- (if (null? dynamic)
- (make-body)
- (let-dynamic loc
- (map car dynamic)
- module
- (map
- (lambda (sym)
- (make-lexical-ref loc
- sym
- sym))
- dynamic-syms)
- (make-body)))))))))))))
-
-;;; Let* is compiled to a cascaded set of "small lets" for each binding
-;;; in turn so that each one already sees the preceding bindings.
-
-(define (generate-let* loc module bindings body)
- (let ((bind (process-let-bindings loc bindings)))
- (begin
- (for-each (lambda (sym)
- (if (not (bind-lexically? sym module))
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- module)))
- (map car bind))
- (let iterate ((tail bind))
- (if (null? tail)
- (make-sequence loc (map compile-expr body))
- (let ((sym (caar tail))
- (value (compile-expr (cdar tail))))
- (if (bind-lexically? sym module)
- (let ((target (gensym)))
- (make-let loc
- `(,target)
- `(,target)
- `(,value)
- (with-lexical-bindings
- (fluid-ref bindings-data)
- `(,sym)
- `(,target)
- (lambda () (iterate (cdr tail))))))
- (let-dynamic loc
- `(,(caar tail))
- module
- `(,value)
- (iterate (cdr tail))))))))))
-
-;;; Split the argument list of a lambda expression into required,
-;;; optional and rest arguments and also check it is actually valid.
-;;; Additionally, we create a list of all "local variables" (that is,
-;;; required, optional and rest arguments together) and also this one
-;;; split into those to be bound lexically and dynamically. Returned is
-;;; as multiple values: required optional rest lexical dynamic
-
-(define (bind-arg-lexical? arg)
- (let ((always (fluid-ref always-lexical)))
- (or (eq? always 'all)
- (memq arg always))))
-
-(define (split-lambda-arguments loc args)
- (let iterate ((tail args)
- (mode 'required)
- (required '())
- (optional '())
- (lexical '())
- (dynamic '()))
- (cond
- ((null? tail)
- (let ((final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse lexical))
- (final-dynamic (reverse dynamic)))
- (values final-required
- final-optional
- #f
- final-lexical
- final-dynamic)))
- ((and (eq? mode 'required)
- (eq? (car tail) '&optional))
- (iterate (cdr tail) 'optional required optional lexical dynamic))
- ((eq? (car tail) '&rest)
- (if (or (null? (cdr tail))
- (not (null? (cddr tail))))
- (report-error loc "expected exactly one symbol after &rest")
- (let* ((rest (cadr tail))
- (rest-lexical (bind-arg-lexical? rest))
- (final-required (reverse required))
- (final-optional (reverse optional))
- (final-lexical (reverse (if rest-lexical
- (cons rest lexical)
- lexical)))
- (final-dynamic (reverse (if rest-lexical
- dynamic
- (cons rest dynamic)))))
- (values final-required
- final-optional
- rest
- final-lexical
- final-dynamic))))
- (else
- (if (not (symbol? (car tail)))
- (report-error loc
- "expected symbol in argument list, got"
- (car tail))
- (let* ((arg (car tail))
- (bind-lexical (bind-arg-lexical? arg))
- (new-lexical (if bind-lexical
- (cons arg lexical)
- lexical))
- (new-dynamic (if bind-lexical
- dynamic
- (cons arg dynamic))))
- (case mode
- ((required) (iterate (cdr tail) mode
- (cons arg required) optional
- new-lexical new-dynamic))
- ((optional) (iterate (cdr tail) mode
- required (cons arg optional)
- new-lexical new-dynamic))
- (else
- (error "invalid mode in split-lambda-arguments"
- mode)))))))))
-
-;;; Compile a lambda expression. One thing we have to be aware of is
-;;; that lambda arguments are usually dynamically bound, even when a
-;;; lexical binding is intact for a symbol. For symbols that are marked
-;;; as 'always lexical,' however, we lexically bind here as well, and
-;;; thus we get them out of the let-dynamic call and register a lexical
-;;; binding for them (the lexical target variable is already there,
-;;; namely the real lambda argument from TreeIL).
-
-(define (compile-lambda loc args body)
- (if (not (list? args))
- (report-error loc "expected list for argument-list" args))
- (if (null? body)
- (report-error loc "function body must not be empty"))
- (receive (required optional rest lexical dynamic)
- (split-lambda-arguments loc args)
- (define (process-args args)
- (define (find-pairs pairs filter)
- (lset-intersection (lambda (name+sym x)
- (eq? (car name+sym) x))
- pairs
- filter))
- (let* ((syms (map (lambda (x) (gensym)) args))
- (pairs (map cons args syms))
- (lexical-pairs (find-pairs pairs lexical))
- (dynamic-pairs (find-pairs pairs dynamic)))
- (values syms pairs lexical-pairs dynamic-pairs)))
- (let*-values (((required-syms
- required-pairs
- required-lex-pairs
- required-dyn-pairs)
- (process-args required))
- ((optional-syms
- optional-pairs
- optional-lex-pairs
- optional-dyn-pairs)
- (process-args optional))
- ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
- (process-args (if rest (list rest) '())))
- ((the-rest-sym) (if rest (car rest-syms) #f))
- ((all-syms) (append required-syms
- optional-syms
- rest-syms))
- ((all-lex-pairs) (append required-lex-pairs
- optional-lex-pairs
- rest-lex-pairs))
- ((all-dyn-pairs) (append required-dyn-pairs
- optional-dyn-pairs
- rest-dyn-pairs)))
- (for-each (lambda (sym)
- (mark-global-needed! (fluid-ref bindings-data)
- sym
- value-slot))
- dynamic)
- (with-dynamic-bindings
- (fluid-ref bindings-data)
- dynamic
- (lambda ()
- (with-lexical-bindings
- (fluid-ref bindings-data)
- (map car all-lex-pairs)
- (map cdr all-lex-pairs)
- (lambda ()
- (make-lambda
- loc
- '()
- (make-lambda-case
- #f
- required
- optional
- rest
- #f
- (map (lambda (x) (nil-value loc)) optional)
- all-syms
- (let ((compiled-body
- (make-sequence loc (map compile-expr body))))
- (make-sequence
- loc
- (list
- (if rest
- (make-conditional
- loc
- (call-primitive loc
- 'null?
- (make-lexical-ref loc
- rest
- the-rest-sym))
- (make-lexical-set loc
- rest
- the-rest-sym
- (nil-value loc))
- (make-void loc))
- (make-void loc))
- (if (null? dynamic)
- compiled-body
- (let-dynamic loc
- dynamic
- value-slot
- (map (lambda (name-sym)
- (make-lexical-ref
- loc
- (car name-sym)
- (cdr name-sym)))
- all-dyn-pairs)
- compiled-body)))))
- #f)))))))))
-
-;;; Handle the common part of defconst and defvar, that is, checking for
-;;; a correct doc string and arguments as well as maybe in the future
-;;; handling the docstring somehow.
-
-(define (handle-var-def loc sym doc)
- (cond
- ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
- ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
- ((and (not (null? doc)) (not (string? (car doc))))
- (report-error loc "expected string as third argument of defvar, got"
- (car doc)))
- ;; TODO: Handle doc string if present.
- (else #t)))
-
-;;; Handle macro and special operator bindings.
-
-(define (find-operator sym type)
- (and
- (symbol? sym)
- (module-defined? (resolve-interface function-slot) sym)
- (let* ((op (module-ref (resolve-module function-slot) sym))
- (op (if (fluid? op) (fluid-ref op) op)))
- (if (and (pair? op) (eq? (car op) type))
- (cdr op)
- #f))))
-
-;;; See if a (backquoted) expression contains any unquotes.
-
-(define (contains-unquotes? expr)
- (if (pair? expr)
- (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
- #t
- (or (contains-unquotes? (car expr))
- (contains-unquotes? (cdr expr))))
- #f))
-
-;;; Process a backquoted expression by building up the needed
-;;; cons/append calls. For splicing, it is assumed that the expression
-;;; spliced in evaluates to a list. The emacs manual does not really
-;;; state either it has to or what to do if it does not, but Scheme
-;;; explicitly forbids it and this seems reasonable also for elisp.
-
-(define (unquote-cell? expr)
- (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
-
-(define (unquote-splicing-cell? expr)
- (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
-
-(define (process-backquote loc expr)
- (if (contains-unquotes? expr)
- (if (pair? expr)
- (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
- (compile-expr (cadr expr))
- (let* ((head (car expr))
- (processed-tail (process-backquote loc (cdr expr)))
- (head-is-list-2 (and (list? head)
- (= (length head) 2)))
- (head-unquote (and head-is-list-2
- (unquote? (car head))))
- (head-unquote-splicing (and head-is-list-2
- (unquote-splicing?
- (car head)))))
- (if head-unquote-splicing
- (call-primitive loc
- 'append
- (compile-expr (cadr head))
- processed-tail)
- (call-primitive loc 'cons
- (if head-unquote
- (compile-expr (cadr head))
- (process-backquote loc head))
- processed-tail))))
- (report-error loc
- "non-pair expression contains unquotes"
- expr))
- (make-const loc expr)))
-
-;;; Temporarily update a list of symbols that are handled specially
-;;; (disabled void check or always lexical) for compiling body. We need
-;;; to handle special cases for already all / set to all and the like.
-
-(define (with-added-symbols loc fluid syms body)
- (if (null? body)
- (report-error loc "symbol-list construct has empty body"))
- (if (not (or (eq? syms 'all)
- (and (list? syms) (and-map symbol? syms))))
- (report-error loc "invalid symbol list" syms))
- (let ((old (fluid-ref fluid))
- (make-body (lambda ()
- (make-sequence loc (map compile-expr body)))))
- (if (eq? old 'all)
- (make-body)
- (let ((new (if (eq? syms 'all)
- 'all
- (append syms old))))
- (with-fluids ((fluid new))
- (make-body))))))
-
-;;; Special operators
-
-(defspecial progn (loc args)
- (make-sequence loc (map compile-expr args)))
-
-(defspecial if (loc args)
- (pmatch args
- ((,cond ,then . ,else)
- (make-conditional loc
- (compile-expr cond)
- (compile-expr then)
- (if (null? else)
- (nil-value loc)
- (make-sequence loc
- (map compile-expr else)))))))
-
-(defspecial defconst (loc args)
- (pmatch args
- ((,sym ,value . ,doc)
- (if (handle-var-def loc sym doc)
- (make-sequence loc
- (list (set-variable! loc
- sym
- value-slot
- (compile-expr value))
- (make-const loc sym)))))))
-
-(defspecial defvar (loc args)
- (pmatch args
- ((,sym) (make-const loc sym))
- ((,sym ,value . ,doc)
- (if (handle-var-def loc sym doc)
- (make-sequence
- loc
- (list
- (make-conditional
- loc
- (make-conditional
- loc
- (call-primitive
- loc
- 'module-bound?
- (call-primitive loc
- 'resolve-interface
- (make-const loc value-slot))
- (make-const loc sym))
- (call-primitive loc
- 'fluid-bound?
- (make-module-ref loc value-slot sym #t))
- (make-const loc #f))
- (make-void loc)
- (set-variable! loc sym value-slot (compile-expr value)))
- (make-const loc sym)))))))
-
-(defspecial setq (loc args)
- (define (car* x) (if (null? x) '() (car x)))
- (define (cdr* x) (if (null? x) '() (cdr x)))
- (define (cadr* x) (car* (cdr* x)))
- (define (cddr* x) (cdr* (cdr* x)))
- (make-sequence
- loc
- (let loop ((args args) (last (nil-value loc)))
- (if (null? args)
- (list last)
- (let ((sym (car args))
- (val (compile-expr (cadr* args))))
- (if (not (symbol? sym))
- (report-error loc "expected symbol in setq")
- (cons
- (set-variable! loc sym value-slot val)
- (loop (cddr* args)
- (reference-variable loc sym value-slot)))))))))
-
-(defspecial let (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let loc value-slot bindings body))))
-
-(defspecial lexical-let (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let loc 'lexical bindings body))))
-
-(defspecial flet (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let loc function-slot bindings body))))
-
-(defspecial let* (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let* loc value-slot bindings body))))
-
-(defspecial lexical-let* (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let* loc 'lexical bindings body))))
-
-(defspecial flet* (loc args)
- (pmatch args
- ((,bindings . ,body)
- (generate-let* loc function-slot bindings body))))
-
-;;; Temporarily set symbols as always lexical only for the lexical scope
-;;; of a construct.
-
-(defspecial with-always-lexical (loc args)
- (pmatch args
- ((,syms . ,body)
- (with-added-symbols loc always-lexical syms body))))
-
-;;; guile-ref allows building TreeIL's module references from within
-;;; elisp as a way to access data within the Guile universe. The module
-;;; and symbol referenced are static values, just like (@ module symbol)
-;;; does!
-
-(defspecial guile-ref (loc args)
- (pmatch args
- ((,module ,sym) (guard (and (list? module) (symbol? sym)))
- (make-module-ref loc module sym #t))))
-
-;;; guile-primitive allows to create primitive references, which are
-;;; still a little faster.
-
-(defspecial guile-primitive (loc args)
- (pmatch args
- ((,sym)
- (make-primitive-ref loc sym))))
-
-;;; A while construct is transformed into a tail-recursive loop like
-;;; this:
-;;;
-;;; (letrec ((iterate (lambda ()
-;;; (if condition
-;;; (begin body
-;;; (iterate))
-;;; #nil))))
-;;; (iterate))
-;;;
-;;; As letrec is not directly accessible from elisp, while is
-;;; implemented here instead of with a macro.
-
-(defspecial while (loc args)
- (pmatch args
- ((,condition . ,body)
- (let* ((itersym (gensym))
- (compiled-body (map compile-expr body))
- (iter-call (make-application loc
- (make-lexical-ref loc
- 'iterate
- itersym)
- (list)))
- (full-body (make-sequence loc
- `(,@compiled-body ,iter-call)))
- (lambda-body (make-conditional loc
- (compile-expr condition)
- full-body
- (nil-value loc)))
- (iter-thunk (make-lambda loc
- '()
- (make-lambda-case #f
- '()
- #f
- #f
- #f
- '()
- '()
- lambda-body
- #f))))
- (make-letrec loc
- #f
- '(iterate)
- (list itersym)
- (list iter-thunk)
- iter-call)))))
-
-(defspecial function (loc args)
- (pmatch args
- (((lambda ,args . ,body))
- (compile-lambda loc args body))
- ((,sym) (guard (symbol? sym))
- (reference-variable loc sym function-slot))))
-
-(defspecial defmacro (loc args)
- (pmatch args
- ((,name ,args . ,body)
- (if (not (symbol? name))
- (report-error loc "expected symbol as macro name" name)
- (let* ((tree-il
- (make-sequence
- loc
- (list
- (set-variable!
- loc
- name
- function-slot
- (make-application
- loc
- (make-module-ref loc '(guile) 'cons #t)
- (list (make-const loc 'macro)
- (compile-lambda loc args body))))
- (make-const loc name)))))
- (compile (ensuring-globals loc bindings-data tree-il)
- #:from 'tree-il
- #:to 'value)
- tree-il)))))
-
-(defspecial defun (loc args)
- (pmatch args
- ((,name ,args . ,body)
- (if (not (symbol? name))
- (report-error loc "expected symbol as function name" name)
- (make-sequence loc
- (list (set-variable! loc
- name
- function-slot
- (compile-lambda loc
- args
- body))
- (make-const loc name)))))))
-
-(defspecial #{`}# (loc args)
- (pmatch args
- ((,val)
- (process-backquote loc val))))
-
-(defspecial quote (loc args)
- (pmatch args
- ((,val)
- (make-const loc val))))
-
-;;; Compile a compound expression to Tree-IL.
-
-(define (compile-pair loc expr)
- (let ((operator (car expr))
- (arguments (cdr expr)))
- (cond
- ((find-operator operator 'special-operator)
- => (lambda (special-operator-function)
- (special-operator-function loc arguments)))
- ((find-operator operator 'macro)
- => (lambda (macro-function)
- (compile-expr (apply macro-function arguments))))
- (else
- (make-application loc
- (if (symbol? operator)
- (reference-variable loc
- operator
- function-slot)
- (compile-expr operator))
- (map compile-expr arguments))))))
-
-;;; Compile a symbol expression. This is a variable reference or maybe
-;;; some special value like nil.
-
-(define (compile-symbol loc sym)
- (case sym
- ((nil) (nil-value loc))
- ((t) (t-value loc))
- (else (reference-variable loc sym value-slot))))
-
-;;; Compile a single expression to TreeIL.
-
-(define (compile-expr expr)
- (let ((loc (location expr)))
- (cond
- ((symbol? expr)
- (compile-symbol loc expr))
- ((pair? expr)
- (compile-pair loc expr))
- (else (make-const loc expr)))))
-
-;;; Process the compiler options.
-;;; FIXME: Why is '(()) passed as options by the REPL?
-
-(define (valid-symbol-list-arg? value)
- (or (eq? value 'all)
- (and (list? value) (and-map symbol? value))))
-
-(define (process-options! opt)
- (if (and (not (null? opt))
- (not (equal? opt '(()))))
- (if (null? (cdr opt))
- (report-error #f "Invalid compiler options" opt)
- (let ((key (car opt))
- (value (cadr opt)))
- (case key
- ((#:warnings) ; ignore
- #f)
- ((#:always-lexical)
- (if (valid-symbol-list-arg? value)
- (fluid-set! always-lexical value)
- (report-error #f
- "Invalid value for #:always-lexical"
- value)))
- (else (report-error #f
- "Invalid compiler option"
- key)))))))
-
-;;; Entry point for compilation to TreeIL. This creates the bindings
-;;; data structure, and after compiling the main expression we need to
-;;; make sure all globals for symbols used during the compilation are
-;;; created using the generate-ensure-global function.
-
-(define (compile-tree-il expr env opts)
- (values
- (with-fluids ((bindings-data (make-bindings))
- (disable-void-check '())
- (always-lexical '()))
- (process-options! opts)
- (let ((compiled (compile-expr expr)))
- (ensuring-globals (location expr) bindings-data compiled)))
- env
- env))
+;;; Guile Emacs Lisp
+
+;; Copyright (C) 2009, 2010, 2011, 2013 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, 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.
+
+;;; Code:
+
+(define-module (language elisp compile-tree-il)
+ #:use-module (language elisp bindings)
+ #:use-module (language elisp runtime)
+ #:use-module (language tree-il)
+ #:use-module (system base pmatch)
+ #:use-module (system base compile)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:export (compile-tree-il
+ compile-progn
+ compile-eval-when-compile
+ compile-if
+ compile-defconst
+ compile-defvar
+ compile-setq
+ compile-let
+ compile-flet
+ compile-labels
+ compile-let*
+ compile-guile-ref
+ compile-guile-primitive
+ compile-function
+ compile-defmacro
+ compile-defun
+ #{compile-`}#
+ compile-quote
+ compile-%funcall
+ compile-%set-lexical-binding-mode))
+
+;;; Certain common parameters (like the bindings data structure or
+;;; compiler options) are not always passed around but accessed using
+;;; fluids to simulate dynamic binding (hey, this is about elisp).
+
+;;; The bindings data structure to keep track of symbol binding related
+;;; data.
+
+(define bindings-data (make-fluid))
+
+(define lexical-binding (make-fluid))
+
+;;; Find the source properties of some parsed expression if there are
+;;; any associated with it.
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ props))))
+
+;;; Values to use for Elisp's nil and t.
+
+(define (nil-value loc)
+ (make-const loc (@ (language elisp runtime) nil-value)))
+
+(define (t-value loc)
+ (make-const loc (@ (language elisp runtime) t-value)))
+
+;;; Modules that contain the value and function slot bindings.
+
+(define runtime '(language elisp runtime))
+
+(define value-slot (@ (language elisp runtime) value-slot-module))
+
+(define function-slot (@ (language elisp runtime) function-slot-module))
+
+;;; The backquoting works the same as quasiquotes in Scheme, but the
+;;; forms are named differently; to make easy adaptions, we define these
+;;; predicates checking for a symbol being the car of an
+;;; unquote/unquote-splicing/backquote form.
+
+(define (unquote? sym)
+ (and (symbol? sym) (eq? sym '#{,}#)))
+
+(define (unquote-splicing? sym)
+ (and (symbol? sym) (eq? sym '#{,@}#)))
+
+;;; Build a call to a primitive procedure nicely.
+
+(define (call-primitive loc sym . args)
+ (make-primcall loc sym args))
+
+;;; Error reporting routine for syntax/compilation problems or build
+;;; code for a runtime-error output.
+
+(define (report-error loc . args)
+ (apply error args))
+
+(define (access-variable loc symbol handle-lexical handle-dynamic)
+ (cond
+ ((get-lexical-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-dynamic))))
+
+(define (reference-variable loc symbol)
+ (access-variable
+ loc
+ symbol
+ (lambda (lexical)
+ (make-lexical-ref loc lexical lexical))
+ (lambda ()
+ (call-primitive loc
+ 'fluid-ref
+ (make-module-ref loc value-slot symbol #t)))))
+
+(define (global? module symbol)
+ (module-variable module symbol))
+
+(define (ensure-globals! loc names body)
+ (if (and (every (cut global? (resolve-module value-slot) <>) names)
+ (every symbol-interned? names))
+ body
+ (list->seq
+ loc
+ `(,@(map
+ (lambda (name)
+ (ensure-fluid! value-slot name)
+ (make-call loc
+ (make-module-ref loc runtime 'ensure-fluid! #t)
+ (list (make-const loc value-slot)
+ (make-const loc name))))
+ names)
+ ,body))))
+
+(define (set-variable! loc symbol value)
+ (access-variable
+ loc
+ symbol
+ (lambda (lexical)
+ (make-lexical-set loc lexical lexical value))
+ (lambda ()
+ (ensure-globals!
+ loc
+ (list symbol)
+ (call-primitive loc
+ 'fluid-set!
+ (make-module-ref loc value-slot symbol #t)
+ value)))))
+
+(define (access-function loc symbol handle-lexical handle-global)
+ (cond
+ ((get-function-binding (fluid-ref bindings-data) symbol)
+ => handle-lexical)
+ (else
+ (handle-global))))
+
+(define (reference-function loc symbol)
+ (access-function
+ loc
+ symbol
+ (lambda (gensym) (make-lexical-ref loc symbol gensym))
+ (lambda () (make-module-ref loc function-slot symbol #t))))
+
+(define (set-function! loc symbol value)
+ (access-function
+ loc
+ symbol
+ (lambda (gensym) (make-lexical-set loc symbol gensym value))
+ (lambda ()
+ (make-call
+ loc
+ (make-module-ref loc runtime 'set-symbol-function! #t)
+ (list (make-const loc symbol) value)))))
+
+(define (bind-lexically? sym module decls)
+ (or (eq? module function-slot)
+ (let ((decl (assq-ref decls sym)))
+ (and (equal? module value-slot)
+ (or
+ (eq? decl 'lexical)
+ (and
+ (fluid-ref lexical-binding)
+ (not (global? (resolve-module module) sym))))))))
+
+(define (parse-let-binding loc binding)
+ (pmatch binding
+ ((unquote var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var)
+ (guard (symbol? var))
+ (cons var #nil))
+ ((,var ,val)
+ (guard (symbol? var))
+ (cons var val))
+ (else
+ (report-error loc "malformed variable binding" binding))))
+
+(define (parse-flet-binding loc binding)
+ (pmatch binding
+ ((,var ,args . ,body)
+ (guard (symbol? var))
+ (cons var `(function (lambda ,args ,@body))))
+ (else
+ (report-error loc "malformed function binding" binding))))
+
+(define (parse-declaration expr)
+ (pmatch expr
+ ((lexical . ,vars)
+ (map (cut cons <> 'lexical) vars))
+ (else
+ '())))
+
+(define (parse-body-1 body lambda?)
+ (let loop ((lst body)
+ (decls '())
+ (intspec #f)
+ (doc #f))
+ (pmatch lst
+ (((declare . ,x) . ,tail)
+ (loop tail (append-reverse x decls) intspec doc))
+ (((interactive . ,x) . ,tail)
+ (guard lambda? (not intspec))
+ (loop tail decls x doc))
+ ((,x . ,tail)
+ (guard lambda? (string? x) (not doc) (not (null? tail)))
+ (loop tail decls intspec x))
+ (else
+ (values (append-map parse-declaration decls)
+ intspec
+ doc
+ lst)))))
+
+(define (parse-lambda-body body)
+ (parse-body-1 body #t))
+
+(define (parse-body body)
+ (receive (decls intspec doc body) (parse-body-1 body #f)
+ (values decls body)))
+
+;;; Partition the argument list of a lambda expression into required,
+;;; optional and rest arguments.
+
+(define (parse-lambda-list lst)
+ (define (%match lst null optional rest symbol)
+ (pmatch lst
+ (() (null))
+ ((&optional . ,tail) (optional tail))
+ ((&rest . ,tail) (rest tail))
+ ((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
+ (else (fail))))
+ (define (return rreq ropt rest)
+ (values #t (reverse rreq) (reverse ropt) rest))
+ (define (fail)
+ (values #f #f #f #f))
+ (define (parse-req lst rreq)
+ (%match lst
+ (lambda () (return rreq '() #f))
+ (lambda (tail) (parse-opt tail rreq '()))
+ (lambda (tail) (parse-rest tail rreq '()))
+ (lambda (arg tail) (parse-req tail (cons arg rreq)))))
+ (define (parse-opt lst rreq ropt)
+ (%match lst
+ (lambda () (return rreq ropt #f))
+ (lambda (tail) (fail))
+ (lambda (tail) (parse-rest tail rreq ropt))
+ (lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
+ (define (parse-rest lst rreq ropt)
+ (%match lst
+ (lambda () (fail))
+ (lambda (tail) (fail))
+ (lambda (tail) (fail))
+ (lambda (arg tail) (parse-post-rest tail rreq ropt arg))))
+ (define (parse-post-rest lst rreq ropt rest)
+ (%match lst
+ (lambda () (return rreq ropt rest))
+ (lambda () (fail))
+ (lambda () (fail))
+ (lambda (arg tail) (fail))))
+ (parse-req lst '()))
+
+(define (make-simple-lambda loc meta req opt init rest vars body)
+ (make-lambda loc
+ meta
+ (make-lambda-case #f req opt rest #f init vars body #f)))
+
+(define (make-dynlet src fluids vals body)
+ (let ((f (map (lambda (x) (gensym "fluid ")) fluids))
+ (v (map (lambda (x) (gensym "valud ")) vals)))
+ (make-let src (map (lambda (_) 'fluid) fluids) f fluids
+ (make-let src (map (lambda (_) 'val) vals) v vals
+ (let lp ((f f) (v v))
+ (if (null? f)
+ body
+ (make-primcall
+ src 'with-fluid*
+ (list (make-lexical-ref #f 'fluid (car f))
+ (make-lexical-ref #f 'val (car v))
+ (make-lambda
+ src '()
+ (make-lambda-case
+ src '() #f #f #f '() '()
+ (lp (cdr f) (cdr v))
+ #f))))))))))
+
+(define (compile-lambda loc meta args body)
+ (receive (valid? req-ids opt-ids rest-id)
+ (parse-lambda-list args)
+ (if valid?
+ (let* ((all-ids (append req-ids
+ opt-ids
+ (or (and=> rest-id list) '())))
+ (all-vars (map (lambda (ignore) (gensym)) all-ids)))
+ (let*-values (((decls intspec doc forms)
+ (parse-lambda-body body))
+ ((lexical dynamic)
+ (partition
+ (compose (cut bind-lexically? <> value-slot decls)
+ car)
+ (map list all-ids all-vars)))
+ ((lexical-ids lexical-vars) (unzip2 lexical))
+ ((dynamic-ids dynamic-vars) (unzip2 dynamic)))
+ (with-dynamic-bindings
+ (fluid-ref bindings-data)
+ dynamic-ids
+ (lambda ()
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ lexical-ids
+ lexical-vars
+ (lambda ()
+ (ensure-globals!
+ loc
+ dynamic-ids
+ (let* ((tree-il
+ (compile-expr
+ (if rest-id
+ `(let ((,rest-id (if ,rest-id
+ ,rest-id
+ nil)))
+ ,@forms)
+ `(progn ,@forms))))
+ (full-body
+ (if (null? dynamic)
+ tree-il
+ (make-dynlet
+ loc
+ (map (cut make-module-ref loc value-slot <> #t)
+ dynamic-ids)
+ (map (cut make-lexical-ref loc <> <>)
+ dynamic-ids
+ dynamic-vars)
+ tree-il))))
+ (make-simple-lambda loc
+ meta
+ req-ids
+ opt-ids
+ (map (const (nil-value loc))
+ opt-ids)
+ rest-id
+ all-vars
+ full-body)))))))))
+ (report-error "invalid function" `(lambda ,args ,@body)))))
+
+;;; Handle the common part of defconst and defvar, that is, checking for
+;;; a correct doc string and arguments as well as maybe in the future
+;;; handling the docstring somehow.
+
+(define (handle-var-def loc sym doc)
+ (cond
+ ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
+ ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
+ ((and (not (null? doc)) (not (string? (car doc))))
+ (report-error loc "expected string as third argument of defvar, got"
+ (car doc)))
+ ;; TODO: Handle doc string if present.
+ (else #t)))
+
+;;; Handle macro and special operator bindings.
+
+(define (find-operator name type)
+ (and
+ (symbol? name)
+ (module-defined? (resolve-interface function-slot) name)
+ (let ((op (module-ref (resolve-module function-slot) name)))
+ (if (and (pair? op) (eq? (car op) type))
+ (cdr op)
+ #f))))
+
+;;; See if a (backquoted) expression contains any unquotes.
+
+(define (contains-unquotes? expr)
+ (if (pair? expr)
+ (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
+ #t
+ (or (contains-unquotes? (car expr))
+ (contains-unquotes? (cdr expr))))
+ #f))
+
+;;; Process a backquoted expression by building up the needed
+;;; cons/append calls. For splicing, it is assumed that the expression
+;;; spliced in evaluates to a list. The emacs manual does not really
+;;; state either it has to or what to do if it does not, but Scheme
+;;; explicitly forbids it and this seems reasonable also for elisp.
+
+(define (unquote-cell? expr)
+ (and (list? expr) (= (length expr) 2) (unquote? (car expr))))
+
+(define (unquote-splicing-cell? expr)
+ (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))
+
+(define (process-backquote loc expr)
+ (if (contains-unquotes? expr)
+ (if (pair? expr)
+ (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
+ (compile-expr (cadr expr))
+ (let* ((head (car expr))
+ (processed-tail (process-backquote loc (cdr expr)))
+ (head-is-list-2 (and (list? head)
+ (= (length head) 2)))
+ (head-unquote (and head-is-list-2
+ (unquote? (car head))))
+ (head-unquote-splicing (and head-is-list-2
+ (unquote-splicing?
+ (car head)))))
+ (if head-unquote-splicing
+ (call-primitive loc
+ 'append
+ (compile-expr (cadr head))
+ processed-tail)
+ (call-primitive loc 'cons
+ (if head-unquote
+ (compile-expr (cadr head))
+ (process-backquote loc head))
+ processed-tail))))
+ (report-error loc
+ "non-pair expression contains unquotes"
+ expr))
+ (make-const loc expr)))
+
+;;; Special operators
+
+(defspecial progn (loc args)
+ (list->seq loc
+ (if (null? args)
+ (list (nil-value loc))
+ (map compile-expr args))))
+
+(defspecial eval-when-compile (loc args)
+ (make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
+
+(defspecial if (loc args)
+ (pmatch args
+ ((,cond ,then . ,else)
+ (make-conditional
+ loc
+ (call-primitive loc 'not
+ (call-primitive loc 'nil? (compile-expr cond)))
+ (compile-expr then)
+ (compile-expr `(progn ,@else))))))
+
+(defspecial defconst (loc args)
+ (pmatch args
+ ((,sym ,value . ,doc)
+ (if (handle-var-def loc sym doc)
+ (make-seq loc
+ (set-variable! loc sym (compile-expr value))
+ (make-const loc sym))))))
+
+(defspecial defvar (loc args)
+ (pmatch args
+ ((,sym) (make-const loc sym))
+ ((,sym ,value . ,doc)
+ (if (handle-var-def loc sym doc)
+ (make-seq
+ loc
+ (make-conditional
+ loc
+ (make-conditional
+ loc
+ (call-primitive
+ loc
+ 'module-bound?
+ (call-primitive loc
+ 'resolve-interface
+ (make-const loc value-slot))
+ (make-const loc sym))
+ (call-primitive loc
+ 'fluid-bound?
+ (make-module-ref loc value-slot sym #t))
+ (make-const loc #f))
+ (make-void loc)
+ (set-variable! loc sym (compile-expr value)))
+ (make-const loc sym))))))
+
+(defspecial setq (loc args)
+ (define (car* x) (if (null? x) '() (car x)))
+ (define (cdr* x) (if (null? x) '() (cdr x)))
+ (define (cadr* x) (car* (cdr* x)))
+ (define (cddr* x) (cdr* (cdr* x)))
+ (list->seq
+ loc
+ (let loop ((args args) (last (nil-value loc)))
+ (if (null? args)
+ (list last)
+ (let ((sym (car args))
+ (val (compile-expr (cadr* args))))
+ (if (not (symbol? sym))
+ (report-error loc "expected symbol in setq")
+ (cons
+ (set-variable! loc sym val)
+ (loop (cddr* args)
+ (reference-variable loc sym)))))))))
+
+(defspecial let (loc args)
+ (pmatch args
+ ((,varlist . ,body)
+ (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
+ (receive (decls forms) (parse-body body)
+ (receive (lexical dynamic)
+ (partition
+ (compose (cut bind-lexically? <> value-slot decls)
+ car)
+ bindings)
+ (let ((make-values (lambda (for)
+ (map (lambda (el) (compile-expr (cdr el)))
+ for)))
+ (make-body (lambda () (compile-expr `(progn ,@forms)))))
+ (ensure-globals!
+ loc
+ (map car dynamic)
+ (if (null? lexical)
+ (make-dynlet loc
+ (map (compose (cut make-module-ref
+ loc
+ value-slot
+ <>
+ #t)
+ car)
+ dynamic)
+ (map (compose compile-expr cdr)
+ dynamic)
+ (make-body))
+ (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
+ (dynamic-syms (map (lambda (el) (gensym)) dynamic))
+ (all-syms (append lexical-syms dynamic-syms))
+ (vals (append (make-values lexical)
+ (make-values dynamic))))
+ (make-let loc
+ all-syms
+ all-syms
+ vals
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ (map car lexical)
+ lexical-syms
+ (lambda ()
+ (if (null? dynamic)
+ (make-body)
+ (make-dynlet loc
+ (map
+ (compose
+ (cut make-module-ref
+ loc
+ value-slot
+ <>
+ #t)
+ car)
+ dynamic)
+ (map
+ (lambda (sym)
+ (make-lexical-ref
+ loc
+ sym
+ sym))
+ dynamic-syms)
+ (make-body))))))))))))))))
+
+(defspecial let* (loc args)
+ (pmatch args
+ ((,varlist . ,body)
+ (let ((bindings (map (cut parse-let-binding loc <>) varlist)))
+ (receive (decls forms) (parse-body body)
+ (let iterate ((tail bindings))
+ (if (null? tail)
+ (compile-expr `(progn ,@forms))
+ (let ((sym (caar tail))
+ (value (compile-expr (cdar tail))))
+ (if (bind-lexically? sym value-slot decls)
+ (let ((target (gensym)))
+ (make-let loc
+ `(,target)
+ `(,target)
+ `(,value)
+ (with-lexical-bindings
+ (fluid-ref bindings-data)
+ `(,sym)
+ `(,target)
+ (lambda () (iterate (cdr tail))))))
+ (ensure-globals!
+ loc
+ (list sym)
+ (make-dynlet loc
+ (list (make-module-ref loc value-slot sym #t))
+ (list value)
+ (iterate (cdr tail)))))))))))))
+
+(defspecial flet (loc args)
+ (pmatch args
+ ((,bindings . ,body)
+ (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
+ (receive (decls forms) (parse-body body)
+ (let ((names (map car names+vals))
+ (vals (map cdr names+vals))
+ (gensyms (map (lambda (x) (gensym)) names+vals)))
+ (with-function-bindings
+ (fluid-ref bindings-data)
+ names
+ gensyms
+ (lambda ()
+ (make-let loc
+ names
+ gensyms
+ (map compile-expr vals)
+ (compile-expr `(progn ,@forms)))))))))))
+
+(defspecial labels (loc args)
+ (pmatch args
+ ((,bindings . ,body)
+ (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
+ (receive (decls forms) (parse-body body)
+ (let ((names (map car names+vals))
+ (vals (map cdr names+vals))
+ (gensyms (map (lambda (x) (gensym)) names+vals)))
+ (with-function-bindings
+ (fluid-ref bindings-data)
+ names
+ gensyms
+ (lambda ()
+ (make-letrec #f
+ loc
+ names
+ gensyms
+ (map compile-expr vals)
+ (compile-expr `(progn ,@forms)))))))))))
+
+;;; guile-ref allows building TreeIL's module references from within
+;;; elisp as a way to access data within the Guile universe. The module
+;;; and symbol referenced are static values, just like (@ module symbol)
+;;; does!
+
+(defspecial guile-ref (loc args)
+ (pmatch args
+ ((,module ,sym) (guard (and (list? module) (symbol? sym)))
+ (make-module-ref loc module sym #t))))
+
+;;; guile-primitive allows to create primitive references, which are
+;;; still a little faster.
+
+(defspecial guile-primitive (loc args)
+ (pmatch args
+ ((,sym)
+ (make-primitive-ref loc sym))))
+
+(defspecial function (loc args)
+ (pmatch args
+ (((lambda ,args . ,body))
+ (compile-lambda loc '() args body))
+ ((,sym) (guard (symbol? sym))
+ (reference-function loc sym))))
+
+(defspecial defmacro (loc args)
+ (pmatch args
+ ((,name ,args . ,body)
+ (if (not (symbol? name))
+ (report-error loc "expected symbol as macro name" name)
+ (let* ((tree-il
+ (make-seq
+ loc
+ (set-function!
+ loc
+ name
+ (make-call
+ loc
+ (make-module-ref loc '(guile) 'cons #t)
+ (list (make-const loc 'macro)
+ (compile-lambda loc
+ `((name . ,name))
+ args
+ body))))
+ (make-const loc name))))
+ (compile tree-il #:from 'tree-il #:to 'value)
+ tree-il)))))
+
+(defspecial defun (loc args)
+ (pmatch args
+ ((,name ,args . ,body)
+ (if (not (symbol? name))
+ (report-error loc "expected symbol as function name" name)
+ (make-seq loc
+ (set-function! loc
+ name
+ (compile-lambda loc
+ `((name . ,name))
+ args
+ body))
+ (make-const loc name))))))
+
+(defspecial #{`}# (loc args)
+ (pmatch args
+ ((,val)
+ (process-backquote loc val))))
+
+(defspecial quote (loc args)
+ (pmatch args
+ ((,val)
+ (make-const loc val))))
+
+(defspecial %funcall (loc args)
+ (pmatch args
+ ((,function . ,arguments)
+ (make-call loc
+ (compile-expr function)
+ (map compile-expr arguments)))))
+
+(defspecial %set-lexical-binding-mode (loc args)
+ (pmatch args
+ ((,val)
+ (fluid-set! lexical-binding val)
+ (make-void loc))))
+
+;;; Compile a compound expression to Tree-IL.
+
+(define (compile-pair loc expr)
+ (let ((operator (car expr))
+ (arguments (cdr expr)))
+ (cond
+ ((find-operator operator 'special-operator)
+ => (lambda (special-operator-function)
+ (special-operator-function loc arguments)))
+ ((find-operator operator 'macro)
+ => (lambda (macro-function)
+ (compile-expr (apply macro-function arguments))))
+ (else
+ (compile-expr `(%funcall (function ,operator) ,@arguments))))))
+
+;;; Compile a symbol expression. This is a variable reference or maybe
+;;; some special value like nil.
+
+(define (compile-symbol loc sym)
+ (case sym
+ ((nil) (nil-value loc))
+ ((t) (t-value loc))
+ (else (reference-variable loc sym))))
+
+;;; Compile a single expression to TreeIL.
+
+(define (compile-expr expr)
+ (let ((loc (location expr)))
+ (cond
+ ((symbol? expr)
+ (compile-symbol loc expr))
+ ((pair? expr)
+ (compile-pair loc expr))
+ (else (make-const loc expr)))))
+
+;;; Process the compiler options.
+;;; FIXME: Why is '(()) passed as options by the REPL?
+
+(define (valid-symbol-list-arg? value)
+ (or (eq? value 'all)
+ (and (list? value) (and-map symbol? value))))
+
+(define (process-options! opt)
+ (if (and (not (null? opt))
+ (not (equal? opt '(()))))
+ (if (null? (cdr opt))
+ (report-error #f "Invalid compiler options" opt)
+ (let ((key (car opt))
+ (value (cadr opt)))
+ (case key
+ ((#:warnings #:to-file?) ; ignore
+ #f)
+ (else (report-error #f
+ "Invalid compiler option"
+ key)))))))
+
+(define (compile-tree-il expr env opts)
+ (values
+ (with-fluids ((bindings-data (make-bindings)))
+ (process-options! opts)
+ (compile-expr expr))
+ env
+ env))
--- /dev/null
+(define-module (language elisp falias)
+ #:export (falias?
+ make-falias
+ falias-function
+ falias-object))
+
+(define <falias-vtable>
+ (make-struct <applicable-struct-vtable>
+ 0
+ (make-struct-layout "pwpw")
+ (lambda (object port)
+ (format port "#<falias ~S>" (falias-object object)))))
+
+(set-struct-vtable-name! <falias-vtable> 'falias)
+
+(define (falias? object)
+ (and (struct? object)
+ (eq? (struct-vtable object) <falias-vtable>)))
+
+(define (make-falias f object)
+ (make-struct <falias-vtable> 0 f object))
+
+(define (falias-function object)
+ (struct-ref object 0))
+
+(define (falias-object object)
+ (struct-ref object 1))
;;; Guile Emacs Lisp
-;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2009, 2010, 2013 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
;;; Main lexer routine, which is given a port and does look for the next
;;; token.
+(define lexical-binding-regexp
+ (make-regexp
+ "-\\*-(|.*;)[ \t]*lexical-binding:[ \t]*([^;]*[^ \t;]).*-\\*-"))
+
(define (lex port)
- (let ((return (let ((file (if (file-port? port)
- (port-filename port)
- #f))
- (line (1+ (port-line port)))
- (column (1+ (port-column port))))
- (lambda (token value)
- (let ((obj (cons token value)))
- (set-source-property! obj 'filename file)
- (set-source-property! obj 'line line)
- (set-source-property! obj 'column column)
- obj))))
- ;; Read afterwards so the source-properties are correct above
- ;; and actually point to the very character to be read.
- (c (read-char port)))
+ (define (lexical-binding-value string)
+ (and=> (regexp-exec lexical-binding-regexp string)
+ (lambda (match)
+ (not (member (match:substring match 2) '("nil" "()"))))))
+ (let* ((return (let ((file (if (file-port? port)
+ (port-filename port)
+ #f))
+ (line (1+ (port-line port)))
+ (column (1+ (port-column port))))
+ (lambda (token value)
+ (let ((obj (cons token value)))
+ (set-source-property! obj 'filename file)
+ (set-source-property! obj 'line line)
+ (set-source-property! obj 'column column)
+ obj))))
+ ;; Read afterwards so the source-properties are correct above
+ ;; and actually point to the very character to be read.
+ (c (read-char port)))
(cond
;; End of input must be specially marked to the parser.
((eof-object? c) (return 'eof c))
(case c
;; A line comment, skip until end-of-line is found.
((#\;)
- (let iterate ()
- (let ((cur (read-char port)))
- (if (or (eof-object? cur) (char=? cur #\newline))
- (lex port)
- (iterate)))))
+ (if (= (port-line port) 0)
+ (let iterate ((chars '()))
+ (let ((cur (read-char port)))
+ (if (or (eof-object? cur) (char=? cur #\newline))
+ (let ((string (list->string (reverse chars))))
+ (return 'set-lexical-binding-mode!
+ (lexical-binding-value string)))
+ (iterate (cons cur chars)))))
+ (let iterate ()
+ (let ((cur (read-char port)))
+ (if (or (eof-object? cur) (char=? cur #\newline))
+ (lex port)
+ (iterate))))))
;; A character literal.
((#\?)
(return 'character (get-character port #f)))
(let ((mark (get-circular-marker port)))
(return (car mark) (cdr mark))))
((#\')
- (return 'function #f)))))
+ (return 'function #f))
+ ((#\:)
+ (call-with-values
+ (lambda () (get-symbol-or-number port))
+ (lambda (type str)
+ (return 'symbol (make-symbol str))))))))
;; Parentheses and other special-meaning single characters.
((#\() (return 'paren-open #f))
((#\)) (return 'paren-close #f))
(setter expr)
(force-promises! expr)
expr))
+ ((set-lexical-binding-mode!)
+ (return `(%set-lexical-binding-mode ,(cdr token))))
(else
(parse-error token "expected expression, got" token)))))
function-slot-module
elisp-bool
ensure-fluid!
- reference-variable
- set-variable!
- runtime-error
- macro-error)
- #:export-syntax (built-in-func built-in-macro defspecial prim))
+ symbol-fluid
+ set-symbol-fluid!
+ symbol-value
+ set-symbol-value!
+ symbol-function
+ set-symbol-function!
+ symbol-bound?
+ symbol-fbound?
+ makunbound!
+ fmakunbound!)
+ #:export-syntax (defspecial prim))
;;; This module provides runtime support for the Elisp front-end.
(define function-slot-module '(language elisp runtime function-slot))
-;;; Report an error during macro compilation, that means some special
-;;; compilation (syntax) error; or report a simple runtime-error from a
-;;; built-in function.
-
-(define (macro-error msg . args)
- (apply error msg args))
-
-(define runtime-error macro-error)
-
-;;; Convert a scheme boolean to Elisp.
-
-(define (elisp-bool b)
- (if b
- t-value
- nil-value))
-
;;; Routines for access to elisp dynamically bound symbols. This is
;;; used for runtime access using functions like symbol-value or set,
;;; where the symbol accessed might not be known at compile-time. These
(module-define! resolved sym fluid)
(module-export! resolved `(,sym))))))
-(define (reference-variable module sym)
- (let ((resolved (resolve-module module)))
- (cond
- ((equal? module function-slot-module)
- (module-ref resolved sym))
- (else
- (ensure-fluid! module sym)
- (fluid-ref (module-ref resolved sym))))))
+(define (symbol-fluid symbol)
+ (let ((module (resolve-module value-slot-module)))
+ (ensure-fluid! value-slot-module symbol) ;++ implicit special proclamation
+ (module-ref module symbol)))
-(define (set-variable! module sym value)
- (let ((intf (resolve-interface module))
- (resolved (resolve-module module)))
- (cond
- ((equal? module function-slot-module)
- (cond
- ((module-defined? intf sym)
- (module-set! resolved sym value))
- (else
- (module-define! resolved sym value)
- (module-export! resolved `(,sym)))))
- (else
- (ensure-fluid! module sym)
- (fluid-set! (module-ref resolved sym) value))))
+(define (set-symbol-fluid! symbol fluid)
+ (let ((module (resolve-module value-slot-module)))
+ (module-define! module symbol fluid)
+ (module-export! module (list symbol)))
+ fluid)
+
+(define (symbol-value symbol)
+ (fluid-ref (symbol-fluid symbol)))
+
+(define (set-symbol-value! symbol value)
+ (fluid-set! (symbol-fluid symbol) value)
value)
-;;; Define a predefined function or predefined macro for use in the
-;;; function-slot and macro-slot modules, respectively.
+(define (symbol-function symbol)
+ (let ((module (resolve-module function-slot-module)))
+ (module-ref module symbol)))
+
+(define (set-symbol-function! symbol value)
+ (let ((module (resolve-module function-slot-module)))
+ (module-define! module symbol value)
+ (module-export! module (list symbol)))
+ value)
-(define-syntax built-in-func
- (syntax-rules ()
- ((_ name value)
- (begin
- (define-public name value)))))
+(define (symbol-bound? symbol)
+ (and
+ (module-bound? (resolve-interface value-slot-module) symbol)
+ (let ((var (module-variable (resolve-module value-slot-module)
+ symbol)))
+ (and (variable-bound? var)
+ (if (fluid? (variable-ref var))
+ (fluid-bound? (variable-ref var))
+ #t)))))
+
+(define (symbol-fbound? symbol)
+ (and
+ (module-bound? (resolve-interface function-slot-module) symbol)
+ (variable-bound?
+ (module-variable (resolve-module function-slot-module)
+ symbol))))
+
+(define (makunbound! symbol)
+ (if (module-bound? (resolve-interface value-slot-module) symbol)
+ (let ((var (module-variable (resolve-module value-slot-module)
+ symbol)))
+ (if (and (variable-bound? var) (fluid? (variable-ref var)))
+ (fluid-unset! (variable-ref var))
+ (variable-unset! var))))
+ symbol)
+
+(define (fmakunbound! symbol)
+ (if (module-bound? (resolve-interface function-slot-module) symbol)
+ (variable-unset! (module-variable
+ (resolve-module function-slot-module)
+ symbol)))
+ symbol)
+
+;;; Define a predefined macro for use in the function-slot module.
(define (make-id template-id . data)
(let ((append-symbols
datum))
data)))))
-(define-syntax built-in-macro
- (lambda (x)
- (syntax-case x ()
- ((_ name value)
- (with-syntax ((scheme-name (make-id #'name 'macro- #'name)))
- #'(begin
- (define-public scheme-name
- (make-fluid (cons 'macro value)))))))))
-
(define-syntax defspecial
(lambda (x)
(syntax-case x ()
((_ name args body ...)
(with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
- #'(begin
- (define scheme-name
- (make-fluid
- (cons 'special-operator
- (lambda args body ...))))))))))
-
-;;; Call a guile-primitive that may be rebound for elisp and thus needs
-;;; absolute addressing.
-
-(define-syntax prim
- (syntax-rules ()
- ((_ sym args ...)
- ((@ (guile) sym) args ...))))
+ #'(define scheme-name
+ (cons 'special-operator (lambda args body ...))))))))
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (language elisp runtime function-slot)
- #:use-module (language elisp runtime subrs)
- #:use-module ((language elisp runtime macros)
- #:select
- ((macro-lambda . lambda)
- (macro-prog1 . prog1)
- (macro-prog2 . prog2)
- (macro-when . when)
- (macro-unless . unless)
- (macro-cond . cond)
- (macro-and . and)
- (macro-or . or)
- (macro-dotimes . dotimes)
- (macro-dolist . dolist)
- (macro-catch . catch)
- (macro-unwind-protect . unwind-protect)
- (macro-pop . pop)
- (macro-push . push)))
#:use-module ((language elisp compile-tree-il)
#:select
((compile-progn . progn)
+ (compile-eval-when-compile . eval-when-compile)
(compile-if . if)
(compile-defconst . defconst)
(compile-defvar . defvar)
(compile-setq . setq)
(compile-let . let)
- (compile-lexical-let . lexical-let)
(compile-flet . flet)
+ (compile-labels . labels)
(compile-let* . let*)
- (compile-lexical-let* . lexical-let*)
- (compile-flet* . flet*)
- (compile-with-always-lexical . with-always-lexical)
(compile-guile-ref . guile-ref)
(compile-guile-primitive . guile-primitive)
- (compile-while . while)
(compile-function . function)
(compile-defun . defun)
(compile-defmacro . defmacro)
(#{compile-`}# . #{`}#)
- (compile-quote . quote)))
+ (compile-quote . quote)
+ (compile-%funcall . %funcall)
+ (compile-%set-lexical-binding-mode
+ . %set-lexical-binding-mode)))
#:duplicates (last)
;; special operators
#:re-export (progn
+ eval-when-compile
if
defconst
defvar
setq
let
- lexical-let
flet
+ labels
let*
- lexical-let*
- flet*
- with-always-lexical
guile-ref
guile-primitive
- while
function
defun
defmacro
#{`}#
- quote)
- ;; macros
- #:re-export (lambda
- prog1
- prog2
- when
- unless
- cond
- and
- or
- dotimes
- dolist
- catch
- unwind-protect
- pop
- push)
- ;; functions
- #:re-export (eq
- equal
- floatp
- integerp
- numberp
- wholenump
- zerop
- =
- /=
- <
- <=
- >
- >=
- max
- min
- abs
- float
- 1+
- 1-
- +
- -
- *
- %
- ffloor
- fceiling
- ftruncate
- fround
- consp
- atomp
- listp
- nlistp
- null
- car
- cdr
- car-safe
- cdr-safe
- nth
- nthcdr
- length
- cons
- list
- make-list
- append
- reverse
- copy-tree
- number-sequence
- setcar
- setcdr
- symbol-value
- symbol-function
- set
- fset
- makunbound
- fmakunbound
- boundp
- fboundp
- apply
- funcall
- throw
- not
- eval
- load))
+ quote
+ %funcall
+ %set-lexical-binding-mode)
+ #:pure)
+++ /dev/null
-;;; Guile Emacs Lisp
-
-;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
-;;;
-;;; This library is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU Lesser General Public
-;;; License as published by the Free Software Foundation; either
-;;; version 3 of 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 elisp runtime macros)
- #:use-module (language elisp runtime))
-
-;;; This module contains the macro definitions of elisp symbols. In
-;;; contrast to the other runtime modules, those are used directly
-;;; during compilation, of course, so not really in runtime. But I
-;;; think it fits well to the others here.
-
-(built-in-macro lambda
- (lambda cdr
- `(function (lambda ,@cdr))))
-
-;;; The prog1 and prog2 constructs can easily be defined as macros using
-;;; progn and some lexical-let's to save the intermediate value to
-;;; return at the end.
-
-(built-in-macro prog1
- (lambda (form1 . rest)
- (let ((temp (gensym)))
- `(lexical-let ((,temp ,form1))
- ,@rest
- ,temp))))
-
-(built-in-macro prog2
- (lambda (form1 form2 . rest)
- `(progn ,form1 (prog1 ,form2 ,@rest))))
-
-;;; Define the conditionals when and unless as macros.
-
-(built-in-macro when
- (lambda (condition . thens)
- `(if ,condition (progn ,@thens) nil)))
-
-(built-in-macro unless
- (lambda (condition . elses)
- `(if ,condition nil (progn ,@elses))))
-
-;;; Impement the cond form as nested if's. A special case is a
-;;; (condition) subform, in which case we need to return the condition
-;;; itself if it is true and thus save it in a local variable before
-;;; testing it.
-
-(built-in-macro cond
- (lambda (. clauses)
- (let iterate ((tail clauses))
- (if (null? tail)
- 'nil
- (let ((cur (car tail))
- (rest (iterate (cdr tail))))
- (prim cond
- ((prim or (not (list? cur)) (null? cur))
- (macro-error "invalid clause in cond" cur))
- ((null? (cdr cur))
- (let ((var (gensym)))
- `(lexical-let ((,var ,(car cur)))
- (if ,var
- ,var
- ,rest))))
- (else
- `(if ,(car cur)
- (progn ,@(cdr cur))
- ,rest))))))))
-
-;;; The `and' and `or' forms can also be easily defined with macros.
-
-(built-in-macro and
- (case-lambda
- (() 't)
- ((x) x)
- ((x . args)
- (let iterate ((x x) (tail args))
- (if (null? tail)
- x
- `(if ,x
- ,(iterate (car tail) (cdr tail))
- nil))))))
-
-(built-in-macro or
- (case-lambda
- (() 'nil)
- ((x) x)
- ((x . args)
- (let iterate ((x x) (tail args))
- (if (null? tail)
- x
- (let ((var (gensym)))
- `(lexical-let ((,var ,x))
- (if ,var
- ,var
- ,(iterate (car tail) (cdr tail))))))))))
-
-;;; Define the dotimes and dolist iteration macros.
-
-(built-in-macro dotimes
- (lambda (args . body)
- (if (prim or
- (not (list? args))
- (< (length args) 2)
- (> (length args) 3))
- (macro-error "invalid dotimes arguments" args)
- (let ((var (car args))
- (count (cadr args)))
- (if (not (symbol? var))
- (macro-error "expected symbol as dotimes variable"))
- `(let ((,var 0))
- (while ((guile-primitive <) ,var ,count)
- ,@body
- (setq ,var ((guile-primitive 1+) ,var)))
- ,@(if (= (length args) 3)
- (list (caddr args))
- '()))))))
-
-(built-in-macro dolist
- (lambda (args . body)
- (if (prim or
- (not (list? args))
- (< (length args) 2)
- (> (length args) 3))
- (macro-error "invalid dolist arguments" args)
- (let ((var (car args))
- (iter-list (cadr args))
- (tailvar (gensym)))
- (if (not (symbol? var))
- (macro-error "expected symbol as dolist variable")
- `(let (,var)
- (lexical-let ((,tailvar ,iter-list))
- (while ((guile-primitive not)
- ((guile-primitive null?) ,tailvar))
- (setq ,var ((guile-primitive car) ,tailvar))
- ,@body
- (setq ,tailvar ((guile-primitive cdr) ,tailvar)))
- ,@(if (= (length args) 3)
- (list (caddr args))
- '()))))))))
-
-;;; Exception handling. unwind-protect and catch are implemented as
-;;; macros (throw is a built-in function).
-
-;;; catch and throw can mainly be implemented directly using Guile's
-;;; primitives for exceptions, the only difficulty is that the keys used
-;;; within Guile must be symbols, while elisp allows any value and
-;;; checks for matches using eq (eq?). We handle this by using always #t
-;;; as key for the Guile primitives and check for matches inside the
-;;; handler; if the elisp keys are not eq?, we rethrow the exception.
-
-(built-in-macro catch
- (lambda (tag . body)
- (if (null? body)
- (macro-error "catch with empty body"))
- (let ((tagsym (gensym)))
- `(lexical-let ((,tagsym ,tag))
- ((guile-primitive catch)
- #t
- (lambda () ,@body)
- ,(let* ((dummy-key (gensym))
- (elisp-key (gensym))
- (value (gensym))
- (arglist `(,dummy-key ,elisp-key ,value)))
- `(with-always-lexical
- ,arglist
- (lambda ,arglist
- (if (eq ,elisp-key ,tagsym)
- ,value
- ((guile-primitive throw) ,dummy-key ,elisp-key
- ,value))))))))))
-
-;;; unwind-protect is just some weaker construct as dynamic-wind, so
-;;; straight-forward to implement.
-
-(built-in-macro unwind-protect
- (lambda (body . clean-ups)
- (if (null? clean-ups)
- (macro-error "unwind-protect without cleanup code"))
- `((guile-primitive dynamic-wind)
- (lambda () nil)
- (lambda () ,body)
- (lambda () ,@clean-ups))))
-
-;;; Pop off the first element from a list or push one to it.
-
-(built-in-macro pop
- (lambda (list-name)
- `(prog1 (car ,list-name)
- (setq ,list-name (cdr ,list-name)))))
-
-(built-in-macro push
- (lambda (new-el list-name)
- `(setq ,list-name (cons ,new-el ,list-name))))
+++ /dev/null
-;;; Guile Emacs Lisp
-
-;;; 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
-
-;;; Code:
-
-(define-module (language elisp runtime subrs)
- #:use-module (language elisp runtime)
- #:use-module (system base compile))
-
-;;; This module contains the function-slots of elisp symbols. Elisp
-;;; built-in functions are implemented as predefined function bindings
-;;; here.
-
-;;; Equivalence and equalness predicates.
-
-(built-in-func eq
- (lambda (a b)
- (elisp-bool (eq? a b))))
-
-(built-in-func equal
- (lambda (a b)
- (elisp-bool (equal? a b))))
-
-;;; Number predicates.
-
-(built-in-func floatp
- (lambda (num)
- (elisp-bool (and (real? num)
- (or (inexact? num)
- (prim not (integer? num)))))))
-
-(built-in-func integerp
- (lambda (num)
- (elisp-bool (and (exact? num)
- (integer? num)))))
-
-(built-in-func numberp
- (lambda (num)
- (elisp-bool (real? num))))
-
-(built-in-func wholenump
- (lambda (num)
- (elisp-bool (and (exact? num)
- (integer? num)
- (prim >= num 0)))))
-
-(built-in-func zerop
- (lambda (num)
- (elisp-bool (prim = num 0))))
-
-;;; Number comparisons.
-
-(built-in-func =
- (lambda (num1 num2)
- (elisp-bool (prim = num1 num2))))
-
-(built-in-func /=
- (lambda (num1 num2)
- (elisp-bool (prim not (prim = num1 num2)))))
-
-(built-in-func <
- (lambda (num1 num2)
- (elisp-bool (prim < num1 num2))))
-
-(built-in-func <=
- (lambda (num1 num2)
- (elisp-bool (prim <= num1 num2))))
-
-(built-in-func >
- (lambda (num1 num2)
- (elisp-bool (prim > num1 num2))))
-
-(built-in-func >=
- (lambda (num1 num2)
- (elisp-bool (prim >= num1 num2))))
-
-(built-in-func max
- (lambda (. nums)
- (prim apply (@ (guile) max) nums)))
-
-(built-in-func min
- (lambda (. nums)
- (prim apply (@ (guile) min) nums)))
-
-(built-in-func abs
- (@ (guile) abs))
-
-;;; Number conversion.
-
-(built-in-func float
- (lambda (num)
- (if (exact? num)
- (exact->inexact num)
- num)))
-
-;;; TODO: truncate, floor, ceiling, round.
-
-;;; Arithmetic functions.
-
-(built-in-func 1+ (@ (guile) 1+))
-
-(built-in-func 1- (@ (guile) 1-))
-
-(built-in-func + (@ (guile) +))
-
-(built-in-func - (@ (guile) -))
-
-(built-in-func * (@ (guile) *))
-
-(built-in-func % (@ (guile) modulo))
-
-;;; TODO: / with correct integer/real behaviour, mod (for floating-piont
-;;; values).
-
-;;; Floating-point rounding operations.
-
-(built-in-func ffloor (@ (guile) floor))
-
-(built-in-func fceiling (@ (guile) ceiling))
-
-(built-in-func ftruncate (@ (guile) truncate))
-
-(built-in-func fround (@ (guile) round))
-
-;;; List predicates.
-
-(built-in-func consp
- (lambda (el)
- (elisp-bool (pair? el))))
-
-(built-in-func atomp
- (lambda (el)
- (elisp-bool (prim not (pair? el)))))
-
-(built-in-func listp
- (lambda (el)
- (elisp-bool (or (pair? el) (null? el)))))
-
-(built-in-func nlistp
- (lambda (el)
- (elisp-bool (and (prim not (pair? el))
- (prim not (null? el))))))
-
-(built-in-func null
- (lambda (el)
- (elisp-bool (null? el))))
-
-;;; Accessing list elements.
-
-(built-in-func car
- (lambda (el)
- (if (null? el)
- nil-value
- (prim car el))))
-
-(built-in-func cdr
- (lambda (el)
- (if (null? el)
- nil-value
- (prim cdr el))))
-
-(built-in-func car-safe
- (lambda (el)
- (if (pair? el)
- (prim car el)
- nil-value)))
-
-(built-in-func cdr-safe
- (lambda (el)
- (if (pair? el)
- (prim cdr el)
- nil-value)))
-
-(built-in-func nth
- (lambda (n lst)
- (if (negative? n)
- (prim car lst)
- (let iterate ((i n)
- (tail lst))
- (cond
- ((null? tail) nil-value)
- ((zero? i) (prim car tail))
- (else (iterate (prim 1- i) (prim cdr tail))))))))
-
-(built-in-func nthcdr
- (lambda (n lst)
- (if (negative? n)
- lst
- (let iterate ((i n)
- (tail lst))
- (cond
- ((null? tail) nil-value)
- ((zero? i) tail)
- (else (iterate (prim 1- i) (prim cdr tail))))))))
-
-(built-in-func length (@ (guile) length))
-
-;;; Building lists.
-
-(built-in-func cons (@ (guile) cons))
-
-(built-in-func list (@ (guile) list))
-
-(built-in-func make-list
- (lambda (len obj)
- (prim make-list len obj)))
-
-(built-in-func append (@ (guile) append))
-
-(built-in-func reverse (@ (guile) reverse))
-
-(built-in-func copy-tree (@ (guile) copy-tree))
-
-(built-in-func number-sequence
- (lambda (from . rest)
- (if (prim > (prim length rest) 2)
- (runtime-error "too many arguments for number-sequence"
- (prim cdddr rest))
- (if (null? rest)
- `(,from)
- (let ((to (prim car rest))
- (sep (if (or (null? (prim cdr rest))
- (eq? nil-value (prim cadr rest)))
- 1
- (prim cadr rest))))
- (cond
- ((or (eq? nil-value to) (prim = to from)) `(,from))
- ((and (zero? sep) (prim not (prim = from to)))
- (runtime-error "infinite list in number-sequence"))
- ((prim < (prim * to sep) (prim * from sep)) '())
- (else
- (let iterate ((i (prim +
- from
- (prim *
- sep
- (prim quotient
- (prim abs
- (prim -
- to
- from))
- (prim abs sep)))))
- (result '()))
- (if (prim = i from)
- (prim cons i result)
- (iterate (prim - i sep)
- (prim cons i result)))))))))))
-
-;;; Changing lists.
-
-(built-in-func setcar
- (lambda (cell val)
- (if (and (null? cell) (null? val))
- #nil
- (prim set-car! cell val))
- val))
-
-(built-in-func setcdr
- (lambda (cell val)
- (if (and (null? cell) (null? val))
- #nil
- (prim set-cdr! cell val))
- val))
-
-;;; Accessing symbol bindings for symbols known only at runtime.
-
-(built-in-func symbol-value
- (lambda (sym)
- (reference-variable value-slot-module sym)))
-
-(built-in-func symbol-function
- (lambda (sym)
- (reference-variable function-slot-module sym)))
-
-(built-in-func set
- (lambda (sym value)
- (set-variable! value-slot-module sym value)))
-
-(built-in-func fset
- (lambda (sym value)
- (set-variable! function-slot-module sym value)))
-
-(built-in-func makunbound
- (lambda (sym)
- (if (module-bound? (resolve-interface value-slot-module) sym)
- (let ((var (module-variable (resolve-module value-slot-module)
- sym)))
- (if (and (variable-bound? var) (fluid? (variable-ref var)))
- (fluid-unset! (variable-ref var))
- (variable-unset! var))))
- sym))
-
-(built-in-func fmakunbound
- (lambda (sym)
- (if (module-bound? (resolve-interface function-slot-module) sym)
- (let ((var (module-variable
- (resolve-module function-slot-module)
- sym)))
- (if (and (variable-bound? var) (fluid? (variable-ref var)))
- (fluid-unset! (variable-ref var))
- (variable-unset! var))))
- sym))
-
-(built-in-func boundp
- (lambda (sym)
- (elisp-bool
- (and
- (module-bound? (resolve-interface value-slot-module) sym)
- (let ((var (module-variable (resolve-module value-slot-module)
- sym)))
- (and (variable-bound? var)
- (if (fluid? (variable-ref var))
- (fluid-bound? (variable-ref var))
- #t)))))))
-
-(built-in-func fboundp
- (lambda (sym)
- (elisp-bool
- (and
- (module-bound? (resolve-interface function-slot-module) sym)
- (let* ((var (module-variable (resolve-module function-slot-module)
- sym)))
- (and (variable-bound? var)
- (if (fluid? (variable-ref var))
- (fluid-bound? (variable-ref var))
- #t)))))))
-
-;;; Function calls. These must take care of special cases, like using
-;;; symbols or raw lambda-lists as functions!
-
-(built-in-func apply
- (lambda (func . args)
- (let ((real-func (cond
- ((symbol? func)
- (reference-variable function-slot-module func))
- ((list? func)
- (if (and (prim not (null? func))
- (eq? (prim car func) 'lambda))
- (compile func #:from 'elisp #:to 'value)
- (runtime-error "list is not a function"
- func)))
- (else func))))
- (prim apply (@ (guile) apply) real-func args))))
-
-(built-in-func funcall
- (lambda (func . args)
- (apply func args)))
-
-;;; Throw can be implemented as built-in function.
-
-(built-in-func throw
- (lambda (tag value)
- (prim throw 'elisp-exception tag value)))
-
-;;; Miscellaneous.
-
-(built-in-func not
- (lambda (x)
- (if x nil-value t-value)))
-
-(built-in-func eval
- (lambda (form)
- (compile form #:from 'elisp #:to 'value)))
-
-(built-in-func load
- (lambda* (file)
- (compile-file file #:from 'elisp #:to 'value)
- #t))
;;; Code:
-(define-module (language elisp runtime value-slot))
+(define-module (language elisp runtime value-slot)
+ #:pure)
;;; This module contains the value-slots of elisp symbols.
#:use-module (language elisp compile-tree-il)
#:use-module (language elisp parser)
#:use-module (system base language)
+ #:use-module (system base compile)
#:export (elisp))
(define-language elisp
#:reader (lambda (port env) (read-elisp port))
#:printer write
#:compilers `((tree-il . ,compile-tree-il)))
+
+(compile-and-load (%search-load-path "language/elisp/boot.el")
+ #:from 'elisp)
+++ /dev/null
-;;; Guile Low Intermediate Language
-
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
-
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of 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 glil)
- #:use-module (system base syntax)
- #:use-module (system base pmatch)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:export
- (<glil-program> make-glil-program glil-program?
- 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
-
- <glil-mv-bind> make-glil-mv-bind glil-mv-bind?
- glil-mv-bind-vars glil-mv-bind-rest
-
- <glil-unbind> make-glil-unbind glil-unbind?
-
- <glil-source> make-glil-source glil-source?
- glil-source-props
-
- <glil-void> make-glil-void glil-void?
-
- <glil-const> make-glil-const glil-const?
- glil-const-obj
-
- <glil-lexical> make-glil-lexical glil-lexical?
- glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
-
- <glil-toplevel> make-glil-toplevel glil-toplevel?
- glil-toplevel-op glil-toplevel-name
-
- <glil-module> make-glil-module glil-module?
- glil-module-op glil-module-mod glil-module-name glil-module-public?
-
- <glil-label> make-glil-label glil-label?
- glil-label-label
-
- <glil-branch> make-glil-branch glil-branch?
- glil-branch-inst glil-branch-label
-
- <glil-call> make-glil-call glil-call?
- glil-call-inst glil-call-nargs
-
- <glil-mv-call> make-glil-mv-call glil-mv-call?
- glil-mv-call-nargs glil-mv-call-ra
-
- <glil-prompt> make-glil-prompt glil-prompt? glil-prompt-label glil-prompt-escape-only?
-
- parse-glil unparse-glil))
-
-(define (print-glil x port)
- (format port "#<glil ~s>" (unparse-glil x)))
-
-(define-type (<glil> #:printer print-glil)
- ;; Meta operations
- (<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>)
- (<glil-source> props)
- ;; Objects
- (<glil-void>)
- (<glil-const> obj)
- ;; Variables
- (<glil-lexical> local? boxed? op index)
- (<glil-toplevel> op name)
- (<glil-module> op mod name public?)
- ;; Controls
- (<glil-label> label)
- (<glil-branch> inst label)
- (<glil-call> inst nargs)
- (<glil-mv-call> nargs ra)
- (<glil-prompt> label escape-only?))
-
-\f
-
-(define (parse-glil x)
- (pmatch x
- ((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))
- ((source ,props) (make-glil-source props))
- ((void) (make-glil-void))
- ((const ,obj) (make-glil-const obj))
- ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
- ((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-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))
- ((prompt ,label ,escape-only?)
- (make-glil-prompt label escape-only?))
- (else (error "invalid glil" x))))
-
-(define (unparse-glil glil)
- (record-case glil
- ;; meta
- ((<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))
- ((<glil-source> props) `(source ,props))
- ;; constants
- ((<glil-void>) `(void))
- ((<glil-const> obj) `(const ,obj))
- ;; variables
- ((<glil-lexical> local? boxed? op index)
- `(lexical ,local? ,boxed? ,op ,index))
- ((<glil-toplevel> op name)
- `(toplevel ,op ,name))
- ((<glil-module> op mod name public?)
- `(module ,(if public? 'public 'private) ,op ,mod ,name))
- ;; controls
- ((<glil-label> label) `(label ,label))
- ((<glil-branch> inst label) `(branch ,inst ,label))
- ((<glil-call> inst nargs) `(call ,inst ,nargs))
- ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,ra))
- ((<glil-prompt> label escape-only?)
- `(prompt ,label escape-only?))))
+++ /dev/null
-;;; Guile VM assembler
-
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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 glil compile-assembly)
- #:use-module (system base syntax)
- #:use-module (system base pmatch)
- #:use-module (language glil)
- #:use-module (language assembly)
- #:use-module (system vm instruction)
- #:use-module ((system vm program) #:select (make-binding))
- #:use-module (ice-9 receive)
- #:use-module (ice-9 vlist)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:use-module (rnrs bytevectors)
- #:export (compile-assembly))
-
-;; Traversal helpers
-;;
-(define (vhash-fold-right2 proc vhash s0 s1)
- (let lp ((i (vlist-length vhash)) (s0 s0) (s1 s1))
- (if (zero? i)
- (values s0 s1)
- (receive (s0 s1) (let ((pair (vlist-ref vhash (1- i))))
- (proc (car pair) (cdr pair) s0 s1))
- (lp (1- i) s0 s1)))))
-
-(define (fold2 proc ls s0 s1)
- (let lp ((ls ls) (s0 s0) (s1 s1))
- (if (null? ls)
- (values s0 s1)
- (receive (s0 s1) (proc (car ls) s0 s1)
- (lp (cdr ls) s0 s1)))))
-
-(define (vector-fold2 proc vect s0 s1)
- (let ((len (vector-length vect)))
- (let lp ((i 0) (s0 s0) (s1 s1))
- (if (< i len)
- (receive (s0 s1) (proc (vector-ref vect i) s0 s1)
- (lp (1+ i) s0 s1))
- (values s0 s1)))))
-
-;; Variable cache cells go in the object table, and serialize as their
-;; keys. The reason we wrap the keys in these records is so they don't
-;; compare as `equal?' to other objects in the object table.
-;;
-;; `key' is either a symbol or the list (MODNAME SYM PUBLIC?)
-
-(define-record <variable-cache-cell> key)
-
-(define (limn-sources sources)
- (let lp ((in sources) (out '()) (filename #f))
- (if (null? in)
- (reverse! out)
- (let ((addr (caar in))
- (new-filename (assq-ref (cdar in ) 'filename))
- (line (assq-ref (cdar in) 'line))
- (column (assq-ref (cdar in) 'column)))
- (cond
- ((not (equal? new-filename filename))
- (lp (cdr in)
- `((,addr . (,line . ,column))
- (filename . ,new-filename)
- . ,out)
- new-filename))
- ((or (null? out) (not (equal? (cdar out) `(,line . ,column))))
- (lp (cdr in)
- `((,addr . (,line . ,column))
- . ,out)
- filename))
- (else
- (lp (cdr in) out filename)))))))
-
-
-;; Avoid going through the compiler so as to avoid adding to the
-;; constant store.
-(define (make-meta bindings sources arities tail)
- (let ((body `(,@(dump-object `(,bindings ,sources ,arities ,@tail) 0)
- (return))))
- `(load-program ()
- ,(addr+ 0 body)
- #f
- ,@body)))
-
-;; If this is true, the object doesn't need to go in a constant table.
-;;
-(define (immediate? x)
- (object->assembly x))
-
-;; This tests for a proper scheme list whose last cdr is '(), not #nil.
-;;
-(define (scheme-list? x)
- (and (list? x)
- (or (eq? x '())
- (let ((p (last-pair x)))
- (and (pair? p)
- (eq? (cdr p) '()))))))
-
-;; Note: in all of these procedures that build up constant tables, the
-;; first (zeroth) index is reserved. At runtime it is replaced with the
-;; procedure's module. Hence all of this 1+ length business.
-
-;; Build up a vhash of constant -> index, allowing us to build up a
-;; constant table for a whole compilation unit.
-;;
-(define (build-constant-store x)
- (define (add-to-store store x)
- (define (add-to-end store x)
- (vhash-cons x (1+ (vlist-length store)) store))
- (cond
- ((vhash-assoc x store)
- ;; Already in the store.
- store)
- ((immediate? x)
- ;; Immediates don't need to go in the constant table.
- store)
- ((or (number? x)
- (string? x)
- (symbol? x)
- (keyword? x))
- ;; Atoms.
- (add-to-end store x))
- ((variable-cache-cell? x)
- ;; Variable cache cells (see below).
- (add-to-end (add-to-store store (variable-cache-cell-key x))
- x))
- ((list? x)
- ;; Add the elements to the store, then the list itself. We could
- ;; try hashing the cdrs as well, but that seems a bit overkill, and
- ;; this way we do compress the bytecode a bit by allowing the use of
- ;; the `list' opcode.
- (let ((store (fold (lambda (x store)
- (add-to-store store x))
- store
- x)))
- (add-to-end store x)))
- ((pair? x)
- ;; Non-lists get caching on both fields.
- (let ((store (add-to-store (add-to-store store (car x))
- (cdr x))))
- (add-to-end store x)))
- ((and (vector? x)
- (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
- ;; Likewise, add the elements to the store, then the vector itself.
- ;; Important for the vectors produced by the psyntax expansion
- ;; process.
- (let ((store (fold (lambda (x store)
- (add-to-store store x))
- store
- (vector->list x))))
- (add-to-end store x)))
- ((array? x)
- ;; Naive assumption that if folks are using arrays, that perhaps
- ;; there's not much more duplication.
- (add-to-end store x))
- (else
- (error "build-constant-store: unrecognized object" x))))
-
- (let walk ((x x) (store vlist-null))
- (record-case x
- ((<glil-program> meta body)
- (fold walk store body))
- ((<glil-const> obj)
- (add-to-store store obj))
- ((<glil-kw-prelude> kw)
- (add-to-store store kw))
- ((<glil-toplevel> op name)
- ;; We don't add toplevel variable cache cells to the global
- ;; constant table, because they are sensitive to changes in
- ;; modules as the toplevel expressions are evaluated. So we just
- ;; add the name.
- (add-to-store store name))
- ((<glil-module> op mod name public?)
- ;; However, it is fine add module variable cache cells to the
- ;; global table, as their bindings are not dependent on the
- ;; current module.
- (add-to-store store
- (make-variable-cache-cell (list mod name public?))))
- (else store))))
-
-;; Analyze one <glil-program> to determine its object table. Produces a
-;; vhash of constant to index.
-;;
-(define (build-object-table x)
- (define (add store x)
- (if (vhash-assoc x store)
- store
- (vhash-cons x (1+ (vlist-length store)) store)))
- (record-case x
- ((<glil-program> meta body)
- (fold (lambda (x table)
- (record-case x
- ((<glil-program> meta body)
- ;; Add the GLIL itself to the table.
- (add table x))
- ((<glil-const> obj)
- (if (immediate? obj)
- table
- (add table obj)))
- ((<glil-kw-prelude> kw)
- (add table kw))
- ((<glil-toplevel> op name)
- (add table (make-variable-cache-cell name)))
- ((<glil-module> op mod name public?)
- (add table (make-variable-cache-cell (list mod name public?))))
- (else table)))
- vlist-null
- body))))
-
-;; A functional stack of names of live variables.
-(define (make-open-binding name boxed? index)
- (list name boxed? index))
-(define (make-closed-binding open-binding start end)
- (make-binding (car open-binding) (cadr open-binding)
- (caddr open-binding) start end))
-(define (open-binding bindings vars start)
- (cons
- (acons start
- (map
- (lambda (v)
- (pmatch v
- ((,name ,boxed? ,i)
- (make-open-binding name boxed? i))
- (else (error "unknown binding type" v))))
- vars)
- (car bindings))
- (cdr bindings)))
-(define (close-binding bindings end)
- (pmatch bindings
- ((((,start . ,closing) . ,open) . ,closed)
- (cons open
- (fold (lambda (o tail)
- ;; the cons is for dsu sort
- (acons start (make-closed-binding o start end)
- tail))
- closed
- closing)))
- (else (error "broken bindings" bindings))))
-(define (close-all-bindings bindings end)
- (if (null? (car bindings))
- (map cdr
- (stable-sort (reverse (cdr bindings))
- (lambda (x y) (< (car x) (car y)))))
- (close-all-bindings (close-binding bindings end) end)))
-
-
-;; 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)
- (let* ((all-constants (build-constant-store glil))
- (prog (compile-program glil all-constants))
- (len (byte-length prog)))
- ;; The top objcode thunk. We're going to wrap this thunk in
- ;; a thunk -- yo dawgs -- with the goal being to lift all
- ;; constants up to the top level. The store forms a DAG, so
- ;; we can actually build up later elements in terms of
- ;; earlier ones.
- ;;
- (cond
- ((vlist-null? all-constants)
- ;; No constants: just emit the inner thunk.
- prog)
- (else
- ;; We have an object store, so write it out, attach it
- ;; to the inner thunk, and tail call.
- (receive (tablecode addr) (dump-constants all-constants)
- (let ((prog (align-program prog addr)))
- ;; Outer thunk.
- `(load-program ()
- ,(+ (addr+ addr prog)
- 2 ; for (tail-call 0)
- )
- #f
- ;; Load the table, build the inner
- ;; thunk, then tail call.
- ,@tablecode
- ,@prog
- (tail-call 0))))))))
-
-(define (compile-program glil constants)
- (record-case glil
- ((<glil-program> meta body)
- (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
- (label-alist '()) (arities '()) (addr 0))
- (cond
- ((null? body)
- (let ((code (fold append '() code))
- (bindings (close-all-bindings bindings addr))
- (sources (limn-sources (reverse! source-alist)))
- (labels (reverse label-alist))
- (arities (reverse (close-arity addr arities)))
- (len addr))
- (let* ((meta (make-meta bindings sources arities meta))
- (meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0)))
- `(load-program ,labels
- ,(+ len meta-pad)
- ,meta
- ,@code
- ,@(if meta
- (make-list meta-pad '(nop))
- '())))))
- (else
- (receive (subcode bindings source-alist label-alist arities)
- (glil->assembly (car body) bindings
- source-alist label-alist
- constants arities addr)
- (lp (cdr body) (cons subcode code)
- bindings source-alist label-alist arities
- (addr+ addr subcode)))))))))
-
-(define (compile-objtable constants table addr)
- (define (load-constant idx)
- (if (< idx 256)
- (values `((object-ref ,idx))
- 2)
- (values `((long-object-ref
- ,(quotient idx 256) ,(modulo idx 256)))
- 3)))
- (cond
- ((vlist-null? table)
- ;; Empty table; just return #f.
- (values '((make-false))
- (1+ addr)))
- (else
- (call-with-values
- (lambda ()
- (vhash-fold-right2
- (lambda (obj idx codes addr)
- (cond
- ((vhash-assoc obj constants)
- => (lambda (pair)
- (receive (load len) (load-constant (cdr pair))
- (values (cons load codes)
- (+ addr len)))))
- ((variable-cache-cell? obj)
- (cond
- ((vhash-assoc (variable-cache-cell-key obj) constants)
- => (lambda (pair)
- (receive (load len) (load-constant (cdr pair))
- (values (cons load codes)
- (+ addr len)))))
- (else (error "vcache cell key not in table" obj))))
- ((glil-program? obj)
- ;; Programs are not cached in the global constants
- ;; table because when a program is loaded, its module
- ;; is bound, and we want to do that only after any
- ;; preceding effectful statements.
- (let* ((table (build-object-table obj))
- (prog (compile-program obj table)))
- (receive (tablecode addr)
- (compile-objtable constants table addr)
- (let ((prog (align-program prog addr)))
- (values (cons `(,@tablecode ,@prog)
- codes)
- (addr+ addr prog))))))
- (else
- (error "unrecognized constant" obj))))
- table
- '(((make-false))) (1+ addr)))
- (lambda (elts addr)
- (let ((len (1+ (vlist-length table))))
- (values
- (fold append
- `((vector ,(quotient len 256) ,(modulo len 256)))
- elts)
- (+ addr 3))))))))
-
-(define (glil->assembly glil bindings source-alist label-alist
- constants arities addr)
- (define (emit-code x)
- (values x bindings source-alist label-alist arities))
- (define (emit-object-ref i)
- (values (if (< i 256)
- `((object-ref ,i))
- `((long-object-ref ,(quotient i 256) ,(modulo i 256))))
- bindings source-alist label-alist arities))
- (define (emit-code/arity x nreq nopt rest kw)
- (values x bindings source-alist label-alist
- (begin-arity addr (addr+ addr x) nreq nopt rest kw arities)))
-
- (record-case glil
- ((<glil-program> meta body)
- (cond
- ((vhash-assoc glil constants)
- ;; We are cached in someone's objtable; just emit a load.
- => (lambda (pair)
- (emit-object-ref (cdr pair))))
- (else
- ;; Otherwise, build an objtable for the program, compile it, and
- ;; emit a load-program.
- (let* ((table (build-object-table glil))
- (prog (compile-program glil table)))
- (receive (tablecode addr) (compile-objtable constants table addr)
- (emit-code `(,@tablecode ,@(align-program prog addr))))))))
-
- ((<glil-std-prelude> nreq nlocs else-label)
- (emit-code/arity
- (if (and (< nreq 8) (< nlocs (+ nreq 32)) (not else-label))
- `((assert-nargs-ee/locals ,(logior nreq (ash (- nlocs nreq) 3))))
- `(,(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)
- (let* ((kw-idx (or (and=> (vhash-assoc kw constants) cdr)
- (error "kw not in objtable")))
- (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
- `((,(if (and else-label (not rest))
- 'bind-optionals/shuffle-or-br
- 'bind-optionals/shuffle)
- ,(quotient nreq 256)
- ,(modulo nreq 256)
- ,(quotient (+ nreq nopt) 256)
- ,(modulo (+ nreq nopt) 256)
- ,(quotient ntotal 256)
- ,(modulo ntotal 256)
- ,@(if (and else-label (not rest))
- `(,else-label)
- '()))))
- (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
- (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
- arities))
-
- ((<glil-mv-bind> vars rest)
- (if (integer? vars)
- (values `((truncate-values ,vars ,(if rest 1 0)))
- bindings
- source-alist
- label-alist
- arities)
- (values `((truncate-values ,(length vars) ,(if rest 1 0)))
- (open-binding bindings vars addr)
- source-alist
- label-alist
- arities)))
-
- ((<glil-unbind>)
- (values '()
- (close-binding bindings addr)
- source-alist
- label-alist
- arities))
-
- ((<glil-source> props)
- (values '()
- bindings
- (acons addr props source-alist)
- label-alist
- arities))
-
- ((<glil-void>)
- (emit-code '((void))))
-
- ((<glil-const> obj)
- (cond
- ((object->assembly obj)
- => (lambda (code)
- (emit-code (list code))))
- ((vhash-assoc obj constants)
- => (lambda (pair)
- (emit-object-ref (cdr pair))))
- (else (error "const not in table" obj))))
-
- ((<glil-lexical> local? boxed? op index)
- (emit-code
- (if local?
- (if (< index 256)
- (case op
- ((ref) (if boxed?
- `((local-boxed-ref ,index))
- `((local-ref ,index))))
- ((set) (if boxed?
- `((local-boxed-set ,index))
- `((local-set ,index))))
- ((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 index 256))
- (b (modulo index 256)))
- (case op
- ((ref)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-ref))
- `((long-local-ref ,a ,b))))
- ((set)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-set))
- `((long-local-set ,a ,b))))
- ((box)
- `((make-variable)
- (variable-set)
- (long-local-set ,a ,b)))
- ((empty-box)
- `((make-variable)
- (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)))))
- `((,(case op
- ((ref) (if boxed? 'free-boxed-ref 'free-ref))
- ((set) (if boxed? 'free-boxed-set (error "what." glil)))
- (else (error "what" op)))
- ,index)))))
-
- ((<glil-toplevel> op name)
- (case op
- ((ref set)
- (cond
- ((and=> (vhash-assoc (make-variable-cache-cell name) constants)
- cdr)
- => (lambda (i)
- (emit-code (if (< i 256)
- `((,(case op
- ((ref) 'toplevel-ref)
- ((set) 'toplevel-set))
- ,i))
- `((,(case op
- ((ref) 'long-toplevel-ref)
- ((set) 'long-toplevel-set))
- ,(quotient i 256)
- ,(modulo i 256)))))))
- (else
- (let ((i (or (and=> (vhash-assoc name constants) cdr)
- (error "toplevel name not in objtable" name))))
- (emit-code `(,(if (< i 256)
- `(object-ref ,i)
- `(long-object-ref ,(quotient i 256)
- ,(modulo i 256)))
- (link-now)
- ,(case op
- ((ref) '(variable-ref))
- ((set) '(variable-set)))))))))
- ((define)
- (let ((i (or (and=> (vhash-assoc name constants) cdr)
- (error "toplevel name not in objtable" name))))
- (emit-code `(,(if (< i 256)
- `(object-ref ,i)
- `(long-object-ref ,(quotient i 256)
- ,(modulo i 256)))
- (define)))))
- (else
- (error "unknown toplevel var kind" op name))))
-
- ((<glil-module> op mod name public?)
- (let ((key (list mod name public?)))
- (case op
- ((ref set)
- (let ((i (or (and=> (vhash-assoc (make-variable-cache-cell key)
- constants) cdr)
- (error "module vcache not in objtable" key))))
- (emit-code (if (< i 256)
- `((,(case op
- ((ref) 'toplevel-ref)
- ((set) 'toplevel-set))
- ,i))
- `((,(case op
- ((ref) 'long-toplevel-ref)
- ((set) 'long-toplevel-set))
- ,(quotient i 256)
- ,(modulo i 256)))))))
- (else
- (error "unknown module var kind" op key)))))
-
- ((<glil-label> label)
- (let ((code (align-block addr)))
- (values code
- bindings
- source-alist
- (acons label (addr+ addr code) label-alist)
- arities)))
-
- ((<glil-branch> inst label)
- (emit-code `((,inst ,label))))
-
- ;; nargs is number of stack args to insn. probably should rename.
- ((<glil-call> inst nargs)
- (if (not (instruction? inst))
- (error "Unknown instruction:" inst))
- (let ((pops (instruction-pops inst)))
- (cond ((< pops 0)
- (case (instruction-length inst)
- ((1) (emit-code `((,inst ,nargs))))
- ((2) (emit-code `((,inst ,(quotient nargs 256)
- ,(modulo nargs 256)))))
- (else (error "Unknown length for variable-arg instruction:"
- inst (instruction-length inst)))))
- ((= pops nargs)
- (emit-code `((,inst))))
- (else
- (error "Wrong number of stack arguments to instruction:" inst nargs)))))
-
- ((<glil-mv-call> nargs ra)
- (emit-code `((mv-call ,nargs ,ra))))
-
- ((<glil-prompt> label escape-only?)
- (emit-code `((prompt ,(if escape-only? 1 0) ,label))))))
-
-(define (dump-object x addr)
- (define (too-long x)
- (error (string-append x " too long")))
-
- (cond
- ((object->assembly x) => list)
- ((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
- ((number? x)
- `((load-number ,(number->string x))))
- ((string? x)
- (case (string-bytes-per-char x)
- ((1) `((load-string ,x)))
- ((4) (align-code `(load-wide-string ,x) addr 4 4))
- (else (error "bad string bytes per char" x))))
- ((symbol? x)
- (let ((str (symbol->string x)))
- (case (string-bytes-per-char str)
- ((1) `((load-symbol ,str)))
- ((4) `(,@(dump-object str addr)
- (make-symbol)))
- (else (error "bad string bytes per char" str)))))
- ((keyword? x)
- `(,@(dump-object (keyword->symbol x) addr)
- (make-keyword)))
- ((scheme-list? x)
- (let ((tail (let ((len (length x)))
- (if (>= len 65536) (too-long "list"))
- `((list ,(quotient len 256) ,(modulo len 256))))))
- (let dump-objects ((objects x) (codes '()) (addr addr))
- (if (null? objects)
- (fold append tail codes)
- (let ((code (dump-object (car objects) addr)))
- (dump-objects (cdr objects) (cons code codes)
- (addr+ addr code)))))))
- ((pair? x)
- (let ((kar (dump-object (car x) addr)))
- `(,@kar
- ,@(dump-object (cdr x) (addr+ addr kar))
- (cons))))
- ((and (vector? x)
- (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
- (let* ((len (vector-length x))
- (tail (if (>= len 65536)
- (too-long "vector")
- `((vector ,(quotient len 256) ,(modulo len 256))))))
- (let dump-objects ((i 0) (codes '()) (addr addr))
- (if (>= i len)
- (fold append tail codes)
- (let ((code (dump-object (vector-ref x i) addr)))
- (dump-objects (1+ i) (cons code codes)
- (addr+ addr code)))))))
- ((and (array? x) (symbol? (array-type x)))
- (let* ((type (dump-object (array-type x) addr))
- (shape (dump-object (array-shape x) (addr+ addr type))))
- `(,@type
- ,@shape
- ,@(align-code
- `(load-array ,(uniform-array->bytevector x))
- (addr+ (addr+ addr type) shape)
- 8
- 4))))
- ((array? x)
- ;; an array of generic scheme values
- (let* ((contents (array-contents x))
- (len (vector-length contents)))
- (let dump-objects ((i 0) (codes '()) (addr addr))
- (if (< i len)
- (let ((code (dump-object (vector-ref contents i) addr)))
- (dump-objects (1+ i) (cons code codes)
- (addr+ addr code)))
- (fold append
- `(,@(dump-object (array-shape x) addr)
- (make-array ,(quotient (ash len -16) 256)
- ,(logand #xff (ash len -8))
- ,(logand #xff len)))
- codes)))))
- (else
- (error "dump-object: unrecognized object" x))))
-
-(define (dump-constants constants)
- (define (ref-or-dump x i addr)
- (let ((pair (vhash-assoc x constants)))
- (if (and pair (< (cdr pair) i))
- (let ((idx (cdr pair)))
- (if (< idx 256)
- (values `((object-ref ,idx))
- (+ addr 2))
- (values `((long-object-ref ,(quotient idx 256)
- ,(modulo idx 256)))
- (+ addr 3))))
- (dump1 x i addr))))
- (define (dump1 x i addr)
- (cond
- ((object->assembly x)
- => (lambda (code)
- (values (list code)
- (+ (byte-length code) addr))))
- ((or (number? x)
- (string? x)
- (symbol? x)
- (keyword? x))
- ;; Atoms.
- (let ((code (dump-object x addr)))
- (values code (addr+ addr code))))
- ((variable-cache-cell? x)
- (dump1 (variable-cache-cell-key x) i addr))
- ((scheme-list? x)
- (receive (codes addr)
- (fold2 (lambda (x codes addr)
- (receive (subcode addr) (ref-or-dump x i addr)
- (values (cons subcode codes) addr)))
- x '() addr)
- (values (fold append
- (let ((len (length x)))
- `((list ,(quotient len 256) ,(modulo len 256))))
- codes)
- (+ addr 3))))
- ((pair? x)
- (receive (car-code addr) (ref-or-dump (car x) i addr)
- (receive (cdr-code addr) (ref-or-dump (cdr x) i addr)
- (values `(,@car-code ,@cdr-code (cons))
- (1+ addr)))))
- ((and (vector? x)
- (<= (vector-length x) #xffff)
- (equal? (array-shape x) (list (list 0 (1- (vector-length x))))))
- (receive (codes addr)
- (vector-fold2 (lambda (x codes addr)
- (receive (subcode addr) (ref-or-dump x i addr)
- (values (cons subcode codes) addr)))
- x '() addr)
- (values (fold append
- (let ((len (vector-length x)))
- `((vector ,(quotient len 256) ,(modulo len 256))))
- codes)
- (+ addr 3))))
- ((and (array? x) (symbol? (array-type x)))
- (receive (type addr) (ref-or-dump (array-type x) i addr)
- (receive (shape addr) (ref-or-dump (array-shape x) i addr)
- (let ((bv (align-code `(load-array ,(uniform-array->bytevector x))
- addr 8 4)))
- (values `(,@type ,@shape ,@bv)
- (addr+ addr bv))))))
- ((array? x)
- (let ((contents (array-contents x)))
- (receive (codes addr)
- (vector-fold2 (lambda (x codes addr)
- (receive (subcode addr) (ref-or-dump x i addr)
- (values (cons subcode codes) addr)))
- contents '() addr)
- (receive (shape addr) (ref-or-dump (array-shape x) i addr)
- (values (fold append
- (let ((len (vector-length contents)))
- `(,@shape
- (make-array ,(quotient (ash len -16) 256)
- ,(logand #xff (ash len -8))
- ,(logand #xff len))))
- codes)
- (+ addr 4))))))
- (else
- (error "write-table: unrecognized object" x))))
-
- (receive (codes addr)
- (vhash-fold-right2 (lambda (obj idx code addr)
- ;; The vector is on the stack. Dup it, push
- ;; the index, push the val, then vector-set.
- (let ((pre `((dup)
- ,(object->assembly idx))))
- (receive (valcode addr) (dump1 obj idx
- (addr+ addr pre))
- (values (cons* '((vector-set))
- valcode
- pre
- code)
- (1+ addr)))))
- constants
- '(((assert-nargs-ee/locals 1)
- ;; Push the vector.
- (local-ref 0)))
- 4)
- (let* ((len (1+ (vlist-length constants)))
- (pre-prog-addr (+ 2 ; reserve-locals
- len 3 ; empty vector
- 2 ; local-set
- 1 ; new-frame
- 2 ; local-ref
- ))
- (prog (align-program
- `(load-program ()
- ,(+ addr 1)
- #f
- ;; The `return' will be at the tail of the
- ;; program. The vector is already pushed
- ;; on the stack.
- . ,(fold append '((return)) codes))
- pre-prog-addr)))
- (values `(;; Reserve storage for the vector.
- (assert-nargs-ee/locals ,(logior 0 (ash 1 3)))
- ;; Push the vector, and store it in slot 0.
- ,@(make-list len '(make-false))
- (vector ,(quotient len 256) ,(modulo len 256))
- (local-set 0)
- ;; Now we open the call frame.
- ;;
- (new-frame)
- ;; Now build a thunk to init the constants. It will
- ;; have the unfinished constant table both as its
- ;; argument and as its objtable. The former allows it
- ;; to update the objtable, with vector-set!, and the
- ;; latter allows init code to refer to previously set
- ;; values.
- ;;
- ;; Grab the vector, to be the objtable.
- (local-ref 0)
- ;; Now the load-program, properly aligned. Pops the vector.
- ,@prog
- ;; Grab the vector, as an argument this time.
- (local-ref 0)
- ;; Call the init thunk with the vector as an arg.
- (call 1)
- ;; The thunk also returns the vector. Leave it on the
- ;; stack for compile-assembly to use.
- )
- ;; The byte length of the init code, which we can
- ;; determine without folding over the code again.
- (+ (addr+ pre-prog-addr prog) ; aligned program
- 2 ; local-ref
- 2 ; call
- )))))
+++ /dev/null
-;;; Guile Virtual Machine Object Code
-
-;; 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 objcode)
- #:export (encode-length decode-length))
-
-\f
-;;;
-;;; Variable-length interface
-;;;
-
-;; NOTE: decoded in vm_fetch_length in vm.c as well.
-
-(define (encode-length len)
- (cond ((< len 254) (u8vector len))
- ((< len (* 256 256))
- (u8vector 254 (quotient len 256) (modulo len 256)))
- ((< len most-positive-fixnum)
- (u8vector 255
- (quotient len (* 256 256 256))
- (modulo (quotient len (* 256 256)) 256)
- (modulo (quotient len 256) 256)
- (modulo len 256)))
- (else (error "Too long code length:" len))))
-
-(define (decode-length pop)
- (let ((x (pop)))
- (cond ((< x 254) x)
- ((= x 254) (+ (ash x 8) (pop)))
- (else
- (let* ((b2 (pop))
- (b3 (pop))
- (b4 (pop)))
- (+ (ash x 24) (ash b2 16) (ash b3 8) b4))))))
+++ /dev/null
-;;; Guile Lowlevel Intermediate Language
-
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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 objcode spec)
- #:use-module (system base language)
- #:use-module (system vm objcode)
- #:use-module (system vm program)
- #:export (objcode))
-
-(define (objcode->value x e opts)
- (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 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
-;; the returned locals set is a list, where element N of the list is
-;; itself a list of bindings for local variable N.
-(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))))))))
-
-(define (decompile-value x env opts)
- (cond
- ((program? x)
- (let ((objs (program-objects x))
- (meta (program-meta x))
- (free-vars (program-free-variables x))
- (binds (program-bindings x))
- (srcs (program-sources x)))
- (let ((blocs (and binds (collapse-locals binds))))
- (values (program-objcode x)
- `((objects . ,objs)
- (meta . ,(and meta (meta)))
- (free-vars . ,free-vars)
- (blocs . ,blocs)
- (sources . ,srcs))))))
- ((objcode? x)
- (values x #f))
- (else
- (error "Object for disassembly not a program or objcode" x))))
-
-(define-language objcode
- #:title "Guile Object Code"
- #:reader #f
- #:printer write-objcode
- #:compilers `((value . ,objcode->value))
- #:decompilers `((value . ,decompile-value))
- #:for-humans? #f
- )
exp
`(quote ,exp)))
- ((<sequence> exps)
- (build-begin (map recurse exps)))
+ ((<seq> head tail)
+ (build-begin (cons (recurse head)
+ (build-begin-body
+ (recurse tail)))))
- ((<application> proc args)
+ ((<call> proc args)
(match `(,(recurse proc) ,@(map recurse args))
((('lambda (formals ...) body ...) args ...)
(=> failure)
(failure)))
(e e)))
+ ((<primcall> name args)
+ `(,name ,@(map recurse args)))
+
((<primitive-ref> name)
name)
`(call-with-values (lambda () ,@(recurse-body exp))
,(recurse (make-lambda #f '() body))))
- ((<dynwind> body winder unwinder)
- `(dynamic-wind ,(recurse winder)
- (lambda () ,@(recurse-body body))
- ,(recurse unwinder)))
-
- ((<dynlet> fluids vals body)
- `(with-fluids ,(map list
- (map recurse fluids)
- (map recurse vals))
- ,@(recurse-body body)))
-
- ((<dynref> fluid)
- `(fluid-ref ,(recurse fluid)))
-
- ((<dynset> fluid exp)
- `(fluid-set! ,(recurse fluid) ,(recurse exp)))
-
- ((<prompt> tag body handler)
+ ((<prompt> escape-only? tag body handler)
`(call-with-prompt
,(recurse tag)
- (lambda () ,@(recurse-body body))
+ ,(if escape-only?
+ `(lambda () ,(recurse body))
+ (recurse body))
,(recurse handler)))
((<void>) (primitive 'if)) ; (if #f #f)
((<const>) (primitive 'quote))
- ((<application> proc args)
+ ((<call> proc args)
(if (lexical-ref? proc)
(let* ((gensym (lexical-ref-gensym proc))
(name (source-name gensym)))
(for-each recurse args))
((<primitive-ref> name) (primitive name))
+ ((<primcall> name args) (primitive name) (for-each recurse args))
((<lexical-ref> gensym) (lexical gensym))
((<lexical-set> gensym exp)
(primitive 'if)
(recurse test) (recurse consequent) (recurse alternate))
- ((<sequence> exps) (primitive 'begin) (for-each recurse exps))
+ ((<seq> head tail)
+ (primitive 'begin) (recurse head) (recurse tail))
+
((<lambda> body)
(if body (recurse body) (primitive 'case-lambda)))
(primitive 'call-with-values)
(recurse exp) (recurse body))
- ((<dynwind> winder body unwinder)
- (primitive 'dynamic-wind)
- (recurse winder) (recurse body) (recurse unwinder))
-
- ((<dynlet> fluids vals body)
- (primitive 'with-fluids)
- (for-each recurse fluids)
- (for-each recurse vals)
- (recurse body))
-
- ((<dynref> fluid) (primitive 'fluid-ref) (recurse fluid))
- ((<dynset> fluid exp)
- (primitive 'fluid-set!) (recurse fluid) (recurse exp))
-
((<prompt> tag body handler)
(primitive 'call-with-prompt)
- (primitive 'lambda)
(recurse tag) (recurse body) (recurse handler))
((<abort> tag args tail)
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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 (language tree-il)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
- #:use-module (system base pmatch)
+ #:use-module (ice-9 match)
#:use-module (system base syntax)
#:export (tree-il-src
<toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
<toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
<conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
- <application> application? make-application application-src application-proc application-args
- <sequence> sequence? make-sequence sequence-src sequence-exps
+ <call> call? make-call call-src call-proc call-args
+ <primcall> primcall? make-primcall primcall-src primcall-name primcall-args
+ <seq> seq? make-seq seq-src seq-head seq-tail
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src
+ ;; idea: arity
lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
lambda-case-inits lambda-case-gensyms
lambda-case-body lambda-case-alternate
<letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
- <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
- <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
- <dynref> dynref? make-dynref dynref-src dynref-fluid
- <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
- <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
+ <prompt> prompt? make-prompt prompt-src prompt-escape-only? prompt-tag prompt-body prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
+ list->seq
+
parse-tree-il
unparse-tree-il
tree-il->scheme
tree-il-fold
make-tree-il-folder
- post-order!
- pre-order!
+ post-order
+ pre-order
tree-il=?
tree-il-hash))
;; (<toplevel-set> name exp)
;; (<toplevel-define> name exp)
;; (<conditional> test consequent alternate)
- ;; (<application> proc args)
- ;; (<sequence> exps)
+ ;; (<call> proc args)
+ ;; (<primcall> name args)
+ ;; (<seq> head tail)
;; (<lambda> meta body)
;; (<lambda-case> req opt rest kw inits gensyms body alternate)
;; (<let> names gensyms vals body)
;; (<letrec> in-order? names gensyms vals body)
- ;; (<dynlet> fluids vals body)
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
(<let-values> exp body)
- (<dynwind> winder body unwinder)
- (<dynref> fluid)
- (<dynset> fluid exp)
- (<prompt> tag body handler)
+ (<prompt> escape-only? tag body handler)
(<abort> tag args tail))
\f
+;; A helper.
+(define (list->seq loc exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (make-seq loc (car exps) (list->seq #f (cdr exps)))))
+
+\f
+
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
(define (parse-tree-il exp)
(let ((loc (location exp))
(retrans (lambda (x) (parse-tree-il x))))
- (pmatch exp
- ((void)
+ (match exp
+ (('void)
(make-void loc))
- ((apply ,proc . ,args)
- (make-application loc (retrans proc) (map retrans args)))
+ (('call proc . args)
+ (make-call loc (retrans proc) (map retrans args)))
+
+ (('primcall name . args)
+ (make-primcall loc name (map retrans args)))
- ((if ,test ,consequent ,alternate)
+ (('if test consequent alternate)
(make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
- ((primitive ,name) (guard (symbol? name))
+ (('primitive (and name (? symbol?)))
(make-primitive-ref loc name))
- ((lexical ,name) (guard (symbol? name))
+ (('lexical (and name (? symbol?)))
(make-lexical-ref loc name name))
- ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
+ (('lexical (and name (? symbol?)) (and sym (? symbol?)))
(make-lexical-ref loc name sym))
- ((set! (lexical ,name) ,exp) (guard (symbol? name))
+ (('set! ('lexical (and name (? symbol?))) exp)
(make-lexical-set loc name name (retrans exp)))
- ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
+ (('set! ('lexical (and name (? symbol?)) (and sym (? symbol?))) exp)
(make-lexical-set loc name sym (retrans exp)))
- ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+ (('@ ((and mod (? symbol?)) ...) (and name (? symbol?)))
(make-module-ref loc mod name #t))
- ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+ (('set! ('@ ((and mod (? symbol?)) ...) (and name (? symbol?))) exp)
(make-module-set loc mod name #t (retrans exp)))
- ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
+ (('@@ ((and mod (? symbol?)) ...) (and name (? symbol?)))
(make-module-ref loc mod name #f))
- ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
+ (('set! ('@@ ((and mod (? symbol?)) ...) (and name (? symbol?))) exp)
(make-module-set loc mod name #f (retrans exp)))
- ((toplevel ,name) (guard (symbol? name))
+ (('toplevel (and name (? symbol?)))
(make-toplevel-ref loc name))
- ((set! (toplevel ,name) ,exp) (guard (symbol? name))
+ (('set! ('toplevel (and name (? symbol?))) exp)
(make-toplevel-set loc name (retrans exp)))
- ((define ,name ,exp) (guard (symbol? name))
+ (('define (and name (? symbol?)) exp)
(make-toplevel-define loc name (retrans exp)))
- ((lambda ,meta ,body)
+ (('lambda meta body)
(make-lambda loc meta (retrans body)))
- ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate)
+ (('lambda-case ((req opt rest kw inits gensyms) body) alternate)
(make-lambda-case loc req opt rest kw
(map retrans inits) gensyms
(retrans body)
(and=> alternate retrans)))
- ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body))
+ (('lambda-case ((req opt rest kw inits gensyms) body))
(make-lambda-case loc req opt rest kw
(map retrans inits) gensyms
(retrans body)
#f))
- ((const ,exp)
+ (('const exp)
(make-const loc exp))
- ((begin . ,exps)
- (make-sequence loc (map retrans exps)))
+ (('seq head tail)
+ (make-seq loc (retrans head) (retrans tail)))
+
+ ;; Convenience.
+ (('begin . exps)
+ (list->seq loc (map retrans exps)))
- ((let ,names ,gensyms ,vals ,body)
+ (('let names gensyms vals body)
(make-let loc names gensyms (map retrans vals) (retrans body)))
- ((letrec ,names ,gensyms ,vals ,body)
+ (('letrec names gensyms vals body)
(make-letrec loc #f names gensyms (map retrans vals) (retrans body)))
- ((letrec* ,names ,gensyms ,vals ,body)
+ (('letrec* names gensyms vals body)
(make-letrec loc #t names gensyms (map retrans vals) (retrans body)))
- ((fix ,names ,gensyms ,vals ,body)
+ (('fix names gensyms vals body)
(make-fix loc names gensyms (map retrans vals) (retrans body)))
- ((let-values ,exp ,body)
+ (('let-values exp body)
(make-let-values loc (retrans exp) (retrans body)))
- ((dynwind ,winder ,body ,unwinder)
- (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
-
- ((dynlet ,fluids ,vals ,body)
- (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
-
- ((dynref ,fluid)
- (make-dynref loc (retrans fluid)))
-
- ((dynset ,fluid ,exp)
- (make-dynset loc (retrans fluid) (retrans exp)))
-
- ((prompt ,tag ,body ,handler)
- (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
-
- ((abort ,tag ,args ,tail)
+ (('prompt escape-only? tag body handler)
+ (make-prompt loc escape-only?
+ (retrans tag) (retrans body) (retrans handler)))
+
+ (('abort tag args tail)
(make-abort loc (retrans tag) (map retrans args) (retrans tail)))
(else
(error "unrecognized tree-il" exp)))))
(define (unparse-tree-il tree-il)
- (record-case tree-il
- ((<void>)
+ (match tree-il
+ (($ <void> src)
'(void))
- ((<application> proc args)
- `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+ (($ <call> src proc args)
+ `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+
+ (($ <primcall> src name args)
+ `(primcall ,name ,@(map unparse-tree-il args)))
- ((<conditional> test consequent alternate)
- `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
+ (($ <conditional> src test consequent alternate)
+ `(if ,(unparse-tree-il test)
+ ,(unparse-tree-il consequent)
+ ,(unparse-tree-il alternate)))
- ((<primitive-ref> name)
+ (($ <primitive-ref> src name)
`(primitive ,name))
- ((<lexical-ref> name gensym)
+ (($ <lexical-ref> src name gensym)
`(lexical ,name ,gensym))
- ((<lexical-set> name gensym exp)
+ (($ <lexical-set> src name gensym exp)
`(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
- ((<module-ref> mod name public?)
+ (($ <module-ref> src mod name public?)
`(,(if public? '@ '@@) ,mod ,name))
- ((<module-set> mod name public? exp)
+ (($ <module-set> src mod name public? exp)
`(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
- ((<toplevel-ref> name)
+ (($ <toplevel-ref> src name)
`(toplevel ,name))
- ((<toplevel-set> name exp)
+ (($ <toplevel-set> src name exp)
`(set! (toplevel ,name) ,(unparse-tree-il exp)))
- ((<toplevel-define> name exp)
+ (($ <toplevel-define> src name exp)
`(define ,name ,(unparse-tree-il exp)))
- ((<lambda> meta body)
+ (($ <lambda> src meta body)
(if body
`(lambda ,meta ,(unparse-tree-il body))
`(lambda ,meta (lambda-case))))
- ((<lambda-case> req opt rest kw inits gensyms body alternate)
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
`(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
,(unparse-tree-il body))
. ,(if alternate (list (unparse-tree-il alternate)) '())))
- ((<const> exp)
+ (($ <const> src exp)
`(const ,exp))
- ((<sequence> exps)
- `(begin ,@(map unparse-tree-il exps)))
-
- ((<let> names gensyms vals body)
+ (($ <seq> src head tail)
+ `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail)))
+
+ (($ <let> src names gensyms vals body)
`(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<letrec> in-order? names gensyms vals body)
+ (($ <letrec> src in-order? names gensyms vals body)
`(,(if in-order? 'letrec* 'letrec) ,names ,gensyms
,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<fix> names gensyms vals body)
+ (($ <fix> src names gensyms vals body)
`(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
- ((<let-values> exp body)
+ (($ <let-values> src exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- ((<dynwind> winder body unwinder)
- `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
- ,(unparse-tree-il unwinder)))
-
- ((<dynlet> fluids vals body)
- `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
- ,(unparse-tree-il body)))
-
- ((<dynref> fluid)
- `(dynref ,(unparse-tree-il fluid)))
+ (($ <prompt> src escape-only? tag body handler)
+ `(prompt ,escape-only?
+ ,(unparse-tree-il tag)
+ ,(unparse-tree-il body)
+ ,(unparse-tree-il handler)))
- ((<dynset> fluid exp)
- `(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
-
- ((<prompt> tag body handler)
- `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler)))
-
- ((<abort> tag args tail)
+ (($ <abort> src tag args tail)
`(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
,(unparse-tree-il tail)))))
e env opts)))
\f
-(define (tree-il-fold leaf down up seed tree)
- "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
-into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is
-invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
-and SEED is the current result, intially seeded with SEED.
-
-This is an implementation of `foldts' as described by Andy Wingo in
-``Applications of fold to XML transformation''."
- (let loop ((tree tree)
- (result seed))
- (if (or (null? tree) (pair? tree))
- (fold loop result tree)
- (record-case tree
- ((<lexical-set> exp)
- (up tree (loop exp (down tree result))))
- ((<module-set> exp)
- (up tree (loop exp (down tree result))))
- ((<toplevel-set> exp)
- (up tree (loop exp (down tree result))))
- ((<toplevel-define> exp)
- (up tree (loop exp (down tree result))))
- ((<conditional> test consequent alternate)
- (up tree (loop alternate
- (loop consequent
- (loop test (down tree result))))))
- ((<application> proc args)
- (up tree (loop (cons proc args) (down tree result))))
- ((<sequence> exps)
- (up tree (loop exps (down tree result))))
- ((<lambda> body)
- (let ((result (down tree result)))
- (up tree
- (if body
- (loop body result)
- result))))
- ((<lambda-case> inits body alternate)
- (up tree (if alternate
- (loop alternate
- (loop body (loop inits (down tree result))))
- (loop body (loop inits (down tree result))))))
- ((<let> vals body)
- (up tree (loop body
- (loop vals
- (down tree result)))))
- ((<letrec> vals body)
- (up tree (loop body
- (loop vals
- (down tree result)))))
- ((<fix> vals body)
- (up tree (loop body
- (loop vals
- (down tree result)))))
- ((<let-values> exp body)
- (up tree (loop body (loop exp (down tree result)))))
- ((<dynwind> body winder unwinder)
- (up tree (loop unwinder
- (loop winder
- (loop body (down tree result))))))
- ((<dynlet> fluids vals body)
- (up tree (loop body
- (loop vals
- (loop fluids (down tree result))))))
- ((<dynref> fluid)
- (up tree (loop fluid (down tree result))))
- ((<dynset> fluid exp)
- (up tree (loop exp (loop fluid (down tree result)))))
- ((<prompt> tag body handler)
- (up tree
- (loop tag (loop body (loop handler
- (down tree result))))))
- ((<abort> tag args tail)
- (up tree (loop tail (loop args (loop tag (down tree result))))))
- (else
- (leaf tree result))))))
-
-
(define-syntax-rule (make-tree-il-folder seed ...)
(lambda (tree down up seed ...)
(define (fold-values proc exps seed ...)
(let*-values
(((seed ...) (down tree seed ...))
((seed ...)
- (record-case tree
- ((<lexical-set> exp)
+ (match tree
+ (($ <lexical-set> src name gensym exp)
(foldts exp seed ...))
- ((<module-set> exp)
+ (($ <module-set> src mod name public? exp)
(foldts exp seed ...))
- ((<toplevel-set> exp)
+ (($ <toplevel-set> src name exp)
(foldts exp seed ...))
- ((<toplevel-define> exp)
+ (($ <toplevel-define> src name exp)
(foldts exp seed ...))
- ((<conditional> test consequent alternate)
+ (($ <conditional> src test consequent alternate)
(let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...)))
- ((<application> proc args)
+ (($ <call> src proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
- ((<sequence> exps)
- (fold-values foldts exps seed ...))
- ((<lambda> body)
+ (($ <primcall> src name args)
+ (fold-values foldts args seed ...))
+ (($ <seq> src head tail)
+ (let-values (((seed ...) (foldts head seed ...)))
+ (foldts tail seed ...)))
+ (($ <lambda> src meta body)
(if body
(foldts body seed ...)
(values seed ...)))
- ((<lambda-case> inits body alternate)
+ (($ <lambda-case> src req opt rest kw inits gensyms body
+ alternate)
(let-values (((seed ...) (fold-values foldts inits seed ...)))
(if alternate
(let-values (((seed ...) (foldts body seed ...)))
(foldts alternate seed ...))
(foldts body seed ...))))
- ((<let> vals body)
+ (($ <let> src names gensyms vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
- ((<letrec> vals body)
+ (($ <letrec> src in-order? names gensyms vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
- ((<fix> vals body)
+ (($ <fix> src names gensyms vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
- ((<let-values> exp body)
+ (($ <let-values> src exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
- ((<dynwind> body winder unwinder)
- (let*-values (((seed ...) (foldts body seed ...))
- ((seed ...) (foldts winder seed ...)))
- (foldts unwinder seed ...)))
- ((<dynlet> fluids vals body)
- (let*-values (((seed ...) (fold-values foldts fluids seed ...))
- ((seed ...) (fold-values foldts vals seed ...)))
- (foldts body seed ...)))
- ((<dynref> fluid)
- (foldts fluid seed ...))
- ((<dynset> fluid exp)
- (let*-values (((seed ...) (foldts fluid seed ...)))
- (foldts exp seed ...)))
- ((<prompt> tag body handler)
+ (($ <prompt> src escape-only? tag body handler)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...)))
(foldts handler seed ...)))
- ((<abort> tag args tail)
+ (($ <abort> src tag args tail)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (fold-values foldts args seed ...)))
(foldts tail seed ...)))
- (else
+ (_
(values seed ...)))))
(up tree seed ...)))))
-(define (post-order! f x)
- (let lp ((x x))
- (record-case x
- ((<application> proc args)
- (set! (application-proc x) (lp proc))
- (set! (application-args x) (map lp args)))
-
- ((<conditional> test consequent alternate)
- (set! (conditional-test x) (lp test))
- (set! (conditional-consequent x) (lp consequent))
- (set! (conditional-alternate x) (lp alternate)))
-
- ((<lexical-set> name gensym exp)
- (set! (lexical-set-exp x) (lp exp)))
-
- ((<module-set> mod name public? exp)
- (set! (module-set-exp x) (lp exp)))
-
- ((<toplevel-set> name exp)
- (set! (toplevel-set-exp x) (lp exp)))
-
- ((<toplevel-define> name exp)
- (set! (toplevel-define-exp x) (lp exp)))
-
- ((<lambda> body)
- (if body
- (set! (lambda-body x) (lp body))))
-
- ((<lambda-case> inits body alternate)
- (set! inits (map lp inits))
- (set! (lambda-case-body x) (lp body))
- (if alternate
- (set! (lambda-case-alternate x) (lp alternate))))
-
- ((<sequence> exps)
- (set! (sequence-exps x) (map lp exps)))
-
- ((<let> gensyms vals body)
- (set! (let-vals x) (map lp vals))
- (set! (let-body x) (lp body)))
-
- ((<letrec> gensyms vals body)
- (set! (letrec-vals x) (map lp vals))
- (set! (letrec-body x) (lp body)))
-
- ((<fix> gensyms vals body)
- (set! (fix-vals x) (map lp vals))
- (set! (fix-body x) (lp body)))
+(define (tree-il-fold down up seed tree)
+ "Traverse TREE, calling DOWN before visiting a sub-tree, and UP when
+after visiting it. Each of these procedures is invoked as `(PROC TREE
+SEED)', where TREE is the sub-tree considered and SEED is the current
+result, intially seeded with SEED.
- ((<let-values> exp body)
- (set! (let-values-exp x) (lp exp))
- (set! (let-values-body x) (lp body)))
-
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
- (set! (dynwind-winder x) (lp winder))
- (set! (dynwind-unwinder x) (lp unwinder)))
-
- ((<dynlet> fluids vals body)
- (set! (dynlet-fluids x) (map lp fluids))
- (set! (dynlet-vals x) (map lp vals))
- (set! (dynlet-body x) (lp body)))
-
- ((<dynref> fluid)
- (set! (dynref-fluid x) (lp fluid)))
-
- ((<dynset> fluid exp)
- (set! (dynset-fluid x) (lp fluid))
- (set! (dynset-exp x) (lp exp)))
-
- ((<prompt> tag body handler)
- (set! (prompt-tag x) (lp tag))
- (set! (prompt-body x) (lp body))
- (set! (prompt-handler x) (lp handler)))
-
- ((<abort> tag args tail)
- (set! (abort-tag x) (lp tag))
- (set! (abort-args x) (map lp args))
- (set! (abort-tail x) (lp tail)))
-
- (else #f))
-
- (or (f x) x)))
-
-(define (pre-order! f x)
+This is an implementation of `foldts' as described by Andy Wingo in
+``Applications of fold to XML transformation''."
+ ;; Multi-valued fold naturally puts the seeds at the end, whereas
+ ;; normal fold puts the traversable at the end. Adapt to the expected
+ ;; argument order.
+ ((make-tree-il-folder tree) tree down up seed))
+
+(define (pre-post-order pre post x)
+ (define (elts-eq? a b)
+ (or (null? a)
+ (and (eq? (car a) (car b))
+ (elts-eq? (cdr a) (cdr b)))))
(let lp ((x x))
- (let ((x (or (f x) x)))
- (record-case x
- ((<application> proc args)
- (set! (application-proc x) (lp proc))
- (set! (application-args x) (map lp args)))
-
- ((<conditional> test consequent alternate)
- (set! (conditional-test x) (lp test))
- (set! (conditional-consequent x) (lp consequent))
- (set! (conditional-alternate x) (lp alternate)))
-
- ((<lexical-set> exp)
- (set! (lexical-set-exp x) (lp exp)))
-
- ((<module-set> exp)
- (set! (module-set-exp x) (lp exp)))
-
- ((<toplevel-set> exp)
- (set! (toplevel-set-exp x) (lp exp)))
-
- ((<toplevel-define> exp)
- (set! (toplevel-define-exp x) (lp exp)))
-
- ((<lambda> body)
- (if body
- (set! (lambda-body x) (lp body))))
-
- ((<lambda-case> inits body alternate)
- (set! inits (map lp inits))
- (set! (lambda-case-body x) (lp body))
- (if alternate (set! (lambda-case-alternate x) (lp alternate))))
-
- ((<sequence> exps)
- (set! (sequence-exps x) (map lp exps)))
-
- ((<let> vals body)
- (set! (let-vals x) (map lp vals))
- (set! (let-body x) (lp body)))
-
- ((<letrec> vals body)
- (set! (letrec-vals x) (map lp vals))
- (set! (letrec-body x) (lp body)))
-
- ((<fix> vals body)
- (set! (fix-vals x) (map lp vals))
- (set! (fix-body x) (lp body)))
-
- ((<let-values> exp body)
- (set! (let-values-exp x) (lp exp))
- (set! (let-values-body x) (lp body)))
-
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
- (set! (dynwind-winder x) (lp winder))
- (set! (dynwind-unwinder x) (lp unwinder)))
-
- ((<dynlet> fluids vals body)
- (set! (dynlet-fluids x) (map lp fluids))
- (set! (dynlet-vals x) (map lp vals))
- (set! (dynlet-body x) (lp body)))
-
- ((<dynref> fluid)
- (set! (dynref-fluid x) (lp fluid)))
-
- ((<dynset> fluid exp)
- (set! (dynset-fluid x) (lp fluid))
- (set! (dynset-exp x) (lp exp)))
-
- ((<prompt> tag body handler)
- (set! (prompt-tag x) (lp tag))
- (set! (prompt-body x) (lp body))
- (set! (prompt-handler x) (lp handler)))
-
- ((<abort> tag args tail)
- (set! (abort-tag x) (lp tag))
- (set! (abort-args x) (map lp args))
- (set! (abort-tail x) (lp tail)))
-
- (else #f))
- x)))
+ (post
+ (let ((x (pre x)))
+ (match x
+ ((or ($ <void>)
+ ($ <const>)
+ ($ <primitive-ref>)
+ ($ <lexical-ref>)
+ ($ <module-ref>)
+ ($ <toplevel-ref>))
+ x)
+
+ (($ <lexical-set> src name gensym exp)
+ (let ((exp* (lp exp)))
+ (if (eq? exp exp*)
+ x
+ (make-lexical-set src name gensym exp*))))
+
+ (($ <module-set> src mod name public? exp)
+ (let ((exp* (lp exp)))
+ (if (eq? exp exp*)
+ x
+ (make-module-set src mod name public? exp*))))
+
+ (($ <toplevel-set> src name exp)
+ (let ((exp* (lp exp)))
+ (if (eq? exp exp*)
+ x
+ (make-toplevel-set src name exp*))))
+
+ (($ <toplevel-define> src name exp)
+ (let ((exp* (lp exp)))
+ (if (eq? exp exp*)
+ x
+ (make-toplevel-define src name exp*))))
+
+ (($ <conditional> src test consequent alternate)
+ (let ((test* (lp test))
+ (consequent* (lp consequent))
+ (alternate* (lp alternate)))
+ (if (and (eq? test test*)
+ (eq? consequent consequent*)
+ (eq? alternate alternate*))
+ x
+ (make-conditional src test* consequent* alternate*))))
+
+ (($ <call> src proc args)
+ (let ((proc* (lp proc))
+ (args* (map lp args)))
+ (if (and (eq? proc proc*)
+ (elts-eq? args args*))
+ x
+ (make-call src proc* args*))))
+
+ (($ <primcall> src name args)
+ (let ((args* (map lp args)))
+ (if (elts-eq? args args*)
+ x
+ (make-primcall src name args*))))
+
+ (($ <seq> src head tail)
+ (let ((head* (lp head))
+ (tail* (lp tail)))
+ (if (and (eq? head head*)
+ (eq? tail tail*))
+ x
+ (make-seq src head* tail*))))
+
+ (($ <lambda> src meta body)
+ (let ((body* (and body (lp body))))
+ (if (eq? body body*)
+ x
+ (make-lambda src meta body*))))
+
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (let ((inits* (map lp inits))
+ (body* (lp body))
+ (alternate* (and alternate (lp alternate))))
+ (if (and (elts-eq? inits inits*)
+ (eq? body body*)
+ (eq? alternate alternate*))
+ x
+ (make-lambda-case src req opt rest kw inits* gensyms body*
+ alternate*))))
+
+ (($ <let> src names gensyms vals body)
+ (let ((vals* (map lp vals))
+ (body* (lp body)))
+ (if (and (elts-eq? vals vals*)
+ (eq? body body*))
+ x
+ (make-let src names gensyms vals* body*))))
+
+ (($ <letrec> src in-order? names gensyms vals body)
+ (let ((vals* (map lp vals))
+ (body* (lp body)))
+ (if (and (elts-eq? vals vals*)
+ (eq? body body*))
+ x
+ (make-letrec src in-order? names gensyms vals* body*))))
+
+ (($ <fix> src names gensyms vals body)
+ (let ((vals* (map lp vals))
+ (body* (lp body)))
+ (if (and (elts-eq? vals vals*)
+ (eq? body body*))
+ x
+ (make-fix src names gensyms vals* body*))))
+
+ (($ <let-values> src exp body)
+ (let ((exp* (lp exp))
+ (body* (lp body)))
+ (if (and (eq? exp exp*)
+ (eq? body body*))
+ x
+ (make-let-values src exp* body*))))
+
+ (($ <prompt> src escape-only? tag body handler)
+ (let ((tag* (lp tag))
+ (body* (lp body))
+ (handler* (lp handler)))
+ (if (and (eq? tag tag*)
+ (eq? body body*)
+ (eq? handler handler*))
+ x
+ (make-prompt src escape-only? tag* body* handler*))))
+
+ (($ <abort> src tag args tail)
+ (let ((tag* (lp tag))
+ (args* (map lp args))
+ (tail* (lp tail)))
+ (if (and (eq? tag tag*)
+ (elts-eq? args args*)
+ (eq? tail tail*))
+ x
+ (make-abort src tag* args* tail*)))))))))
+
+(define (post-order f x)
+ (pre-post-order (lambda (x) x) f x))
+
+(define (pre-order f x)
+ (pre-post-order f (lambda (x) x) x))
;; FIXME: We should have a better primitive than this.
(define (struct-nfields x)
;;; TREE-IL -> GLIL compiler
-;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012,
-;; 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008-2014 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
(analyze! x new-proc (append labels labels-in-proc) #t #f))
(define (recur x new-proc) (analyze! x new-proc '() tail? #f))
(record-case x
- ((<application> proc args)
+ ((<call> proc args)
(apply lset-union eq? (step-tail-call proc args)
(map step args)))
+ ((<primcall> args)
+ (apply lset-union eq? (map step args)))
+
((<conditional> test consequent alternate)
(lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))
((<toplevel-define> exp)
(step exp))
- ((<sequence> exps)
- (let lp ((exps exps) (ret '()))
- (cond ((null? exps) '())
- ((null? (cdr exps))
- (lset-union eq? ret (step-tail (car exps))))
- (else
- (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
+ ((<seq> head tail)
+ (lset-union eq? (step head) (step-tail tail)))
((<lambda> body)
;; order is important here
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
- ((<dynwind> body winder unwinder)
- (lset-union eq? (step body) (step winder) (step unwinder)))
-
- ((<dynlet> fluids vals body)
- (apply lset-union eq? (step body) (map step (append fluids vals))))
-
- ((<dynref> fluid)
- (step fluid))
-
- ((<dynset> fluid exp)
- (lset-union eq? (step fluid) (step exp)))
-
- ((<prompt> tag body handler)
- (lset-union eq? (step tag) (step body) (step-tail handler)))
+ ((<prompt> escape-only? tag body handler)
+ (match handler
+ (($ <lambda> _ _ handler)
+ (lset-union eq? (step tag) (step body) (step-tail handler)))))
((<abort> tag args tail)
(apply lset-union eq? (step tag) (step tail) (map step args)))
(define (allocate! x proc n)
(define (recur y) (allocate! y proc n))
(record-case x
- ((<application> proc args)
+ ((<call> proc args)
(apply max (recur proc) (map recur args)))
+ ((<primcall> args)
+ (apply max n (map recur args)))
+
((<conditional> test consequent alternate)
(max (recur test) (recur consequent) (recur alternate)))
((<toplevel-define> exp)
(recur exp))
- ((<sequence> exps)
- (apply max (map recur exps)))
+ ((<seq> head tail)
+ (max (recur head)
+ (recur tail)))
((<lambda> body)
;; allocate closure vars in order
((<let-values> exp body)
(max (recur exp) (recur body)))
- ((<dynwind> body winder unwinder)
- (max (recur body) (recur winder) (recur unwinder)))
-
- ((<dynlet> fluids vals body)
- (apply max (recur body) (map recur (append fluids vals))))
-
- ((<dynref> fluid)
- (recur fluid))
-
- ((<dynset> fluid exp)
- (max (recur fluid) (recur exp)))
-
- ((<prompt> tag body handler)
- (let ((cont-var (and (lambda-case? handler)
- (pair? (lambda-case-gensyms handler))
- (car (lambda-case-gensyms handler)))))
- (hashq-set! allocation x
- (and cont-var (zero? (hashq-ref refcounts cont-var 0))))
- (max (recur tag) (recur body) (recur handler))))
-
+ ((<prompt> escape-only? tag body handler)
+ (match handler
+ (($ <lambda> _ _ handler)
+ (max (recur tag) (recur body) (recur handler)))))
+
((<abort> tag args tail)
(apply max (recur tag) (recur tail) (map recur args)))
;;;
(define-record-type <tree-analysis>
- (make-tree-analysis leaf down up post init)
+ (make-tree-analysis down up post init)
tree-analysis?
- (leaf tree-analysis-leaf) ;; (lambda (x result env locs) ...)
(down tree-analysis-down) ;; (lambda (x result env locs) ...)
(up tree-analysis-up) ;; (lambda (x result env locs) ...)
(post tree-analysis-post) ;; (lambda (result env) ...)
(define (analyze-tree analyses tree env)
"Run all tree analyses listed in ANALYSES on TREE for ENV, using
-`tree-il-fold'. Return TREE. The leaf/down/up procedures of each analysis are
-passed a ``location stack', which is the stack of `tree-il-src' values for each
-parent tree (a list); it can be used to approximate source location when
-accurate information is missing from a given `tree-il' element."
+`tree-il-fold'. Return TREE. The down and up procedures of each
+analysis are passed a ``location stack', which is the stack of
+`tree-il-src' values for each parent tree (a list); it can be used to
+approximate source location when accurate information is missing from a
+given `tree-il' element."
(define (traverse proc update-locs)
;; Return a tree traversing procedure that returns a list of analysis
analyses
(cdr results))))))
- ;; Keeping/extending/shrinking the location stack.
- (define (keep-locs x locs) locs)
+ ;; Extending and shrinking the location stack.
(define (extend-locs x locs) (cons (tree-il-src x) locs))
(define (shrink-locs x locs) (cdr locs))
(let ((results
- (tree-il-fold (traverse tree-analysis-leaf keep-locs)
- (traverse tree-analysis-down extend-locs)
+ (tree-il-fold (traverse tree-analysis-down extend-locs)
(traverse tree-analysis-up shrink-locs)
(cons '() ;; empty location stack
(map tree-analysis-init analyses))
(define unused-variable-analysis
;; Report unused variables in the given tree.
(make-tree-analysis
- (lambda (x info env locs)
- ;; X is a leaf: extend INFO's refs accordingly.
- (let ((refs (binding-info-refs info))
- (vars (binding-info-vars info)))
- (record-case x
- ((<lexical-ref> gensym)
- (make-binding-info vars (vhash-consq gensym #t refs)))
- (else info))))
-
(lambda (x info env locs)
;; Going down into X: extend INFO's variable list
;; accordingly.
inner-names))
(record-case x
+ ((<lexical-ref> gensym)
+ (make-binding-info vars (vhash-consq gensym #t refs)))
((<lexical-set> gensym)
(make-binding-info vars (vhash-consq gensym #t refs)))
((<lambda-case> req opt inits rest kw gensyms)
(macro? (variable-ref var))))))
(make-tree-analysis
- (lambda (x graph env locs)
- ;; X is a leaf.
- (let ((ctx (reference-graph-toplevel-context graph)))
- (record-case x
- ((<toplevel-ref> name src)
- (add-ref-from-context graph name))
- (else graph))))
-
(lambda (x graph env locs)
;; Going down into X.
(let ((ctx (reference-graph-toplevel-context graph))
(refs (reference-graph-refs graph))
(defs (reference-graph-defs graph)))
(record-case x
+ ((<toplevel-ref> name src)
+ (add-ref-from-context graph name))
((<toplevel-define> name src)
(let ((refs refs)
(defs (vhash-consq name (or src (find pair? locs))
(defs toplevel-info-defs)) ;; (VARIABLE-NAME ...)
(define (goops-toplevel-definition proc args env)
- ;; If application of PROC to ARGS is a GOOPS top-level definition, return
+ ;; If call 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)
;; Report possibly unbound variables in the given tree.
(make-tree-analysis
(lambda (x info env locs)
- ;; X is a leaf: extend INFO's refs accordingly.
- (let ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info)))
+ ;; Going down into X.
+ (let* ((refs (toplevel-info-refs info))
+ (defs (toplevel-info-defs info))
+ (src (tree-il-src x)))
(define (bound? name)
(or (and (module? env)
(module-variable env name))
(let ((src (or src (find pair? locs))))
(make-toplevel-info (vhash-consq name src refs)
defs))))
- (else info))))
-
- (lambda (x info env locs)
- ;; Going down into X.
- (let* ((refs (toplevel-info-refs info))
- (defs (toplevel-info-defs info))
- (src (tree-il-src x)))
- (define (bound? name)
- (or (and (module? env)
- (module-variable env name))
- (vhash-assq name defs)))
-
- (record-case x
((<toplevel-set> name src)
(if (bound? name)
(make-toplevel-info refs defs)
(make-toplevel-info (vhash-delq name refs)
(vhash-consq name #t defs)))
- ((<application> proc args)
+ ((<call> 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
(define-record-type <arity-info>
(make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
arity-info?
- (toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
+ (toplevel-calls toplevel-procedure-calls) ;; ((NAME . CALL) ...)
(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
+(define (validate-arity proc call lexical?)
+ ;; Validate the argument count of CALL, a tree-il call of
;; PROC, emitting a warning in case of argument count mismatch.
(define (filter-keyword-args keywords allow-other-keys? args)
(cond ((program? proc)
(values (procedure-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))))
+ (list (length (or (assq-ref a 'required) '()))
+ (length (or (assq-ref a 'optional) '()))
+ (and (assq-ref a 'rest) #t)
+ (map car (or (assq-ref a 'keyword) '()))
+ (assq-ref a 'allow-other-keys?)))
+ (program-arguments-alists proc))))
((procedure? proc)
(if (struct? proc)
;; An applicable struct.
(else
(values #f #f))))))))
- (let ((args (application-args application))
- (src (tree-il-src application)))
+ (let ((args (call-args call))
+ (src (tree-il-src call)))
(call-with-values (lambda () (arities proc))
(lambda (name arities)
(define matches?
(define arity-analysis
;; Report arity mismatches in the given tree.
(make-tree-analysis
- (lambda (x info env locs)
- ;; X is a leaf.
- info)
(lambda (x info env locs)
;; Down into X.
(define (extend lexical-name val info)
((<fix> gensyms vals)
(fold extend info gensyms vals))
- ((<application> proc args src)
+ ((<call> proc args src)
(record-case proc
((<lambda> body)
(validate-arity proc x #t)
(let ((toplevel-calls (toplevel-procedure-calls result))
(toplevel-lambdas (toplevel-lambdas result)))
(vlist-for-each
- (lambda (name+application)
- (let* ((name (car name+application))
- (application (cdr name+application))
+ (lambda (name+call)
+ (let* ((name (car name+call))
+ (call (cdr name+call))
(proc
(or (and=> (vhash-assq name toplevel-lambdas) cdr)
(and (module? env)
(module-ref env name))))
proc)))
(cond ((lambda? proc*)
- (validate-arity proc* application #t))
+ (validate-arity proc* call #t))
((procedure? proc*)
- (validate-arity proc* application #f)))))
+ (validate-arity proc* call #f)))))
toplevel-calls)))
(make-arity-info vlist-null vlist-null vlist-null)))
(match x
(($ <const> _ (? string? exp))
exp)
- (($ <application> _ (? (cut gettext? <> env))
+ (($ <call> _ (? (cut gettext? <> env))
(($ <const> _ (? string? fmt))))
;; Gettexted literals, like `(_ "foo")'.
fmt)
- (($ <application> _ (? (cut ngettext? <> env))
+ (($ <call> _ (? (cut ngettext? <> env))
(($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ ..1))
;; Plural gettextized literals, like `(N_ "singular" "plural" n)'.
(define format-analysis
;; Report arity mismatches in the given tree.
(make-tree-analysis
- (lambda (x _ env locs)
- ;; X is a leaf.
- #t)
-
(lambda (x _ env locs)
;; Down into X.
(define (check-format-args args loc)
(false-if-exception (module-ref env name))))
(match x
- (($ <application> src ($ <toplevel-ref> _ name) args)
+ (($ <call> src ($ <toplevel-ref> _ name) args)
(let ((proc (resolve-toplevel name)))
(if (or (and (eq? proc (@ (guile) simple-format))
(check-simple-format-args args
(or src (find pair? locs))))
(eq? proc (@ (ice-9 format) format)))
(check-format-args args (or src (find pair? locs))))))
- (($ <application> src ($ <module-ref> _ '(ice-9 format) 'format) args)
+ (($ <call> src ($ <module-ref> _ '(ice-9 format) 'format) args)
(check-format-args args (or src (find pair? locs))))
- (($ <application> src ($ <module-ref> _ '(guile)
- (or 'format 'simple-format))
+ (($ <call> src ($ <module-ref> _ '(guile)
+ (or 'format 'simple-format))
args)
(and (check-simple-format-args args
(or src (find pair? locs)))
#:use-module (language tree-il)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
- #:export (canonicalize!))
+ #:export (canonicalize))
(define (tree-il-any proc exp)
(tree-il-fold (lambda (exp res)
(or res (proc exp)))
- (lambda (exp res)
- (or res (proc exp)))
(lambda (exp res) res)
#f exp))
-(define (canonicalize! x)
- (post-order!
+(define (canonicalize x)
+ (post-order
(lambda (x)
(match x
- (($ <sequence> src (tail))
- tail)
- (($ <sequence> src exps)
- (and (any sequence? exps)
- (make-sequence src
- (append-map (lambda (x)
- (if (sequence? x)
- (sequence-exps x)
- (list x)))
- exps))))
(($ <let> src () () () body)
body)
(($ <letrec> src _ () () () body)
body)
(($ <fix> src () () () body)
body)
- (($ <dynlet> src () () body)
- body)
(($ <lambda> src meta #f)
;; Give a body to case-lambda with no clauses.
(make-lambda
src meta
(make-lambda-case
#f '() #f #f #f '() '()
- (make-application
+ (make-primcall
#f
- (make-primitive-ref #f 'throw)
+ 'throw
(list (make-const #f 'wrong-number-of-args)
(make-const #f #f)
(make-const #f "Wrong number of arguments")
(make-const #f '())
(make-const #f #f)))
#f)))
- (($ <prompt> src tag body handler)
- (define (escape-only? handler)
- (match handler
- (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
- (not (tree-il-any (lambda (x)
- (and (lexical-ref? x)
- (eq? (lexical-ref-gensym x) cont)))
- body)))
- (else #f)))
- (define (thunk-application? x)
- (match x
- (($ <application> _
- ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
- ()) #t)
- (_ #f)))
- (define (make-thunk-application body)
- (define thunk
- (make-lambda #f '()
- (make-lambda-case #f '() #f #f #f '() '() body #f)))
- (make-application #f thunk '()))
-
- ;; This code has a nasty job to do: to ensure that either the
- ;; handler is escape-only, or the body is the application of a
- ;; thunk. Sad but true.
- (if (or (escape-only? handler)
- (thunk-application? body))
- #f
- (make-prompt src tag (make-thunk-application body) handler)))
- (_ #f)))
+ (($ <prompt> src escape-only? tag body handler)
+ ;; The prompt handler should be a simple lambda, so that we
+ ;; can inline it.
+ (match handler
+ (($ <lambda> _ _
+ ($ <lambda-case> _ req #f rest #f () syms body #f))
+ x)
+ (else
+ (let ((handler-sym (gensym))
+ (args-sym (gensym)))
+ (make-let
+ #f (list 'handler) (list handler-sym) (list handler)
+ (make-prompt
+ src escape-only? tag body
+ (make-lambda
+ #f '()
+ (make-lambda-case
+ #f '() #f 'args #f '() (list args-sym)
+ (make-primcall
+ #f 'apply
+ (list (make-lexical-ref #f 'handler handler-sym)
+ (make-lexical-ref #f 'args args-sym)))
+ #f))))))))
+ (_ x)))
x))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 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
+
+;;; Commentary:
+;;;
+;;; This pass converts Tree-IL to the continuation-passing style (CPS)
+;;; language.
+;;;
+;;; CPS is a lower-level representation than Tree-IL. Converting to
+;;; CPS, beyond adding names for all control points and all values,
+;;; simplifies expressions in the following ways, among others:
+;;;
+;;; * Fixing the order of evaluation.
+;;;
+;;; * Converting assigned variables to boxed variables.
+;;;
+;;; * Requiring that Scheme's <letrec> has already been lowered to
+;;; <fix>.
+;;;
+;;; * Inlining default-value initializers into lambda-case
+;;; expressions.
+;;;
+;;; * Inlining prompt bodies.
+;;;
+;;; * Turning toplevel and module references into primcalls. This
+;;; involves explicitly modelling the "scope" of toplevel lookups
+;;; (indicating the module with respect to which toplevel bindings
+;;; are resolved).
+;;;
+;;; The utility of CPS is that it gives a name to everything: every
+;;; intermediate value, and every control point (continuation). As such
+;;; it is more verbose than Tree-IL, but at the same time more simple as
+;;; the number of concepts is reduced.
+;;;
+;;; Code:
+
+(define-module (language tree-il compile-cps)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold fold-right filter-map))
+ #:use-module (srfi srfi-26)
+ #:use-module ((system foreign) #:select (make-pointer pointer->scm))
+ #:use-module (language cps)
+ #:use-module (language cps primitives)
+ #:use-module (language tree-il analyze)
+ #:use-module (language tree-il optimize)
+ #:use-module (language tree-il)
+ #:export (compile-cps))
+
+;;; Guile's semantics are that a toplevel lambda captures a reference on
+;;; the current module, and that all contained lambdas use that module
+;;; to resolve toplevel variables. This parameter tracks whether or not
+;;; we are in a toplevel lambda. If we are in a lambda, the parameter
+;;; is bound to a fresh name identifying the module that was current
+;;; when the toplevel lambda is defined.
+;;;
+;;; This is more complicated than it need be. Ideally we should resolve
+;;; all toplevel bindings to bindings from specific modules, unless the
+;;; binding is unbound. This is always valid if the compilation unit
+;;; sets the module explicitly, as when compiling a module, but it
+;;; doesn't work for files auto-compiled for use with `load'.
+;;;
+(define current-topbox-scope (make-parameter #f))
+(define scope-counter (make-parameter #f))
+
+(define (fresh-scope-id)
+ (let ((scope-id (scope-counter)))
+ (scope-counter (1+ scope-id))
+ scope-id))
+
+(define (toplevel-box src name bound? val-proc)
+ (let-fresh (kbox) (name-sym bound?-sym box)
+ (build-cps-term
+ ($letconst (('name name-sym name)
+ ('bound? bound?-sym bound?))
+ ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
+ ,(match (current-topbox-scope)
+ (#f
+ (build-cps-term
+ ($continue kbox src
+ ($primcall 'resolve
+ (name-sym bound?-sym)))))
+ (scope-id
+ (let-fresh () (scope-sym)
+ (build-cps-term
+ ($letconst (('scope scope-sym scope-id))
+ ($continue kbox src
+ ($primcall 'cached-toplevel-box
+ (scope-sym name-sym bound?-sym)))))))))))))
+
+(define (module-box src module name public? bound? val-proc)
+ (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
+ (build-cps-term
+ ($letconst (('module module-sym module)
+ ('name name-sym name)
+ ('public? public?-sym public?)
+ ('bound? bound?-sym bound?))
+ ($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
+ ($continue kbox src
+ ($primcall 'cached-module-box
+ (module-sym name-sym public?-sym bound?-sym))))))))
+
+(define (capture-toplevel-scope src scope-id k)
+ (let-fresh (kmodule) (module scope-sym)
+ (build-cps-term
+ ($letconst (('scope scope-sym scope-id))
+ ($letk ((kmodule ($kargs ('module) (module)
+ ($continue k src
+ ($primcall 'cache-current-module!
+ (module scope-sym))))))
+ ($continue kmodule src
+ ($primcall 'current-module ())))))))
+
+(define (fold-formals proc seed arity gensyms inits)
+ (match arity
+ (($ $arity req opt rest kw allow-other-keys?)
+ (let ()
+ (define (fold-req names gensyms seed)
+ (match names
+ (() (fold-opt opt gensyms inits seed))
+ ((name . names)
+ (proc name (car gensyms) #f
+ (fold-req names (cdr gensyms) seed)))))
+ (define (fold-opt names gensyms inits seed)
+ (match names
+ (() (fold-rest rest gensyms inits seed))
+ ((name . names)
+ (proc name (car gensyms) (car inits)
+ (fold-opt names (cdr gensyms) (cdr inits) seed)))))
+ (define (fold-rest rest gensyms inits seed)
+ (match rest
+ (#f (fold-kw kw gensyms inits seed))
+ (name (proc name (car gensyms) #f
+ (fold-kw kw (cdr gensyms) inits seed)))))
+ (define (fold-kw kw gensyms inits seed)
+ (match kw
+ (()
+ (unless (null? gensyms)
+ (error "too many gensyms"))
+ (unless (null? inits)
+ (error "too many inits"))
+ seed)
+ (((key name var) . kw)
+ ;; Could be that var is not a gensym any more.
+ (when (symbol? var)
+ (unless (eq? var (car gensyms))
+ (error "unexpected keyword arg order")))
+ (proc name (car gensyms) (car inits)
+ (fold-kw kw (cdr gensyms) (cdr inits) seed)))))
+ (fold-req req gensyms seed)))))
+
+(define (unbound? src var kt kf)
+ (define tc8-iflag 4)
+ (define unbound-val 9)
+ (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
+ (let-fresh () (unbound)
+ (build-cps-term
+ ($letconst (('unbound unbound
+ (pointer->scm (make-pointer unbound-bits))))
+ ($continue kf src
+ ($branch kt ($primcall 'eq? (var unbound))))))))
+
+(define (init-default-value name sym subst init body)
+ (match (hashq-ref subst sym)
+ ((orig-var subst-var box?)
+ (let ((src (tree-il-src init)))
+ (define (maybe-box k make-body)
+ (if box?
+ (let-fresh (kbox) (phi)
+ (build-cps-term
+ ($letk ((kbox ($kargs (name) (phi)
+ ($continue k src ($primcall 'box (phi))))))
+ ,(make-body kbox))))
+ (make-body k)))
+ (let-fresh (knext kbound kunbound kreceive krest) (val rest)
+ (build-cps-term
+ ($letk ((knext ($kargs (name) (subst-var) ,body)))
+ ,(maybe-box
+ knext
+ (lambda (k)
+ (build-cps-term
+ ($letk ((kbound ($kargs () () ($continue k src
+ ($values (orig-var)))))
+ (krest ($kargs (name 'rest) (val rest)
+ ($continue k src ($values (val)))))
+ (kreceive ($kreceive (list name) 'rest krest))
+ (kunbound ($kargs () ()
+ ,(convert init kreceive subst))))
+ ,(unbound? src orig-var kunbound kbound))))))))))))
+
+;; exp k-name alist -> term
+(define (convert exp k subst)
+ ;; exp (v-name -> term) -> term
+ (define (convert-arg exp k)
+ (match exp
+ (($ <lexical-ref> src name sym)
+ (match (hashq-ref subst sym)
+ ((orig-var box #t)
+ (let-fresh (kunboxed) (unboxed)
+ (build-cps-term
+ ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
+ ($continue kunboxed src ($primcall 'box-ref (box)))))))
+ ((orig-var subst-var #f) (k subst-var))
+ (var (k var))))
+ (else
+ (let-fresh (kreceive karg) (arg rest)
+ (build-cps-term
+ ($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
+ (kreceive ($kreceive '(arg) 'rest karg)))
+ ,(convert exp kreceive subst)))))))
+ ;; (exp ...) ((v-name ...) -> term) -> term
+ (define (convert-args exps k)
+ (match exps
+ (() (k '()))
+ ((exp . exps)
+ (convert-arg exp
+ (lambda (name)
+ (convert-args exps
+ (lambda (names)
+ (k (cons name names)))))))))
+ (define (box-bound-var name sym body)
+ (match (hashq-ref subst sym)
+ ((orig-var subst-var #t)
+ (let-fresh (k) ()
+ (build-cps-term
+ ($letk ((k ($kargs (name) (subst-var) ,body)))
+ ($continue k #f ($primcall 'box (orig-var)))))))
+ (else body)))
+ (define (bound-var sym)
+ (match (hashq-ref subst sym)
+ ((var . _) var)
+ ((? exact-integer? var) var)))
+
+ (match exp
+ (($ <lexical-ref> src name sym)
+ (rewrite-cps-term (hashq-ref subst sym)
+ ((orig-var box #t) ($continue k src ($primcall 'box-ref (box))))
+ ((orig-var subst-var #f) ($continue k src ($values (subst-var))))
+ (var ($continue k src ($values (var))))))
+
+ (($ <void> src)
+ (build-cps-term ($continue k src ($void))))
+
+ (($ <const> src exp)
+ (build-cps-term ($continue k src ($const exp))))
+
+ (($ <primitive-ref> src name)
+ (build-cps-term ($continue k src ($prim name))))
+
+ (($ <lambda> fun-src meta body)
+ (let ()
+ (define (convert-clauses body ktail)
+ (match body
+ (#f #f)
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (let* ((arity (make-$arity req (or opt '()) rest
+ (map (match-lambda
+ ((kw name sym)
+ (list kw name (bound-var sym))))
+ (if kw (cdr kw) '()))
+ (and kw (car kw))))
+ (names (fold-formals (lambda (name sym init names)
+ (cons name names))
+ '()
+ arity gensyms inits)))
+ (let ((bound-vars (map bound-var gensyms)))
+ (let-fresh (kclause kargs) ()
+ (build-cps-cont
+ (kclause
+ ($kclause ,arity
+ (kargs
+ ($kargs names bound-vars
+ ,(fold-formals
+ (lambda (name sym init body)
+ (if init
+ (init-default-value name sym subst init body)
+ (box-bound-var name sym body)))
+ (convert body ktail subst)
+ arity gensyms inits)))
+ ,(convert-clauses alternate ktail))))))))))
+ (if (current-topbox-scope)
+ (let-fresh (kfun ktail) (self)
+ (build-cps-term
+ ($continue k fun-src
+ ($fun '()
+ (kfun ($kfun fun-src meta self (ktail ($ktail))
+ ,(convert-clauses body ktail)))))))
+ (let ((scope-id (fresh-scope-id)))
+ (let-fresh (kscope) ()
+ (build-cps-term
+ ($letk ((kscope
+ ($kargs () ()
+ ,(parameterize ((current-topbox-scope scope-id))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope fun-src scope-id kscope))))))))
+
+ (($ <module-ref> src mod name public?)
+ (module-box
+ src mod name public? #t
+ (lambda (box)
+ (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
+
+ (($ <module-set> src mod name public? exp)
+ (convert-arg exp
+ (lambda (val)
+ (module-box
+ src mod name public? #f
+ (lambda (box)
+ (build-cps-term
+ ($continue k src ($primcall 'box-set! (box val)))))))))
+
+ (($ <toplevel-ref> src name)
+ (toplevel-box
+ src name #t
+ (lambda (box)
+ (build-cps-term ($continue k src ($primcall 'box-ref (box)))))))
+
+ (($ <toplevel-set> src name exp)
+ (convert-arg exp
+ (lambda (val)
+ (toplevel-box
+ src name #f
+ (lambda (box)
+ (build-cps-term
+ ($continue k src ($primcall 'box-set! (box val)))))))))
+
+ (($ <toplevel-define> src name exp)
+ (convert-arg exp
+ (lambda (val)
+ (let-fresh (kname) (name-sym)
+ (build-cps-term
+ ($letconst (('name name-sym name))
+ ($continue k src ($primcall 'define! (name-sym val)))))))))
+
+ (($ <call> src proc args)
+ (convert-args (cons proc args)
+ (match-lambda
+ ((proc . args)
+ (build-cps-term ($continue k src ($call proc args)))))))
+
+ (($ <primcall> src name args)
+ (cond
+ ((branching-primitive? name)
+ (convert-args args
+ (lambda (args)
+ (let-fresh (kt kf) ()
+ (build-cps-term
+ ($letk ((kt ($kargs () () ($continue k src ($const #t))))
+ (kf ($kargs () () ($continue k src ($const #f)))))
+ ($continue kf src
+ ($branch kt ($primcall name args)))))))))
+ ((and (eq? name 'not) (match args ((_) #t) (_ #f)))
+ (convert-args args
+ (lambda (args)
+ (let-fresh (kt kf) ()
+ (build-cps-term
+ ($letk ((kt ($kargs () () ($continue k src ($const #f))))
+ (kf ($kargs () () ($continue k src ($const #t)))))
+ ($continue kf src
+ ($branch kt ($values args)))))))))
+ ((and (eq? name 'list)
+ (and-map (match-lambda
+ ((or ($ <const>)
+ ($ <void>)
+ ($ <lambda>)
+ ($ <lexical-ref>)) #t)
+ (_ #f))
+ args))
+ ;; See note below in `canonicalize' about `vector'. The same
+ ;; thing applies to `list'.
+ (let lp ((args args) (k k))
+ (match args
+ (()
+ (build-cps-term
+ ($continue k src ($const '()))))
+ ((arg . args)
+ (let-fresh (ktail) (tail)
+ (build-cps-term
+ ($letk ((ktail ($kargs ('tail) (tail)
+ ,(convert-arg arg
+ (lambda (head)
+ (build-cps-term
+ ($continue k src
+ ($primcall 'cons (head tail)))))))))
+ ,(lp args ktail))))))))
+ (else
+ (convert-args args
+ (lambda (args)
+ (build-cps-term ($continue k src ($primcall name args))))))))
+
+ ;; Prompts with inline handlers.
+ (($ <prompt> src escape-only? tag body
+ ($ <lambda> hsrc hmeta
+ ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ ;; Handler:
+ ;; khargs: check args returned to handler, -> khbody
+ ;; khbody: the handler, -> k
+ ;;
+ ;; Post-body:
+ ;; krest: collect return vals from body to list, -> kpop
+ ;; kpop: pop the prompt, -> kprim
+ ;; kprim: load the values primitive, -> kret
+ ;; kret: (apply values rvals), -> k
+ ;;
+ ;; Escape prompts evaluate the body with the continuation of krest.
+ ;; Otherwise we do a no-inline call to body, continuing to krest.
+ (convert-arg tag
+ (lambda (tag)
+ (let ((hnames (append hreq (if hrest (list hrest) '())))
+ (bound-vars (map bound-var hsyms)))
+ (let-fresh (khargs khbody kret kprim kpop krest kbody) (prim vals)
+ (build-cps-term
+ ;; FIXME: Attach hsrc to $kreceive.
+ ($letk* ((khbody ($kargs hnames bound-vars
+ ,(fold box-bound-var
+ (convert hbody k subst)
+ hnames hsyms)))
+ (khargs ($kreceive hreq hrest khbody))
+ (kpop ($kargs ('rest) (vals)
+ ($letk ((kret
+ ($kargs () ()
+ ($letk ((kprim
+ ($kargs ('prim) (prim)
+ ($continue k src
+ ($primcall 'apply
+ (prim vals))))))
+ ($continue kprim src
+ ($prim 'values))))))
+ ($continue kret src
+ ($primcall 'unwind ())))))
+ (krest ($kreceive '() 'rest kpop)))
+ ,(if escape-only?
+ (build-cps-term
+ ($letk ((kbody ($kargs () ()
+ ,(convert body krest subst))))
+ ($continue kbody src ($prompt #t tag khargs))))
+ (convert-arg body
+ (lambda (thunk)
+ (build-cps-term
+ ($letk ((kbody ($kargs () ()
+ ($continue krest (tree-il-src body)
+ ($primcall 'call-thunk/no-inline
+ (thunk))))))
+ ($continue kbody (tree-il-src body)
+ ($prompt #f tag khargs))))))))))))))
+
+ (($ <abort> src tag args ($ <const> _ ()))
+ (convert-args (cons tag args)
+ (lambda (args*)
+ (build-cps-term
+ ($continue k src
+ ($primcall 'abort-to-prompt args*))))))
+
+ (($ <abort> src tag args tail)
+ (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
+ tag)
+ args
+ (list tail))
+ (lambda (args*)
+ (build-cps-term
+ ($continue k src ($primcall 'apply args*))))))
+
+ (($ <conditional> src test consequent alternate)
+ (let-fresh (kt kf) ()
+ (build-cps-term
+ ($letk* ((kt ($kargs () () ,(convert consequent k subst)))
+ (kf ($kargs () () ,(convert alternate k subst))))
+ ,(match test
+ (($ <primcall> src (? branching-primitive? name) args)
+ (convert-args args
+ (lambda (args)
+ (build-cps-term
+ ($continue kf src
+ ($branch kt ($primcall name args)))))))
+ (_ (convert-arg test
+ (lambda (test)
+ (build-cps-term
+ ($continue kf src
+ ($branch kt ($values (test)))))))))))))
+
+ (($ <lexical-set> src name gensym exp)
+ (convert-arg exp
+ (lambda (exp)
+ (match (hashq-ref subst gensym)
+ ((orig-var box #t)
+ (build-cps-term
+ ($continue k src ($primcall 'box-set! (box exp)))))))))
+
+ (($ <seq> src head tail)
+ (let-fresh (kreceive kseq) (vals)
+ (build-cps-term
+ ($letk* ((kseq ($kargs ('vals) (vals)
+ ,(convert tail k subst)))
+ (kreceive ($kreceive '() 'vals kseq)))
+ ,(convert head kreceive subst)))))
+
+ (($ <let> src names syms vals body)
+ (let lp ((names names) (syms syms) (vals vals))
+ (match (list names syms vals)
+ ((() () ()) (convert body k subst))
+ (((name . names) (sym . syms) (val . vals))
+ (let-fresh (kreceive klet) (rest)
+ (build-cps-term
+ ($letk* ((klet ($kargs (name 'rest) ((bound-var sym) rest)
+ ,(box-bound-var name sym
+ (lp names syms vals))))
+ (kreceive ($kreceive (list name) 'rest klet)))
+ ,(convert val kreceive subst))))))))
+
+ (($ <fix> src names gensyms funs body)
+ ;; Some letrecs can be contified; that happens later.
+ (if (current-topbox-scope)
+ (let-fresh () (self)
+ (build-cps-term
+ ($letrec names
+ (map bound-var gensyms)
+ (map (lambda (fun)
+ (match (convert fun k subst)
+ (($ $continue _ _ (and fun ($ $fun)))
+ fun)))
+ funs)
+ ,(convert body k subst))))
+ (let ((scope-id (fresh-scope-id)))
+ (let-fresh (kscope) ()
+ (build-cps-term
+ ($letk ((kscope
+ ($kargs () ()
+ ,(parameterize ((current-topbox-scope scope-id))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope src scope-id kscope)))))))
+
+ (($ <let-values> src exp
+ ($ <lambda-case> lsrc req #f rest #f () syms body #f))
+ (let ((names (append req (if rest (list rest) '())))
+ (bound-vars (map bound-var syms)))
+ (let-fresh (kreceive kargs) ()
+ (build-cps-term
+ ($letk* ((kargs ($kargs names bound-vars
+ ,(fold box-bound-var
+ (convert body k subst)
+ names syms)))
+ (kreceive ($kreceive req rest kargs)))
+ ,(convert exp kreceive subst))))))))
+
+(define (build-subst exp)
+ "Compute a mapping from lexical gensyms to CPS variable indexes. CPS
+uses small integers to identify variables, instead of gensyms.
+
+This subst table serves an additional purpose of mapping variables to
+replacements. The usual reason to replace one variable by another is
+assignment conversion. Default argument values is the other reason.
+
+The result is a hash table mapping symbols to substitutions (in the case
+that a variable is substituted) or to indexes. A substitution is a list
+of the form:
+
+ (ORIG-INDEX SUBST-INDEX BOXED?)
+
+A true value for BOXED? indicates that the replacement variable is in a
+box. If a variable is not substituted, the mapped value is a small
+integer."
+ (let ((table (make-hash-table)))
+ (define (down exp)
+ (match exp
+ (($ <lexical-set> src name sym exp)
+ (match (hashq-ref table sym)
+ ((orig subst #t) #t)
+ ((orig subst #f) (hashq-set! table sym (list orig subst #t)))
+ ((? number? idx) (hashq-set! table sym (list idx (fresh-var) #t)))))
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (fold-formals (lambda (name sym init seed)
+ (hashq-set! table sym
+ (if init
+ (list (fresh-var) (fresh-var) #f)
+ (fresh-var))))
+ #f
+ (make-$arity req (or opt '()) rest
+ (if kw (cdr kw) '()) (and kw (car kw)))
+ gensyms
+ inits))
+ (($ <let> src names gensyms vals body)
+ (for-each (lambda (sym)
+ (hashq-set! table sym (fresh-var)))
+ gensyms))
+ (($ <fix> src names gensyms vals body)
+ (for-each (lambda (sym)
+ (hashq-set! table sym (fresh-var)))
+ gensyms))
+ (_ #t))
+ (values))
+ (define (up exp) (values))
+ ((make-tree-il-folder) exp down up)
+ table))
+
+(define (cps-convert/thunk exp)
+ (parameterize ((label-counter 0)
+ (var-counter 0)
+ (scope-counter 0))
+ (let ((src (tree-il-src exp)))
+ (let-fresh (kinit ktail kclause kbody) (init)
+ (build-cps-cont
+ (kinit ($kfun src '() init (ktail ($ktail))
+ (kclause
+ ($kclause ('() '() #f '() #f)
+ (kbody ($kargs () ()
+ ,(convert exp ktail
+ (build-subst exp))))
+ ,#f)))))))))
+
+(define *comp-module* (make-fluid))
+
+(define %warning-passes
+ `((unused-variable . ,unused-variable-analysis)
+ (unused-toplevel . ,unused-toplevel-analysis)
+ (unbound-variable . ,unbound-variable-analysis)
+ (arity-mismatch . ,arity-analysis)
+ (format . ,format-analysis)))
+
+(define (optimize-tree-il x e opts)
+ (define warnings
+ (or (and=> (memq #:warnings opts) cadr)
+ '()))
+
+ ;; Go through the warning passes.
+ (let ((analyses (filter-map (lambda (kind)
+ (assoc-ref %warning-passes kind))
+ warnings)))
+ (analyze-tree analyses x e))
+
+ (optimize x e opts))
+
+(define (canonicalize exp)
+ (post-order
+ (lambda (exp)
+ (match exp
+ (($ <primcall> src 'vector
+ (and args
+ ((or ($ <const>) ($ <void>) ($ <lambda>) ($ <lexical-ref>))
+ ...)))
+ ;; Some macros generate calls to "vector" with like 300
+ ;; arguments. Since we eventually compile to make-vector and
+ ;; vector-set!, it reduces live variable pressure to allocate the
+ ;; vector first, then set values as they are produced, if we can
+ ;; prove that no value can capture the continuation. (More on
+ ;; that caveat here:
+ ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
+ ;;
+ ;; Normally we would do this transformation in the compiler, but
+ ;; it's quite tricky there and quite easy here, so hold your nose
+ ;; while we drop some smelly code.
+ (let ((len (length args))
+ (v (gensym "v ")))
+ (make-let src
+ (list 'v)
+ (list v)
+ (list (make-primcall src 'make-vector
+ (list (make-const #f len)
+ (make-const #f #f))))
+ (fold (lambda (arg n tail)
+ (make-seq
+ src
+ (make-primcall
+ src 'vector-set!
+ (list (make-lexical-ref src 'v v)
+ (make-const #f n)
+ arg))
+ tail))
+ (make-lexical-ref src 'v v)
+ (reverse args) (reverse (iota len))))))
+
+ (($ <primcall> src 'struct-set! (struct index value))
+ ;; Unhappily, and undocumentedly, struct-set! returns the value
+ ;; that was set. There is code that relies on this. Hackety
+ ;; hack...
+ (let ((v (gensym "v ")))
+ (make-let src
+ (list 'v)
+ (list v)
+ (list value)
+ (make-seq src
+ (make-primcall src 'struct-set!
+ (list struct
+ index
+ (make-lexical-ref src 'v v)))
+ (make-lexical-ref src 'v v)))))
+
+ (($ <prompt> src escape-only? tag body
+ ($ <lambda> hsrc hmeta
+ ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ exp)
+
+ ;; Eta-convert prompts without inline handlers.
+ (($ <prompt> src escape-only? tag body handler)
+ (let ((h (gensym "h "))
+ (args (gensym "args ")))
+ (make-let
+ src (list 'h) (list h) (list handler)
+ (make-seq
+ src
+ (make-conditional
+ src
+ (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
+ (make-void src)
+ (make-primcall
+ src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "call-with-prompt")
+ (make-const #f "Wrong type (expecting procedure): ~S")
+ (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
+ (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
+ (make-prompt
+ src escape-only? tag body
+ (make-lambda
+ src '()
+ (make-lambda-case
+ src '() #f 'args #f '() (list args)
+ (make-primcall
+ src 'apply
+ (list (make-lexical-ref #f 'h h)
+ (make-lexical-ref #f 'args args)))
+ #f)))))))
+ (_ exp)))
+ exp))
+
+(define (compile-cps exp env opts)
+ (values (cps-convert/thunk
+ (canonicalize (optimize-tree-il exp env opts)))
+ env
+ env))
+
+;;; Local Variables:
+;;; eval: (put 'convert-arg 'scheme-indent-function 1)
+;;; eval: (put 'convert-args 'scheme-indent-function 1)
+;;; End:
+++ /dev/null
-;;; TREE-IL -> GLIL compiler
-
-;; Copyright (C) 2001,2008,2009,2010,2011,2012,2013,2014 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 tree-il compile-glil)
- #:use-module (system base syntax)
- #:use-module (system base pmatch)
- #:use-module (system base message)
- #:use-module (ice-9 receive)
- #:use-module (language glil)
- #:use-module (system vm instruction)
- #:use-module (language tree-il)
- #:use-module (language tree-il optimize)
- #:use-module (language tree-il canonicalize)
- #:use-module (language tree-il analyze)
- #:use-module ((srfi srfi-1) #:select (filter-map))
- #:export (compile-glil))
-
-;; allocation:
-;; sym -> {lambda -> address}
-;; lambda -> (labels . free-locs)
-;; lambda-case -> (gensym . nlocs)
-;;
-;; 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 . ,unused-variable-analysis)
- (unused-toplevel . ,unused-toplevel-analysis)
- (unbound-variable . ,unbound-variable-analysis)
- (arity-mismatch . ,arity-analysis)
- (format . ,format-analysis)))
-
-(define (compile-glil x e opts)
- (define warnings
- (or (and=> (memq #:warnings opts) cadr)
- '()))
-
- ;; 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) '()
- (make-lambda-case #f '() #f #f #f '() '() x #f)))
- (x (optimize! x e opts))
- (x (canonicalize! x))
- (allocation (analyze-lexicals x)))
-
- (with-fluids ((*comp-module* e))
- (values (flatten-lambda x #f allocation)
- e
- e))))
-
-\f
-
-(define *primcall-ops* (make-hash-table))
-(for-each
- (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
- '(((eq? . 2) . eq?)
- ((eqv? . 2) . eqv?)
- ((equal? . 2) . equal?)
- ((= . 2) . ee?)
- ((< . 2) . lt?)
- ((> . 2) . gt?)
- ((<= . 2) . le?)
- ((>= . 2) . ge?)
- ((+ . 2) . add)
- ((- . 2) . sub)
- ((1+ . 1) . add1)
- ((1- . 1) . sub1)
- ((* . 2) . mul)
- ((/ . 2) . div)
- ((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)
- ((car . 1) . car)
- ((cdr . 1) . cdr)
- ((set-car! . 2) . set-car!)
- ((set-cdr! . 2) . set-cdr!)
- ((null? . 1) . null?)
- ((list? . 1) . list?)
- ((symbol? . 1) . symbol?)
- ((vector? . 1) . vector?)
- (list . list)
- (vector . vector)
- ((class-of . 1) . class-of)
- ((vector-ref . 2) . vector-ref)
- ((vector-set! . 3) . vector-set)
- ((variable-ref . 1) . variable-ref)
- ;; nb, *not* variable-set! -- the args are switched
- ((variable-bound? . 1) . variable-bound?)
- ((struct? . 1) . struct?)
- ((struct-vtable . 1) . struct-vtable)
- ((struct-ref . 2) . struct-ref)
- ((struct-set! . 3) . struct-set)
- (make-struct/no-tail . make-struct)
-
- ;; hack for javascript
- ((return . 1) . return)
- ;; hack for lua
- (return/values . return/values)
-
- ((bytevector-u8-ref . 2) . bv-u8-ref)
- ((bytevector-u8-set! . 3) . bv-u8-set)
- ((bytevector-s8-ref . 2) . bv-s8-ref)
- ((bytevector-s8-set! . 3) . bv-s8-set)
-
- ((bytevector-u16-ref . 3) . bv-u16-ref)
- ((bytevector-u16-set! . 4) . bv-u16-set)
- ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
- ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
- ((bytevector-s16-ref . 3) . bv-s16-ref)
- ((bytevector-s16-set! . 4) . bv-s16-set)
- ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
- ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
-
- ((bytevector-u32-ref . 3) . bv-u32-ref)
- ((bytevector-u32-set! . 4) . bv-u32-set)
- ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
- ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
- ((bytevector-s32-ref . 3) . bv-s32-ref)
- ((bytevector-s32-set! . 4) . bv-s32-set)
- ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
- ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
-
- ((bytevector-u64-ref . 3) . bv-u64-ref)
- ((bytevector-u64-set! . 4) . bv-u64-set)
- ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
- ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
- ((bytevector-s64-ref . 3) . bv-s64-ref)
- ((bytevector-s64-set! . 4) . bv-s64-set)
- ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
- ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
-
- ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
- ((bytevector-ieee-single-set! . 4) . bv-f32-set)
- ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
- ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
- ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
- ((bytevector-ieee-double-set! . 4) . bv-f64-set)
- ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
- ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
-
-
-\f
-
-(define (make-label) (gensym ":L"))
-
-(define (vars->bind-list ids vars allocation proc)
- (map (lambda (id v)
- (pmatch (hashq-ref (hashq-ref allocation v) proc)
- ((#t ,boxed? . ,n)
- (list id boxed? n))
- (,x (error "bad var list element" id v x))))
- ids
- vars))
-
-(define (emit-bindings src ids vars allocation proc emit-code)
- (emit-code src (make-glil-bind
- (vars->bind-list ids vars allocation proc))))
-
-(define (with-output-to-code proc)
- (let ((out '()))
- (define (emit-code src x)
- (set! out (cons x out))
- (if src
- (set! out (cons (make-glil-source src) out))))
- (proc emit-code)
- (reverse out)))
-
-(define (flatten-lambda x self-label allocation)
- (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)))
- ;; compile the body, yo
- (flatten-lambda-case body allocation x self-label
- (car (hashq-ref allocation x))
- emit-code)))))))
-
-(define (flatten-lambda-case lcase allocation self self-label fix-labels
- emit-code)
- (define (emit-label label)
- (emit-code #f (make-glil-label label)))
- (define (emit-branch src inst label)
- (emit-code src (make-glil-branch inst label)))
-
- ;; RA: "return address"; #f unless we're in a non-tail fix with labels
- ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
- (let comp ((x lcase) (context 'tail) (RA #f) (MVRA #f))
- (define (comp-tail tree) (comp tree context RA MVRA))
- (define (comp-push tree) (comp tree 'push #f #f))
- (define (comp-drop tree) (comp tree 'drop #f #f))
- (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
- (define (comp-fix tree RA) (comp tree context RA MVRA))
-
- ;; A couple of helpers. Note that if we are in tail context, we
- ;; won't have an RA.
- (define (maybe-emit-return)
- (if RA
- (emit-branch #f 'br RA)
- (if (eq? context 'tail)
- (emit-code #f (make-glil-call 'return 1)))))
-
- ;; After lexical binding forms in non-tail context, call this
- ;; function to clear stack slots, allowing their previous values to
- ;; be collected.
- (define (clear-stack-slots context syms)
- (case context
- ((push drop)
- (for-each (lambda (v)
- (and=>
- ;; Can be #f if the var is labels-allocated.
- (hashq-ref allocation v)
- (lambda (h)
- (pmatch (hashq-ref h self)
- ((#t _ . ,n)
- (emit-code #f (make-glil-void))
- (emit-code #f (make-glil-lexical #t #f 'set n)))
- (,loc (error "bad let var allocation" x loc))))))
- syms))))
-
- (record-case x
- ((<void>)
- (case context
- ((push vals tail)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((<const> src exp)
- (case context
- ((push vals tail)
- (emit-code src (make-glil-const exp))))
- (maybe-emit-return))
-
- ;; FIXME: should represent sequence as exps tail
- ((<sequence> exps)
- (let lp ((exps exps))
- (if (null? (cdr exps))
- (comp-tail (car exps))
- (begin
- (comp-drop (car exps))
- (lp (cdr exps))))))
-
- ((<application> src proc args)
- ;; FIXME: need a better pattern-matcher here
- (cond
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@apply)
- (>= (length args) 1))
- (let ((proc (car args))
- (args (cdr args)))
- (cond
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)) (not (eq? context 'vals)))
- ;; tail: (lambda () (apply values '(1 2)))
- ;; drop: (lambda () (apply values '(1 2)) 3)
- ;; push: (lambda () (list (apply values '(10 12)) 1))
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((tail)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'return/values* (length args))))))
-
- (else
- (case context
- ((tail)
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
- ((push)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length args))))
- (maybe-emit-return))
- ((vals)
- (comp-vals
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args))
- MVRA)
- (maybe-emit-return))
- ((drop)
- ;; Well, shit. The proc might return any number of
- ;; values (including 0), since it's in a drop context,
- ;; yet apply does not create a MV continuation. So we
- ;; mv-call out to our trampoline instead.
- (comp-drop
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values))
- ;; tail: (lambda () (values '(1 2)))
- ;; drop: (lambda () (values '(1 2)) 3)
- ;; push: (lambda () (list (values '(10 12)) 1))
- ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((push)
- (case (length args)
- ((0)
- ;; FIXME: This is surely an error. We need to add a
- ;; values-mismatch warning pass.
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (emit-code src (make-glil-call 'call 0))
- (maybe-emit-return))
- (else
- ;; Taking advantage of unspecified order of evaluation of
- ;; arguments.
- (for-each comp-drop (cdr args))
- (comp-push (car args))
- (maybe-emit-return))))
- ((vals)
- (for-each comp-push args)
- (emit-code #f (make-glil-const (length args)))
- (emit-branch src 'br MVRA))
- ((tail)
- (for-each comp-push args)
- (emit-code src (let ((len (length args)))
- (if (= len 1)
- (make-glil-call 'return 1)
- (make-glil-call 'return/values len)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-values)
- (= (length args) 2))
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (case context
- ((vals)
- ;; Fall back.
- (comp-vals
- (make-application src (make-primitive-ref #f 'call-with-values)
- args)
- MVRA)
- (maybe-emit-return))
- (else
- (let ((MV (make-label)) (POST (make-label))
- (producer (car args)) (consumer (cadr args)))
- (if (not (eq? context 'tail))
- (emit-code src (make-glil-call 'new-frame 0)))
- (comp-push consumer)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push producer)
- (emit-code src (make-glil-mv-call 0 MV))
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call 1)))
- (else (emit-code src (make-glil-call 'call 1))
- (emit-branch #f 'br POST)))
- (emit-label MV)
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
- (else (emit-code src (make-glil-call 'call/nargs 0))
- (emit-label POST)
- (if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-current-continuation)
- (= (length args) 1))
- (case context
- ((tail)
- (comp-push (car args))
- (emit-code src (make-glil-call 'tail-call/cc 1)))
- ((vals)
- (comp-vals
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args)
- MVRA)
- (maybe-emit-return))
- ((push)
- (comp-push (car args))
- (emit-code src (make-glil-call 'call/cc 1))
- (maybe-emit-return))
- ((drop)
- ;; Crap. Just like `apply' in drop context.
- (comp-drop
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args))
- (maybe-emit-return))))
-
- ;; A hack for variable-set, the opcode for which takes its args
- ;; reversed, relative to the variable-set! function
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) 'variable-set!)
- (= (length args) 2))
- (comp-push (cadr args))
- (comp-push (car args))
- (emit-code src (make-glil-call 'variable-set 2))
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((and (primitive-ref? proc)
- (or (hash-ref *primcall-ops*
- (cons (primitive-ref-name proc) (length args)))
- (hash-ref *primcall-ops* (primitive-ref-name proc))))
- => (lambda (op)
- (for-each comp-push args)
- (emit-code src (make-glil-call op (length args)))
- (case (instruction-pushes op)
- ((0)
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
- ((1)
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
- ((-1)
- ;; A control instruction, like return/values. Here we
- ;; just have to hope that the author of the tree-il
- ;; knew what they were doing.
- *unspecified*)
- (else
- (error "bad primitive op: too many pushes"
- op (instruction-pushes op))))))
-
- ;; call to the same lambda-case in tail position
- ((and (lexical-ref? proc)
- self-label (eq? (lexical-ref-gensym proc) self-label)
- (eq? context 'tail)
- (not (lambda-case-kw lcase))
- (not (lambda-case-rest lcase))
- (= (length args)
- (+ (length (lambda-case-req lcase))
- (or (and=> (lambda-case-opt lcase) length) 0))))
- (for-each comp-push args)
- (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 "bad lambda-case arg allocation" x))))
- (reverse (lambda-case-gensyms lcase)))
- (emit-branch src 'br (car (hashq-ref allocation lcase))))
-
- ;; lambda, the ultimate goto
- ((and (lexical-ref? proc)
- (assq (lexical-ref-gensym proc) fix-labels))
- ;; 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)
- ;; 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 "bad lambda-case arg allocation" x))))
- (reverse (lambda-case-gensyms lcase)))
- (emit-branch src 'br (car (hashq-ref allocation lcase))))
- ((lambda-case? lcase)
- ;; no match, try next case
- (lp (lambda-case-alternate 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-code src (make-glil-call 'new-frame 0)))
- (comp-push proc)
- (for-each comp-push args)
- (let ((len (length args)))
- (case context
- ((tail) (if (<= len #xff)
- (emit-code src (make-glil-call 'tail-call len))
- (begin
- (comp-push (make-const #f len))
- (emit-code src (make-glil-call 'tail-call/nargs 0)))))
- ((push) (if (<= len #xff)
- (emit-code src (make-glil-call 'call len))
- (begin
- (comp-push (make-const #f len))
- (emit-code src (make-glil-call 'call/nargs 0))))
- (maybe-emit-return))
- ;; FIXME: mv-call doesn't have a /nargs variant, so it is
- ;; limited to 255 args. Can work around it with a
- ;; trampoline and tail-call/nargs, but it's not so nice.
- ((vals) (emit-code src (make-glil-mv-call len MVRA))
- (maybe-emit-return))
- ((drop) (let ((MV (make-label)) (POST (make-label)))
- (emit-code src (make-glil-mv-call len MV))
- (emit-code #f (make-glil-call 'drop 1))
- (emit-branch #f 'br (or RA POST))
- (emit-label MV)
- (emit-code #f (make-glil-mv-bind 0 #f))
- (if RA
- (emit-branch #f 'br RA)
- (emit-label POST)))))))))
-
- ((<conditional> src test consequent alternate)
- ;; TEST
- ;; (br-if-not L1)
- ;; consequent
- ;; (br L2)
- ;; L1: alternate
- ;; L2:
- (let ((L1 (make-label)) (L2 (make-label)))
- ;; 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 consequent)
- ;; 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 alternate)
- (if (and (not RA) (not (eq? context 'tail)))
- (emit-label L2))))
-
- ((<primitive-ref> src name)
- (cond
- ((eq? (module-variable (fluid-ref *comp-module*) name)
- (module-variable the-root-module name))
- (case context
- ((tail push vals)
- (emit-code src (make-glil-toplevel 'ref name))))
- (maybe-emit-return))
- ((module-variable the-root-module name)
- (case context
- ((tail push vals)
- (emit-code src (make-glil-module 'ref '(guile) name #f))))
- (maybe-emit-return))
- (else
- (case context
- ((tail push vals)
- (emit-code src (make-glil-module
- 'ref (module-name (fluid-ref *comp-module*)) name #f))))
- (maybe-emit-return))))
-
- ((<lexical-ref> src gensym)
- (case context
- ((push vals tail)
- (pmatch (hashq-ref (hashq-ref allocation gensym) self)
- ((,local? ,boxed? . ,index)
- (emit-code src (make-glil-lexical local? boxed? 'ref index)))
- (,loc
- (error "bad lexical allocation" x loc)))))
- (maybe-emit-return))
-
- ((<lexical-set> src gensym exp)
- (comp-push exp)
- (pmatch (hashq-ref (hashq-ref allocation gensym) self)
- ((,local? ,boxed? . ,index)
- (emit-code src (make-glil-lexical local? boxed? 'set index)))
- (,loc
- (error "bad lexical allocation" x loc)))
- (case context
- ((tail push vals)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((<module-ref> src mod name public?)
- (emit-code src (make-glil-module 'ref mod name public?))
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
-
- ((<module-set> src mod name public? exp)
- (comp-push exp)
- (emit-code src (make-glil-module 'set mod name public?))
- (case context
- ((tail push vals)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((<toplevel-ref> src name)
- (emit-code src (make-glil-toplevel 'ref name))
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
-
- ((<toplevel-set> src name exp)
- (comp-push exp)
- (emit-code src (make-glil-toplevel 'set name))
- (case context
- ((tail push vals)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((<toplevel-define> src name exp)
- (comp-push exp)
- (emit-code src (make-glil-toplevel 'define name))
- (case context
- ((tail push vals)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((<lambda>)
- (let ((free-locs (cdr (hashq-ref allocation x))))
- (case context
- ((push vals tail)
- (emit-code #f (flatten-lambda x #f allocation))
- (if (not (null? free-locs))
- (begin
- (for-each
- (lambda (loc)
- (pmatch loc
- ((,local? ,boxed? . ,n)
- (emit-code #f (make-glil-lexical local? #f 'ref n)))
- (else (error "bad lambda free var allocation" x loc))))
- free-locs)
- (emit-code #f (make-glil-call 'make-closure
- (length free-locs))))))))
- (maybe-emit-return))
-
- ((<lambda-case> src req opt rest kw inits gensyms alternate body)
- ;; o/~ feature on top of feature o/~
- ;; req := (name ...)
- ;; opt := (name ...) | #f
- ;; rest := name | #f
- ;; kw: (allow-other-keys? (keyword name var) ...) | #f
- ;; gensyms: (sym ...)
- ;; init: tree-il in context of gensyms
- ;; gensyms 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 gensyms 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)))
- (alternate-label (and alternate (make-label))))
- (or (= nargs
- (length gensyms)
- (+ nreq (length inits) (if rest 1 0)))
- (error "lambda-case gensyms don't correspond to args"
- req opt rest kw inits gensyms 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 alternate-label))
- ((or rest opt)
- (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label))
- (#t
- (make-glil-std-prelude nreq nlocs alternate-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)))))
- gensyms)
- ;; write bindings info
- (if (not (null? gensyms))
- (emit-bindings
- #f
- (let lp ((kw (if kw (cdr kw) '()))
- (names (append (reverse opt-names) (reverse req)))
- (gensyms (list-tail gensyms (+ nreq nopt
- (if rest 1 0)))))
- (pmatch kw
- (()
- ;; fixme: check that gensyms is empty
- (reverse (if rest (cons rest names) names)))
- (((,key ,name ,var) . ,kw)
- (if (memq var gensyms)
- (lp kw (cons name names) (delq var gensyms))
- (lp kw names gensyms)))
- (,kw (error "bad keywords, yo" kw))))
- gensyms allocation self emit-code))
- ;; init optional/kw args
- (let lp ((inits inits) (n nreq) (gensyms (list-tail gensyms nreq)))
- (cond
- ((null? inits)) ; done
- ((and rest-idx (= n rest-idx))
- (lp inits (1+ n) (cdr gensyms)))
- (#t
- (pmatch (hashq-ref (hashq-ref allocation (car gensyms)) 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 gensyms))))
- (#t (error "bad arg allocation" (car gensyms) inits))))))
- ;; post-prelude case label for label calls
- (emit-label (car (hashq-ref allocation x)))
- (comp-tail body)
- (if (not (null? gensyms))
- (emit-code #f (make-glil-unbind)))
- (if alternate-label
- (begin
- (emit-label alternate-label)
- (flatten-lambda-case alternate allocation self self-label
- fix-labels emit-code)))))
-
- ((<let> src names gensyms vals body)
- (for-each comp-push vals)
- (emit-bindings src names gensyms allocation self emit-code)
- (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 "bad let var allocation" x loc))))
- (reverse gensyms))
- (comp-tail body)
- (clear-stack-slots context gensyms)
- (emit-code #f (make-glil-unbind)))
-
- ((<letrec> src in-order? names gensyms vals body)
- ;; First prepare heap storage slots.
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'empty-box n)))
- (,loc (error "bad letrec var allocation" x loc))))
- gensyms)
- ;; Even though the slots are empty, the bindings are valid.
- (emit-bindings src names gensyms allocation self emit-code)
- (cond
- (in-order?
- ;; For letrec*, bind values in order.
- (for-each (lambda (name v val)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #t . ,n)
- (comp-push val)
- (emit-code src (make-glil-lexical #t #t 'set n)))
- (,loc (error "bad letrec var allocation" x loc))))
- names gensyms vals))
- (else
- ;; But for letrec, eval all values, then bind.
- (for-each comp-push vals)
- (for-each (lambda (v)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #t . ,n)
- (emit-code src (make-glil-lexical #t #t 'set n)))
- (,loc (error "bad letrec var allocation" x loc))))
- (reverse gensyms))))
- (comp-tail body)
- (clear-stack-slots context gensyms)
- (emit-code #f (make-glil-unbind)))
-
- ((<fix> src names gensyms vals body)
- ;; The ideal here is to just render the lambda bodies inline, and
- ;; wire the code together with gotos. We can do that if
- ;; analyze-lexicals has determined that a given var has "label"
- ;; allocation -- which is the case if it is in `fix-labels'.
- ;;
- ;; But even for closures that we can't inline, we can do some
- ;; tricks to avoid heap-allocation for the binding itself. Since
- ;; 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 ((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))
- (let ((free-locs (cdr (hashq-ref allocation x))))
- (if (not (null? free-locs))
- ;; Need to make-closure first, so we have a fresh closure on
- ;; the heap, but with a temporary free values.
- (begin
- (for-each (lambda (loc)
- (emit-code #f (make-glil-const #f)))
- free-locs)
- (emit-code #f (make-glil-call 'make-closure
- (length free-locs))))))
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code src (make-glil-lexical #t #f 'set n)))
- (,loc (error "bad fix var allocation" x loc))))
- (else
- ;; labels allocation: emit label & body, but jump over it
- (let ((POST (make-label)))
- (emit-branch #f 'br POST)
- (let lp ((lcase (lambda-body x)))
- (if lcase
- (record-case lcase
- ((<lambda-case> src req gensyms body alternate)
- (emit-label (car (hashq-ref allocation lcase)))
- ;; FIXME: opt & kw args in the bindings
- (emit-bindings #f req gensyms 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 alternate)))
- (emit-label POST)))))))
- vals
- gensyms)
- ;; Emit bindings metadata for closures
- (let ((binds (let lp ((out '()) (gensyms gensyms) (names names))
- (cond ((null? gensyms) (reverse! out))
- ((assq (car gensyms) fix-labels)
- (lp out (cdr gensyms) (cdr names)))
- (else
- (lp (acons (car gensyms) (car names) out)
- (cdr gensyms) (cdr names)))))))
- (emit-bindings src (map cdr binds) (map car binds)
- allocation self emit-code))
- ;; Now go back and fix up the bindings for closures.
- (for-each
- (lambda (x v)
- (let ((free-locs (if (hashq-ref allocation x)
- (cdr (hashq-ref allocation x))
- ;; can hit this latter case for labels allocation
- '())))
- (if (not (null? free-locs))
- (begin
- (for-each
- (lambda (loc)
- (pmatch loc
- ((,local? ,boxed? . ,n)
- (emit-code #f (make-glil-lexical local? #f 'ref n)))
- (else (error "bad free var allocation" x loc))))
- free-locs)
- (pmatch (hashq-ref (hashq-ref allocation v) self)
- ((#t #f . ,n)
- (emit-code #f (make-glil-lexical #t #f 'fix n)))
- (,loc (error "bad fix var allocation" x loc)))))))
- vals
- gensyms)
- (comp-tail body)
- (if new-RA
- (emit-label new-RA))
- (clear-stack-slots context gensyms)
- (emit-code #f (make-glil-unbind))))
-
- ((<let-values> src exp body)
- (record-case body
- ((<lambda-case> req opt kw rest gensyms body alternate)
- (if (or opt kw alternate)
- (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) '()))
- gensyms 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 "bad let-values var allocation" x loc))))
- (reverse gensyms))
- (comp-tail body)
- (clear-stack-slots context gensyms)
- (emit-code #f (make-glil-unbind))))))
-
- ;; much trickier than i thought this would be, at first, due to the need
- ;; to have body's return value(s) on the stack while the unwinder runs,
- ;; then proceed with returning or dropping or what-have-you, interacting
- ;; with RA and MVRA. What have you, I say.
- ((<dynwind> src body winder unwinder)
- (comp-push winder)
- (comp-push unwinder)
- (comp-drop (make-application src winder '()))
- (emit-code #f (make-glil-call 'wind 2))
-
- (case context
- ((tail)
- (let ((MV (make-label)))
- (comp-vals body MV)
- ;; one value: unwind...
- (emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
- ;; ...and return the val
- (emit-code #f (make-glil-call 'return 1))
-
- (emit-label MV)
- ;; multiple values: unwind...
- (emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
- ;; and return the values.
- (emit-code #f (make-glil-call 'return/nvalues 1))))
-
- ((push)
- ;; we only want one value. so ask for one value
- (comp-push body)
- ;; and unwind, leaving the val on the stack
- (emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '())))
-
- ((vals)
- (let ((MV (make-label)))
- (comp-vals body MV)
- ;; one value: push 1 and fall through to MV case
- (emit-code #f (make-glil-const 1))
-
- (emit-label MV)
- ;; multiple values: unwind...
- (emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
- ;; and goto the MVRA.
- (emit-branch #f 'br MVRA)))
-
- ((drop)
- ;; compile body, discarding values. then unwind...
- (comp-drop body)
- (emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
- ;; and fall through, or goto RA if there is one.
- (if RA
- (emit-branch #f 'br RA)))))
-
- ((<dynlet> src fluids vals body)
- (for-each comp-push fluids)
- (for-each comp-push vals)
- (emit-code #f (make-glil-call 'wind-fluids (length fluids)))
-
- (case context
- ((tail)
- (let ((MV (make-label)))
- ;; NB: in tail case, it is possible to preserve asymptotic tail
- ;; recursion, via merging unwind-fluids structures -- but we'd need
- ;; to compile in the body twice (once in tail context, assuming the
- ;; caller unwinds, and once with this trampoline thing, unwinding
- ;; ourselves).
- (comp-vals body MV)
- ;; one value: unwind and return
- (emit-code #f (make-glil-call 'unwind-fluids 0))
- (emit-code #f (make-glil-call 'return 1))
-
- (emit-label MV)
- ;; multiple values: unwind and return values
- (emit-code #f (make-glil-call 'unwind-fluids 0))
- (emit-code #f (make-glil-call 'return/nvalues 1))))
-
- ((push)
- (comp-push body)
- (emit-code #f (make-glil-call 'unwind-fluids 0)))
-
- ((vals)
- (let ((MV (make-label)))
- (comp-vals body MV)
- ;; one value: push 1 and fall through to MV case
- (emit-code #f (make-glil-const 1))
-
- (emit-label MV)
- ;; multiple values: unwind and goto MVRA
- (emit-code #f (make-glil-call 'unwind-fluids 0))
- (emit-branch #f 'br MVRA)))
-
- ((drop)
- ;; compile body, discarding values. then unwind...
- (comp-drop body)
- (emit-code #f (make-glil-call 'unwind-fluids 0))
- ;; and fall through, or goto RA if there is one.
- (if RA
- (emit-branch #f 'br RA)))))
-
- ((<dynref> src fluid)
- (case context
- ((drop)
- (comp-drop fluid))
- ((push vals tail)
- (comp-push fluid)
- (emit-code #f (make-glil-call 'fluid-ref 1))))
- (maybe-emit-return))
-
- ((<dynset> src fluid exp)
- (comp-push fluid)
- (comp-push exp)
- (emit-code #f (make-glil-call 'fluid-set 2))
- (case context
- ((push vals tail)
- (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ;; What's the deal here? The deal is that we are compiling the start of a
- ;; delimited continuation. We try to avoid heap allocation in the normal
- ;; case; so the body is an expression, not a thunk, and we try to render
- ;; the handler inline. Also we did some analysis, in analyze.scm, so that
- ;; if the continuation isn't referenced, we don't reify it. This makes it
- ;; possible to implement catch and throw with delimited continuations,
- ;; without any overhead.
- ((<prompt> src tag body handler)
- (let ((H (make-label))
- (POST (make-label))
- (escape-only? (hashq-ref allocation x)))
- ;; First, set up the prompt.
- (comp-push tag)
- (emit-code src (make-glil-prompt H escape-only?))
-
- ;; Then we compile the body, with its normal return path, unwinding
- ;; before proceeding.
- (case context
- ((tail)
- (let ((MV (make-label)))
- (comp-vals body MV)
- ;; one value: unwind and return
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-code #f (make-glil-call 'return 1))
- ;; multiple values: unwind and return
- (emit-label MV)
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-code #f (make-glil-call 'return/nvalues 1))))
-
- ((push)
- ;; we only want one value. so ask for one value, unwind, and jump to
- ;; post
- (comp-push body)
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-branch #f 'br (or RA POST)))
-
- ((vals)
- (let ((MV (make-label)))
- (comp-vals body MV)
- ;; one value: push 1 and fall through to MV case
- (emit-code #f (make-glil-const 1))
- ;; multiple values: unwind and goto MVRA
- (emit-label MV)
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-branch #f 'br MVRA)))
-
- ((drop)
- ;; compile body, discarding values, then unwind & fall through.
- (comp-drop body)
- (emit-code #f (make-glil-call 'unwind 0))
- (emit-branch #f 'br (or RA POST))))
-
- (emit-label H)
- ;; Now the handler. The stack is now made up of the continuation, and
- ;; then the args to the continuation (pushed separately), and then the
- ;; number of args, including the continuation.
- (record-case handler
- ((<lambda-case> req opt kw rest gensyms body alternate)
- (if (or opt kw alternate)
- (error "unexpected lambda-case in prompt" x))
- (emit-code src (make-glil-mv-bind
- (vars->bind-list
- (append req (if rest (list rest) '()))
- gensyms 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 "bad prompt handler arg allocation" x loc))))
- (reverse gensyms))
- (comp-tail body)
- (emit-code #f (make-glil-unbind))))
-
- (if (and (not RA)
- (or (eq? context 'push) (eq? context 'drop)))
- (emit-label POST))))
-
- ((<abort> src tag args tail)
- (comp-push tag)
- (for-each comp-push args)
- (comp-push tail)
- (emit-code src (make-glil-call 'abort (length args)))
- ;; so, the abort can actually return. if it does, the values will be on
- ;; the stack, then the MV marker, just as in an MV context.
- (case context
- ((tail)
- ;; Return values.
- (emit-code #f (make-glil-call 'return/nvalues 1)))
- ((drop)
- ;; Drop all values and goto RA, or otherwise fall through.
- (emit-code #f (make-glil-mv-bind 0 #f))
- (if RA (emit-branch #f 'br RA)))
- ((push)
- ;; Truncate to one value.
- (emit-code #f (make-glil-mv-bind 1 #f)))
- ((vals)
- ;; Go to MVRA.
- (emit-branch #f 'br MVRA)))))))
+++ /dev/null
-;;; Common Subexpression Elimination (CSE) on Tree-IL
-
-;; Copyright (C) 2011, 2012, 2013 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 (language tree-il cse)
- #:use-module (language tree-il)
- #:use-module (language tree-il primitives)
- #:use-module (language tree-il effects)
- #:use-module (ice-9 vlist)
- #:use-module (ice-9 match)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:export (cse))
-
-;;;
-;;; This pass eliminates common subexpressions in Tree-IL. It works
-;;; best locally -- within a function -- so it is meant to be run after
-;;; partial evaluation, which usually inlines functions and so opens up
-;;; a bigger space for CSE to work.
-;;;
-;;; The algorithm traverses the tree of expressions, returning two
-;;; values: the newly rebuilt tree, and a "database". The database is
-;;; the set of expressions that will have been evaluated as part of
-;;; evaluating an expression. For example, in:
-;;;
-;;; (1- (+ (if a b c) (* x y)))
-;;;
-;;; We can say that when it comes time to evaluate (1- <>), that the
-;;; subexpressions +, x, y, and (* x y) must have been evaluated in
-;;; values context. We know that a was evaluated in test context, but
-;;; we don't know if it was true or false.
-;;;
-;;; The expressions in the database /dominate/ any subsequent
-;;; expression: FOO dominates BAR if evaluation of BAR implies that any
-;;; effects associated with FOO have already occured.
-;;;
-;;; When adding expressions to the database, we record the context in
-;;; which they are evaluated. We treat expressions in test context
-;;; specially: the presence of such an expression indicates that the
-;;; expression is true. In this way we can elide duplicate predicates.
-;;;
-;;; Duplicate predicates are not common in code that users write, but
-;;; can occur quite frequently in macro-generated code.
-;;;
-;;; For example:
-;;;
-;;; (and (foo? x) (foo-bar x))
-;;; => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;; (struct-ref x 1)
-;;; (throw 'not-a-foo))
-;;; #f))
-;;; => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;; (struct-ref x 1)
-;;; #f)
-;;;
-;;; A conditional bailout in effect context also has the effect of
-;;; adding predicates to the database:
-;;;
-;;; (begin (foo-bar x) (foo-baz x))
-;;; => (begin
-;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;; (struct-ref x 1)
-;;; (throw 'not-a-foo))
-;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;; (struct-ref x 2)
-;;; (throw 'not-a-foo)))
-;;; => (begin
-;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;; (struct-ref x 1)
-;;; (throw 'not-a-foo))
-;;; (struct-ref x 2))
-;;;
-;;; When removing code, we have to ensure that the semantics of the
-;;; source program and the residual program are the same. It's easy to
-;;; ensure that they have the same value, because those manipulations
-;;; are just algebraic, but the tricky thing is to ensure that the
-;;; expressions exhibit the same ordering of effects. For that, we use
-;;; the effects analysis of (language tree-il effects). We only
-;;; eliminate code if the duplicate code commutes with all of the
-;;; dominators on the path from the duplicate to the original.
-;;;
-;;; The implementation uses vhashes as the fundamental data structure.
-;;; This can be seen as a form of global value numbering. This
-;;; algorithm currently spends most of its time in vhash-assoc. I'm not
-;;; sure whether that is due to our bad hash function in Guile 2.0, an
-;;; inefficiency in vhashes, or what. Overall though the complexity
-;;; should be linear, or N log N -- whatever vhash-assoc's complexity
-;;; is. Walking the dominators is nonlinear, but that only happens when
-;;; we've actually found a common subexpression so that should be OK.
-;;;
-
-;; Logging helpers, as in peval.
-;;
-(define-syntax *logging* (identifier-syntax #f))
-;; (define %logging #f)
-;; (define-syntax *logging* (identifier-syntax %logging))
-(define-syntax log
- (syntax-rules (quote)
- ((log 'event arg ...)
- (if (and *logging*
- (or (eq? *logging* #t)
- (memq 'event *logging*)))
- (log* 'event arg ...)))))
-(define (log* event . args)
- (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print))
- 'pretty-print)))
- (pp `(log ,event . ,args))
- (newline)
- (values)))
-
-;; A pre-pass on the source program to determine the set of assigned
-;; lexicals.
-;;
-(define* (build-assigned-var-table exp #:optional (table vlist-null))
- (tree-il-fold
- (lambda (exp res)
- res)
- (lambda (exp res)
- (match exp
- (($ <lexical-set> src name gensym exp)
- (vhash-consq gensym #t res))
- (_ res)))
- (lambda (exp res) res)
- table exp))
-
-(define (boolean-valued-primitive? primitive)
- (or (negate-primitive primitive)
- (eq? primitive 'not)
- (let ((chars (symbol->string primitive)))
- (eqv? (string-ref chars (1- (string-length chars)))
- #\?))))
-
-(define (boolean-valued-expression? x ctx)
- (match x
- (($ <application> _
- ($ <primitive-ref> _ (? boolean-valued-primitive?))) #t)
- (($ <const> _ (? boolean?)) #t)
- (_ (eq? ctx 'test))))
-
-(define (singly-valued-expression? x ctx)
- (match x
- (($ <const>) #t)
- (($ <lexical-ref>) #t)
- (($ <void>) #t)
- (($ <lexical-ref>) #t)
- (($ <primitive-ref>) #t)
- (($ <module-ref>) #t)
- (($ <toplevel-ref>) #t)
- (($ <application> _
- ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
- (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
- (($ <lambda>) #t)
- (_ (eq? ctx 'value))))
-
-(define* (cse exp)
- "Eliminate common subexpressions in EXP."
-
- (define assigned-lexical?
- (let ((table (build-assigned-var-table exp)))
- (lambda (sym)
- (vhash-assq sym table))))
-
- (define %compute-effects
- (make-effects-analyzer assigned-lexical?))
-
- (define (negate exp ctx)
- (match exp
- (($ <const> src x)
- (make-const src (not x)))
- (($ <void> src)
- (make-const src #f))
- (($ <conditional> src test consequent alternate)
- (make-conditional src test (negate consequent ctx) (negate alternate ctx)))
- (($ <application> _ ($ <primitive-ref> _ 'not)
- ((and x (? (cut boolean-valued-expression? <> ctx)))))
- x)
- (($ <application> src
- ($ <primitive-ref> _ (and pred (? negate-primitive)))
- args)
- (make-application src
- (make-primitive-ref #f (negate-primitive pred))
- args))
- (_
- (make-application #f (make-primitive-ref #f 'not) (list exp)))))
-
-
- (define (hasher n)
- (lambda (x size) (modulo n size)))
-
- (define (add-to-db exp effects ctx db)
- (let ((v (vector exp effects ctx))
- (h (tree-il-hash exp)))
- (vhash-cons v h db (hasher h))))
-
- (define (control-flow-boundary db)
- (let ((h (hashq 'lambda most-positive-fixnum)))
- (vhash-cons 'lambda h db (hasher h))))
-
- (define (find-dominating-expression exp effects ctx db)
- (define (entry-matches? v1 v2)
- (match (if (vector? v1) v1 v2)
- (#(exp* effects* ctx*)
- (and (tree-il=? exp exp*)
- (or (not ctx) (eq? ctx* ctx))))
- (_ #f)))
-
- (let ((len (vlist-length db))
- (h (tree-il-hash exp)))
- (and (vhash-assoc #t db entry-matches? (hasher h))
- (let lp ((n 0))
- (and (< n len)
- (match (vlist-ref db n)
- (('lambda . h*)
- ;; We assume that lambdas can escape and thus be
- ;; called from anywhere. Thus code inside a lambda
- ;; only has a dominating expression if it does not
- ;; depend on any effects.
- (and (not (depends-on-effects? effects &all-effects))
- (lp (1+ n))))
- ((#(exp* effects* ctx*) . h*)
- (log 'walk (unparse-tree-il exp) effects
- (unparse-tree-il exp*) effects* ctx*)
- (or (and (= h h*)
- (or (not ctx) (eq? ctx ctx*))
- (tree-il=? exp exp*))
- (and (effects-commute? effects effects*)
- (lp (1+ n)))))))))))
-
- ;; Return #t if EXP is dominated by an instance of itself. In that
- ;; case, we can exclude *type-check* effects, because the first
- ;; expression already caused them if needed.
- (define (has-dominating-effect? exp effects db)
- (or (constant? effects)
- (and
- (effect-free?
- (exclude-effects effects
- (logior &zero-values
- &allocation
- &type-check)))
- (find-dominating-expression exp effects #f db))))
-
- (define (find-dominating-test exp effects db)
- (and
- (effect-free?
- (exclude-effects effects (logior &allocation
- &type-check)))
- (match exp
- (($ <const> src val)
- (if (boolean? val)
- exp
- (make-const src (not (not val)))))
- ;; For (not FOO), try to prove FOO, then negate the result.
- (($ <application> src ($ <primitive-ref> _ 'not) (exp*))
- (match (find-dominating-test exp* effects db)
- (($ <const> _ val)
- (log 'inferring exp (not val))
- (make-const src (not val)))
- (_
- #f)))
- (_
- (cond
- ((find-dominating-expression exp effects 'test db)
- ;; We have an EXP fact, so we infer #t.
- (log 'inferring exp #t)
- (make-const (tree-il-src exp) #t))
- ((find-dominating-expression (negate exp 'test) effects 'test db)
- ;; We have a (not EXP) fact, so we infer #f.
- (log 'inferring exp #f)
- (make-const (tree-il-src exp) #f))
- (else
- ;; Otherwise we don't know.
- #f))))))
-
- (define (add-to-env exp name sym db env)
- (let* ((v (vector exp name sym (vlist-length db)))
- (h (tree-il-hash exp)))
- (vhash-cons v h env (hasher h))))
-
- (define (augment-env env names syms exps db)
- (if (null? names)
- env
- (let ((name (car names)) (sym (car syms)) (exp (car exps)))
- (augment-env (if (or (assigned-lexical? sym)
- (lexical-ref? exp))
- env
- (add-to-env exp name sym db env))
- (cdr names) (cdr syms) (cdr exps) db))))
-
- (define (find-dominating-lexical exp effects env db)
- (define (entry-matches? v1 v2)
- (match (if (vector? v1) v1 v2)
- (#(exp* name sym db)
- (tree-il=? exp exp*))
- (_ #f)))
-
- (define (unroll db base n)
- (or (zero? n)
- (match (vlist-ref db base)
- (('lambda . h*)
- ;; See note in find-dominating-expression.
- (and (not (depends-on-effects? effects &all-effects))
- (unroll db (1+ base) (1- n))))
- ((#(exp* effects* ctx*) . h*)
- (and (effects-commute? effects effects*)
- (unroll db (1+ base) (1- n)))))))
-
- (let ((h (tree-il-hash exp)))
- (and (effect-free? (exclude-effects effects &type-check))
- (vhash-assoc exp env entry-matches? (hasher h))
- (let ((env-len (vlist-length env))
- (db-len (vlist-length db)))
- (let lp ((n 0) (m 0))
- (and (< n env-len)
- (match (vlist-ref env n)
- ((#(exp* name sym db-len*) . h*)
- (let ((niter (- (- db-len db-len*) m)))
- (and (unroll db m niter)
- (if (and (= h h*) (tree-il=? exp* exp))
- (make-lexical-ref (tree-il-src exp) name sym)
- (lp (1+ n) (- db-len db-len*)))))))))))))
-
- (define (lookup-lexical sym env)
- (let ((env-len (vlist-length env)))
- (let lp ((n 0))
- (and (< n env-len)
- (match (vlist-ref env n)
- ((#(exp _ sym* _) . _)
- (if (eq? sym sym*)
- exp
- (lp (1+ n)))))))))
-
- (define (intersection db+ db-)
- (vhash-fold-right
- (lambda (k h out)
- (if (vhash-assoc k db- equal? (hasher h))
- (vhash-cons k h out (hasher h))
- out))
- vlist-null
- db+))
-
- (define (concat db1 db2)
- (vhash-fold-right (lambda (k h tail)
- (vhash-cons k h tail (hasher h)))
- db2 db1))
-
- (let visit ((exp exp)
- (db vlist-null) ; dominating expressions: #(exp effects ctx) -> hash
- (env vlist-null) ; named expressions: #(exp name sym db) -> hash
- (ctx 'values)) ; test, effect, value, or values
-
- (define (parallel-visit exps db env ctx)
- (let lp ((in exps) (out '()) (db* vlist-null))
- (if (pair? in)
- (call-with-values (lambda () (visit (car in) db env ctx))
- (lambda (x db**)
- (lp (cdr in) (cons x out) (concat db** db*))))
- (values (reverse out) db*))))
-
- (define (compute-effects exp)
- (%compute-effects exp (lambda (sym) (lookup-lexical sym env))))
-
- (define (bailout? exp)
- (causes-effects? (compute-effects exp) &definite-bailout))
-
- (define (return exp db*)
- (let ((effects (compute-effects exp)))
- (cond
- ((and (eq? ctx 'effect)
- (not (lambda-case? exp))
- (or (effect-free?
- (exclude-effects effects
- (logior &zero-values
- &allocation)))
- (has-dominating-effect? exp effects db)))
- (cond
- ((void? exp)
- (values exp db*))
- (else
- (log 'elide ctx (unparse-tree-il exp))
- (values (make-void #f) db*))))
- ((and (boolean-valued-expression? exp ctx)
- (find-dominating-test exp effects db))
- => (lambda (exp)
- (log 'propagate-test ctx (unparse-tree-il exp))
- (values exp db*)))
- ((and (singly-valued-expression? exp ctx)
- (find-dominating-lexical exp effects env db))
- => (lambda (exp)
- (log 'propagate-value ctx (unparse-tree-il exp))
- (values exp db*)))
- ((and (constant? effects) (memq ctx '(value values)))
- ;; Adds nothing to the db.
- (values exp db*))
- (else
- (log 'return ctx effects (unparse-tree-il exp) db*)
- (values exp
- (add-to-db exp effects ctx db*))))))
-
- (log 'visit ctx (unparse-tree-il exp) db env)
-
- (match exp
- (($ <const>)
- (return exp vlist-null))
- (($ <void>)
- (return exp vlist-null))
- (($ <lexical-ref> _ _ gensym)
- (return exp vlist-null))
- (($ <lexical-set> src name gensym exp)
- (let*-values (((exp db*) (visit exp db env 'value)))
- (return (make-lexical-set src name gensym exp)
- db*)))
- (($ <let> src names gensyms vals body)
- (let*-values (((vals db*) (parallel-visit vals db env 'value))
- ((body db**) (visit body (concat db* db)
- (augment-env env names gensyms vals db)
- ctx)))
- (return (make-let src names gensyms vals body)
- (concat db** db*))))
- (($ <letrec> src in-order? names gensyms vals body)
- (let*-values (((vals db*) (parallel-visit vals db env 'value))
- ((body db**) (visit body (concat db* db)
- (augment-env env names gensyms vals db)
- ctx)))
- (return (make-letrec src in-order? names gensyms vals body)
- (concat db** db*))))
- (($ <fix> src names gensyms vals body)
- (let*-values (((vals db*) (parallel-visit vals db env 'value))
- ((body db**) (visit body (concat db* db) env ctx)))
- (return (make-fix src names gensyms vals body)
- (concat db** db*))))
- (($ <let-values> src producer consumer)
- (let*-values (((producer db*) (visit producer db env 'values))
- ((consumer db**) (visit consumer (concat db* db) env ctx)))
- (return (make-let-values src producer consumer)
- (concat db** db*))))
- (($ <dynwind> src winder body unwinder)
- (let*-values (((pre db*) (visit winder db env 'value))
- ((body db**) (visit body (concat db* db) env ctx))
- ((post db***) (visit unwinder db env 'value)))
- (return (make-dynwind src pre body post)
- (concat db* (concat db** db***)))))
- (($ <dynlet> src fluids vals body)
- (let*-values (((fluids db*) (parallel-visit fluids db env 'value))
- ((vals db**) (parallel-visit vals db env 'value))
- ((body db***) (visit body (concat db** (concat db* db))
- env ctx)))
- (return (make-dynlet src fluids vals body)
- (concat db*** (concat db** db*)))))
- (($ <dynref> src fluid)
- (let*-values (((fluid db*) (visit fluid db env 'value)))
- (return (make-dynref src fluid)
- db*)))
- (($ <dynset> src fluid exp)
- (let*-values (((fluid db*) (visit fluid db env 'value))
- ((exp db**) (visit exp db env 'value)))
- (return (make-dynset src fluid exp)
- (concat db** db*))))
- (($ <toplevel-ref>)
- (return exp vlist-null))
- (($ <module-ref>)
- (return exp vlist-null))
- (($ <module-set> src mod name public? exp)
- (let*-values (((exp db*) (visit exp db env 'value)))
- (return (make-module-set src mod name public? exp)
- db*)))
- (($ <toplevel-define> src name exp)
- (let*-values (((exp db*) (visit exp db env 'value)))
- (return (make-toplevel-define src name exp)
- db*)))
- (($ <toplevel-set> src name exp)
- (let*-values (((exp db*) (visit exp db env 'value)))
- (return (make-toplevel-set src name exp)
- db*)))
- (($ <primitive-ref>)
- (return exp vlist-null))
- (($ <conditional> src test consequent alternate)
- (let*-values
- (((test db+) (visit test db env 'test))
- ((converse db-) (visit (negate test 'test) db env 'test))
- ((consequent db++) (visit consequent (concat db+ db) env ctx))
- ((alternate db--) (visit alternate (concat db- db) env ctx)))
- (match (make-conditional src test consequent alternate)
- (($ <conditional> _ ($ <const> _ exp))
- (if exp
- (return consequent (concat db++ db+))
- (return alternate (concat db-- db-))))
- ;; (if FOO A A) => (begin FOO A)
- (($ <conditional> src _
- ($ <const> _ a) ($ <const> _ (? (cut equal? a <>))))
- (visit (make-sequence #f (list test (make-const #f a)))
- db env ctx))
- ;; (if FOO #t #f) => FOO for boolean-valued FOO.
- (($ <conditional> src
- (? (cut boolean-valued-expression? <> ctx))
- ($ <const> _ #t) ($ <const> _ #f))
- (return test db+))
- ;; (if FOO #f #t) => (not FOO)
- (($ <conditional> src _ ($ <const> _ #f) ($ <const> _ #t))
- (visit (negate test ctx) db env ctx))
-
- ;; Allow "and"-like conditions to accumulate in test context.
- ((and c ($ <conditional> _ _ _ ($ <const> _ #f)))
- (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null)))
- ((and c ($ <conditional> _ _ ($ <const> _ #f) _))
- (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null)))
-
- ;; Conditional bailouts turn expressions into predicates.
- ((and c ($ <conditional> _ _ _ (? bailout?)))
- (return c (concat db++ db+)))
- ((and c ($ <conditional> _ _ (? bailout?) _))
- (return c (concat db-- db-)))
-
- (c
- (return c (intersection (concat db++ db+) (concat db-- db-)))))))
- (($ <application> src proc args)
- (let*-values (((proc db*) (visit proc db env 'value))
- ((args db**) (parallel-visit args db env 'value)))
- (return (make-application src proc args)
- (concat db** db*))))
- (($ <lambda> src meta body)
- (let*-values (((body _) (if body
- (visit body (control-flow-boundary db)
- env 'values)
- (values #f #f))))
- (return (make-lambda src meta body)
- vlist-null)))
- (($ <lambda-case> src req opt rest kw inits gensyms body alt)
- (let*-values (((inits _) (parallel-visit inits db env 'value))
- ((body db*) (visit body db env ctx))
- ((alt _) (if alt
- (visit alt db env ctx)
- (values #f #f))))
- (return (make-lambda-case src req opt rest kw inits gensyms body alt)
- (if alt vlist-null db*))))
- (($ <sequence> src exps)
- (let lp ((in exps) (out '()) (db* vlist-null))
- (match in
- ((last)
- (let*-values (((last db**) (visit last (concat db* db) env ctx)))
- (if (null? out)
- (return last (concat db** db*))
- (return (make-sequence src (reverse (cons last out)))
- (concat db** db*)))))
- ((head . rest)
- (let*-values (((head db**) (visit head (concat db* db) env 'effect)))
- (cond
- ((sequence? head)
- (lp (append (sequence-exps head) rest) out db*))
- ((void? head)
- (lp rest out db*))
- (else
- (lp rest (cons head out) (concat db** db*)))))))))
- (($ <prompt> src tag body handler)
- (let*-values (((tag db*) (visit tag db env 'value))
- ((body _) (visit body (concat db* db) env ctx))
- ((handler _) (visit handler (concat db* db) env ctx)))
- (return (make-prompt src tag body handler)
- db*)))
- (($ <abort> src tag args tail)
- (let*-values (((tag db*) (visit tag db env 'value))
- ((args db**) (parallel-visit args db env 'value))
- ((tail db***) (visit tail db env 'value)))
- (return (make-abort src tag args tail)
- (concat db* (concat db** db***))))))))
(error "name should be symbol" exp))
(else
(visit exp env))))
- (($ <dynlet> src fluids vals body)
- (cond
- ((not (list? fluids))
- (error "fluids should be list" exp))
- ((not (list? vals))
- (error "vals should be list" exp))
- ((not (= (length fluids) (length vals)))
- (error "mismatch in fluids/vals" exp))
- (else
- (for-each (cut visit <> env) fluids)
- (for-each (cut visit <> env) vals)
- (visit body env))))
- (($ <dynwind> src winder body unwinder)
- (visit winder env)
- (visit body env)
- (visit unwinder env))
- (($ <dynref> src fluid)
- (visit fluid env))
- (($ <dynset> src fluid exp)
- (visit fluid env)
- (visit exp env))
(($ <conditional> src condition subsequent alternate)
(visit condition env)
(visit subsequent env)
(visit alternate env))
- (($ <application> src proc args)
+ (($ <primcall> src name args)
(cond
+ ((not (symbol? name))
+ (error "expected symbolic operator" exp))
((not (list? args))
(error "expected list of args" args))
(else
- (visit proc env)
(for-each (cut visit <> env) args))))
- (($ <sequence> src exps)
+ (($ <call> src proc args)
(cond
- ((not (list? exps))
- (error "expected list of exps" exp))
- ((null? exps)
- (error "expected more than one exp" exp))
+ ((not (list? args))
+ (error "expected list of args" args))
(else
- (for-each (cut visit <> env) exps))))
- (($ <prompt> src tag body handler)
+ (visit proc env)
+ (for-each (cut visit <> env) args))))
+ (($ <seq> src head tail)
+ (visit head env)
+ (visit tail env))
+ (($ <prompt> src escape-only? tag body handler)
+ (unless (boolean? escape-only?)
+ (error "escape-only? should be a bool" escape-only?))
(visit tag env)
(visit body env)
(visit handler env))
&possible-bailout
&zero-values
&allocation
- &mutable-data
&type-check
&all-effects
effects-commute?
;;; expression depends on the effect, and the other to indicate that an
;;; expression causes the effect.
;;;
+;;; Since we have more bits in a fixnum on 64-bit systems, we can be
+;;; more precise without losing efficiency. On a 32-bit system, some of
+;;; the more precise effects map to fewer bits.
+;;;
(define-syntax define-effects
(lambda (x)
...
(define-syntax all (identifier-syntax (logior name ...)))))))))
+(define-syntax compile-time-cond
+ (lambda (x)
+ (syntax-case x (else)
+ ((_ (else body ...))
+ #'(begin body ...))
+ ((_ (exp body ...) clause ...)
+ (if (eval (syntax->datum #'exp) (current-module))
+ #'(begin body ...)
+ #'(compile-time-cond clause ...))))))
+
;; Here we define the effects, indicating the meaning of the effect.
;;
;; Effects that are described in a "depends on" sense can also be used
;; analyzer will not associate the "depends-on" sense of these effects
;; with any expression.
;;
-(define-effects &all-effects
- ;; Indicates that an expression depends on the value of a mutable
- ;; lexical variable.
- &mutable-lexical
-
- ;; Indicates that an expression depends on the value of a toplevel
- ;; variable.
- &toplevel
-
- ;; Indicates that an expression depends on the value of a fluid
- ;; variable.
- &fluid
-
- ;; Indicates that an expression definitely causes a non-local,
- ;; non-resumable exit -- a bailout. Only used in the "changes" sense.
- &definite-bailout
-
- ;; Indicates that an expression may cause a bailout.
- &possible-bailout
-
- ;; Indicates than an expression may return zero values -- a "causes"
- ;; effect.
- &zero-values
-
- ;; Indicates that an expression may return a fresh object -- a
- ;; "causes" effect.
- &allocation
-
- ;; Indicates that an expression depends on the value of a mutable data
- ;; structure.
- &mutable-data
-
- ;; Indicates that an expression may cause a type check. A type check,
- ;; for the purposes of this analysis, is the possibility of throwing
- ;; an exception the first time an expression is evaluated. If the
- ;; expression did not cause an exception to be thrown, users can
- ;; assume that evaluating the expression again will not cause an
- ;; exception to be thrown.
- ;;
- ;; For example, (+ x y) might throw if X or Y are not numbers. But if
- ;; it doesn't throw, it should be safe to elide a dominated, common
- ;; subexpression (+ x y).
- &type-check)
+(compile-time-cond
+ ((>= (logcount most-positive-fixnum) 60)
+ (define-effects &all-effects
+ ;; Indicates that an expression depends on the value of a mutable
+ ;; lexical variable.
+ &mutable-lexical
+
+ ;; Indicates that an expression depends on the value of a toplevel
+ ;; variable.
+ &toplevel
+
+ ;; Indicates that an expression depends on the value of a fluid
+ ;; variable.
+ &fluid
+
+ ;; Indicates that an expression definitely causes a non-local,
+ ;; non-resumable exit -- a bailout. Only used in the "changes" sense.
+ &definite-bailout
+
+ ;; Indicates that an expression may cause a bailout.
+ &possible-bailout
+
+ ;; Indicates than an expression may return zero values -- a "causes"
+ ;; effect.
+ &zero-values
+
+ ;; Indicates that an expression may return a fresh object -- a
+ ;; "causes" effect.
+ &allocation
+
+ ;; Indicates that an expression depends on the value of the car of a
+ ;; pair.
+ &car
+
+ ;; Indicates that an expression depends on the value of the cdr of a
+ ;; pair.
+ &cdr
+
+ ;; Indicates that an expression depends on the value of a vector
+ ;; field. We cannot be more precise, as vectors may alias other
+ ;; vectors.
+ &vector
+
+ ;; Indicates that an expression depends on the value of a variable
+ ;; cell.
+ &variable
+
+ ;; Indicates that an expression depends on the value of a particular
+ ;; struct field.
+ &struct-0 &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+
+
+ ;; Indicates that an expression depends on the contents of a string.
+ &string
+
+ ;; Indicates that an expression depends on the contents of a
+ ;; bytevector. We cannot be more precise, as bytevectors may alias
+ ;; other bytevectors.
+ &bytevector
+
+ ;; Indicates that an expression may cause a type check. A type check,
+ ;; for the purposes of this analysis, is the possibility of throwing
+ ;; an exception the first time an expression is evaluated. If the
+ ;; expression did not cause an exception to be thrown, users can
+ ;; assume that evaluating the expression again will not cause an
+ ;; exception to be thrown.
+ ;;
+ ;; For example, (+ x y) might throw if X or Y are not numbers. But if
+ ;; it doesn't throw, it should be safe to elide a dominated, common
+ ;; subexpression (+ x y).
+ &type-check)
+
+ ;; Indicates that an expression depends on the contents of an unknown
+ ;; struct field.
+ (define-syntax &struct
+ (identifier-syntax
+ (logior &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+))))
+
+ (else
+ ;; For systems with smaller fixnums, be less precise regarding struct
+ ;; fields.
+ (define-effects &all-effects
+ &mutable-lexical
+ &toplevel
+ &fluid
+ &definite-bailout
+ &possible-bailout
+ &zero-values
+ &allocation
+ &car
+ &cdr
+ &vector
+ &variable
+ &struct
+ &string
+ &bytevector
+ &type-check)
+ (define-syntax &struct-0 (identifier-syntax &struct))
+ (define-syntax &struct-1 (identifier-syntax &struct))
+ (define-syntax &struct-2 (identifier-syntax &struct))
+ (define-syntax &struct-3 (identifier-syntax &struct))
+ (define-syntax &struct-4 (identifier-syntax &struct))
+ (define-syntax &struct-5 (identifier-syntax &struct))
+ (define-syntax &struct-6+ (identifier-syntax &struct))))
(define-syntax &no-effects (identifier-syntax 0))
(logior (compute-effects producer)
(compute-effects consumer)
(cause &type-check)))
- (($ <dynwind> _ winder body unwinder)
- (logior (compute-effects winder)
- (compute-effects body)
- (compute-effects unwinder)))
- (($ <dynlet> _ fluids vals body)
- (logior (accumulate-effects fluids)
- (accumulate-effects vals)
- (cause &type-check)
- (cause &fluid)
- (compute-effects body)))
- (($ <dynref> _ fluid)
- (logior (compute-effects fluid)
- (cause &type-check)
- &fluid))
- (($ <dynset> _ fluid exp)
- (logior (compute-effects fluid)
- (compute-effects exp)
- (cause &type-check)
- (cause &fluid)))
(($ <toplevel-ref>)
(logior &toplevel
(cause &type-check)))
&definite-bailout))))
;; Zero values.
- (($ <application> _ ($ <primitive-ref> _ 'values) ())
+ (($ <primcall> _ 'values ())
(cause &zero-values))
;; Effect-free primitives.
- (($ <application> _
- ($ <primitive-ref> _ (or 'values 'eq? 'eqv? 'equal?))
- args)
+ (($ <primcall> _ (or 'values 'eq? 'eqv? 'equal?) args)
(accumulate-effects args))
- (($ <application> _
- ($ <primitive-ref> _ (or 'not 'pair? 'null? 'list? 'symbol?
- 'vector? 'struct? 'string? 'number?
- 'char?))
+ (($ <primcall> _ (or 'not 'pair? 'null? 'list? 'symbol?
+ 'vector? 'struct? 'string? 'number?
+ 'char?)
(arg))
(compute-effects arg))
;; Primitives that allocate memory.
- (($ <application> _ ($ <primitive-ref> _ 'cons) (x y))
+ (($ <primcall> _ 'cons (x y))
(logior (compute-effects x) (compute-effects y)
&allocation))
- (($ <application> _ ($ <primitive-ref> _ (or 'list 'vector)) args)
+ (($ <primcall> _ (or 'list 'vector) args)
(logior (accumulate-effects args) &allocation))
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ())
+ (($ <primcall> _ 'make-prompt-tag ())
&allocation)
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) (arg))
+ (($ <primcall> _ 'make-prompt-tag (arg))
(logior (compute-effects arg) &allocation))
+ (($ <primcall> _ 'fluid-ref (fluid))
+ (logior (compute-effects fluid)
+ (cause &type-check)
+ &fluid))
+
+ (($ <primcall> _ 'fluid-set! (fluid exp))
+ (logior (compute-effects fluid)
+ (compute-effects exp)
+ (cause &type-check)
+ (cause &fluid)))
+
+ (($ <primcall> _ 'push-fluid (fluid val))
+ (logior (compute-effects fluid)
+ (compute-effects val)
+ (cause &type-check)
+ (cause &fluid)))
+
+ (($ <primcall> _ 'pop-fluid ())
+ (logior (cause &fluid)))
+
+ (($ <primcall> _ 'car (x))
+ (logior (compute-effects x)
+ (cause &type-check)
+ &car))
+ (($ <primcall> _ 'set-car! (x y))
+ (logior (compute-effects x)
+ (compute-effects y)
+ (cause &type-check)
+ (cause &car)))
+
+ (($ <primcall> _ 'cdr (x))
+ (logior (compute-effects x)
+ (cause &type-check)
+ &cdr))
+ (($ <primcall> _ 'set-cdr! (x y))
+ (logior (compute-effects x)
+ (compute-effects y)
+ (cause &type-check)
+ (cause &cdr)))
+
+ (($ <primcall> _ (or 'memq 'memv) (x y))
+ (logior (compute-effects x)
+ (compute-effects y)
+ (cause &type-check)
+ &car &cdr))
+
+ (($ <primcall> _ 'vector-ref (v n))
+ (logior (compute-effects v)
+ (compute-effects n)
+ (cause &type-check)
+ &vector))
+ (($ <primcall> _ 'vector-set! (v n x))
+ (logior (compute-effects v)
+ (compute-effects n)
+ (compute-effects x)
+ (cause &type-check)
+ (cause &vector)))
+
+ (($ <primcall> _ 'variable-ref (v))
+ (logior (compute-effects v)
+ (cause &type-check)
+ &variable))
+ (($ <primcall> _ 'variable-set! (v x))
+ (logior (compute-effects v)
+ (compute-effects x)
+ (cause &type-check)
+ (cause &variable)))
+
+ (($ <primcall> _ 'struct-ref (s n))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (cause &type-check)
+ (match n
+ (($ <const> _ 0) &struct-0)
+ (($ <const> _ 1) &struct-1)
+ (($ <const> _ 2) &struct-2)
+ (($ <const> _ 3) &struct-3)
+ (($ <const> _ 4) &struct-4)
+ (($ <const> _ 5) &struct-5)
+ (($ <const> _ _) &struct-6+)
+ (_ &struct))))
+ (($ <primcall> _ 'struct-set! (s n x))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (compute-effects x)
+ (cause &type-check)
+ (match n
+ (($ <const> _ 0) (cause &struct-0))
+ (($ <const> _ 1) (cause &struct-1))
+ (($ <const> _ 2) (cause &struct-2))
+ (($ <const> _ 3) (cause &struct-3))
+ (($ <const> _ 4) (cause &struct-4))
+ (($ <const> _ 5) (cause &struct-5))
+ (($ <const> _ _) (cause &struct-6+))
+ (_ (cause &struct)))))
+
+ (($ <primcall> _ 'string-ref (s n))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (cause &type-check)
+ &string))
+ (($ <primcall> _ 'string-set! (s n c))
+ (logior (compute-effects s)
+ (compute-effects n)
+ (compute-effects c)
+ (cause &type-check)
+ (cause &string)))
+
+ (($ <primcall> _
+ (or 'bytevector-u8-ref 'bytevector-s8-ref
+ 'bytevector-u16-ref 'bytevector-u16-native-ref
+ 'bytevector-s16-ref 'bytevector-s16-native-ref
+ 'bytevector-u32-ref 'bytevector-u32-native-ref
+ 'bytevector-s32-ref 'bytevector-s32-native-ref
+ 'bytevector-u64-ref 'bytevector-u64-native-ref
+ 'bytevector-s64-ref 'bytevector-s64-native-ref
+ 'bytevector-ieee-single-ref 'bytevector-ieee-single-native-ref
+ 'bytevector-ieee-double-ref 'bytevector-ieee-double-native-ref)
+ (bv n))
+ (logior (compute-effects bv)
+ (compute-effects n)
+ (cause &type-check)
+ &bytevector))
+ (($ <primcall> _
+ (or 'bytevector-u8-set! 'bytevector-s8-set!
+ 'bytevector-u16-set! 'bytevector-u16-native-set!
+ 'bytevector-s16-set! 'bytevector-s16-native-set!
+ 'bytevector-u32-set! 'bytevector-u32-native-set!
+ 'bytevector-s32-set! 'bytevector-s32-native-set!
+ 'bytevector-u64-set! 'bytevector-u64-native-set!
+ 'bytevector-s64-set! 'bytevector-s64-native-set!
+ 'bytevector-ieee-single-set! 'bytevector-ieee-single-native-set!
+ 'bytevector-ieee-double-set! 'bytevector-ieee-double-native-set!)
+ (bv n x))
+ (logior (compute-effects bv)
+ (compute-effects n)
+ (compute-effects x)
+ (cause &type-check)
+ (cause &bytevector)))
+
;; Primitives that are normally effect-free, but which might
- ;; cause type checks, allocate memory, or access mutable
- ;; memory. FIXME: expand, to be more precise.
- (($ <application> _
- ($ <primitive-ref> _ (and name
- (? effect-free-primitive?)))
- args)
+ ;; cause type checks or allocate memory. Nota bene,
+ ;; primitives that access mutable memory should be given their
+ ;; own inline cases above!
+ (($ <primcall> _ (and name (? effect-free-primitive?)) args)
(logior (accumulate-effects args)
(cause &type-check)
(if (constructor-primitive? name)
(cause &allocation)
- (if (accessor-primitive? name)
- &mutable-data
- &no-effects))))
+ &no-effects)))
;; Lambda applications might throw wrong-number-of-args.
- (($ <application> _ ($ <lambda> _ _ body) args)
+ (($ <call> _ ($ <lambda> _ _ body) args)
(logior (accumulate-effects args)
(match body
(($ <lambda-case> _ req #f #f #f () syms body #f)
(cause &possible-bailout))))))
;; Bailout primitives.
- (($ <application> src ($ <primitive-ref> _ (? bailout-primitive? name))
- args)
+ (($ <primcall> _ (? bailout-primitive? name) args)
(logior (accumulate-effects args)
(cause &definite-bailout)
(cause &possible-bailout)))
+ (($ <call> _
+ (and proc
+ ($ <module-ref> _ mod name public?)
+ (? (lambda (_)
+ (false-if-exception
+ (procedure-property
+ (module-ref (if public?
+ (resolve-interface mod)
+ (resolve-module mod))
+ name)
+ 'definite-bailout?)))))
+ args)
+ (logior (compute-effects proc)
+ (accumulate-effects args)
+ (cause &definite-bailout)
+ (cause &possible-bailout)))
;; A call to a lexically bound procedure, perhaps labels
;; allocated.
- (($ <application> _ (and proc ($ <lexical-ref> _ _ sym)) args)
+ (($ <call> _ (and proc ($ <lexical-ref> _ _ sym)) args)
(cond
((lookup sym)
=> (lambda (proc)
- (compute-effects (make-application #f proc args))))
+ (compute-effects (make-call #f proc args))))
(else
(logior &all-effects-but-bailout
(cause &all-effects-but-bailout)))))
;; A call to an unknown procedure can do anything.
- (($ <application> _ proc args)
+ (($ <primcall> _ name args)
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))
+ (($ <call> _ proc args)
(logior &all-effects-but-bailout
(cause &all-effects-but-bailout)))
(compute-effects body)
(if alt (compute-effects alt) &no-effects)))
- (($ <sequence> _ exps)
- (let lp ((exps exps) (effects &no-effects))
- (match exps
- ((tail)
- (logior (compute-effects tail)
- ;; Returning zero values to a for-effect continuation is
- ;; not observable.
- (exclude-effects effects (cause &zero-values))))
- ((head . tail)
- (lp tail (logior (compute-effects head) effects))))))
-
- (($ <prompt> _ tag body handler)
+ (($ <seq> _ head tail)
+ (logior
+ ;; Returning zero values to a for-effect continuation is
+ ;; not observable.
+ (exclude-effects (compute-effects head)
+ (cause &zero-values))
+ (compute-effects tail)))
+
+ (($ <prompt> _ escape-only? tag body handler)
(logior (compute-effects tag)
(compute-effects body)
(compute-effects handler)))
;;; transformation of letrec into simpler forms
-;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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-11)
#:use-module (language tree-il)
#:use-module (language tree-il effects)
- #:export (fix-letrec!))
+ #:export (fix-letrec))
;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
;; Efficient Implementation of Scheme's Recursive Binding Construct", by
(and (simple-expression? test bound-vars simple-primcall?)
(simple-expression? consequent bound-vars simple-primcall?)
(simple-expression? alternate bound-vars simple-primcall?)))
- ((<sequence> exps)
- (and-map (lambda (x) (simple-expression? x bound-vars simple-primcall?))
- exps))
- ((<application> proc args)
- (and (primitive-ref? proc)
- (simple-primcall? x)
+ ((<seq> head tail)
+ (and (simple-expression? head bound-vars simple-primcall?)
+ (simple-expression? tail bound-vars simple-primcall?)))
+ ((<primcall> name args)
+ (and (simple-primcall? x)
(and-map (lambda (x)
(simple-expression? x bound-vars simple-primcall?))
args)))
'())))
(values unref simple lambda* complex)))
-(define (make-sequence* src exps)
- (let lp ((in exps) (out '()))
- (if (null? (cdr in))
- (if (null? out)
- (car in)
- (make-sequence src (reverse (cons (car in) out))))
- (let ((head (car in)))
- (record-case head
- ((<lambda>) (lp (cdr in) out))
- ((<const>) (lp (cdr in) out))
- ((<lexical-ref>) (lp (cdr in) out))
- ((<void>) (lp (cdr in) out))
- (else (lp (cdr in) (cons head out))))))))
+(define (make-seq* src head tail)
+ (record-case head
+ ((<lambda>) tail)
+ ((<const>) tail)
+ ((<lexical-ref>) tail)
+ ((<void>) tail)
+ (else (make-seq src head tail))))
-(define (fix-letrec! x)
+(define (list->seq* loc exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (let lp ((exps (cdr exps)) (effects (list (car exps))))
+ (if (null? (cdr exps))
+ (make-seq* loc
+ (fold (lambda (exp tail) (make-seq* #f exp tail))
+ (car effects)
+ (cdr effects))
+ (car exps))
+ (lp (cdr exps) (cons (car exps) effects))))))
+
+(define (fix-letrec x)
(let-values (((unref simple lambda* complex) (partition-vars x)))
- (post-order!
+ (post-order
(lambda (x)
(record-case x
;; expression, called for effect.
((<lexical-set> gensym exp)
(if (memq gensym unref)
- (make-sequence* #f (list exp (make-void #f)))
+ (make-seq* #f exp (make-void #f))
x))
((<letrec> src in-order? names gensyms vals body)
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
- (make-sequence*
+ (list->seq*
src
(append
;; The right-hand-sides of the unreferenced
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
- (make-sequence
+ (list->seq
#f
(map (lambda (x tmp)
(make-lexical-set
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
- (make-sequence*
+ (list->seq*
src
(append
;; unreferenced bindings, called for effect.
;;; Tree-il optimizer
-;; Copyright (C) 2009, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011, 2012, 2013, 2014 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 (language tree-il)
#:use-module (language tree-il primitives)
#:use-module (language tree-il peval)
- #:use-module (language tree-il cse)
#:use-module (language tree-il fix-letrec)
#:use-module (language tree-il debug)
#:use-module (ice-9 match)
- #:export (optimize!))
+ #:export (optimize))
-(define (optimize! x env opts)
+(define (optimize x env opts)
(let ((peval (match (memq #:partial-eval? opts)
((#:partial-eval? #f _ ...)
;; Disable partial evaluation.
(lambda (x e) x))
- (_ peval)))
- (cse (match (memq #:cse? opts)
- ((#:cse? #f _ ...)
- ;; Disable CSE.
- (lambda (x) x))
- (_ cse))))
- (fix-letrec!
+ (_ peval))))
+ (fix-letrec
(verify-tree-il
- (cse
- (verify-tree-il
- (peval (expand-primitives! (resolve-primitives! x env))
- env)))))))
+ (peval (expand-primitives (resolve-primitives x env))
+ env)))))
(tree-il-fold (lambda (exp res)
(let ((res (proc exp)))
(if res (k res) #f)))
- (lambda (exp res)
- (let ((res (proc exp)))
- (if res (k res) #f)))
(lambda (exp res) #f)
#f exp)))
(($ <primitive-ref>) #t)
(($ <module-ref>) #t)
(($ <toplevel-ref>) #t)
- (($ <application> _
- ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
- (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+ (($ <primcall> _ (? singly-valued-primitive?)) #t)
+ (($ <primcall> _ 'values (val)) #t)
(($ <lambda>) #t)
+ (($ <conditional> _ test consequent alternate)
+ (and (singly-valued-expression? consequent)
+ (singly-valued-expression? alternate)))
(else #f)))
(define (truncate-values x)
"Discard all but the first value of X."
(if (singly-valued-expression? x)
x
- (make-application (tree-il-src x)
- (make-primitive-ref #f 'values)
- (list x))))
+ (make-primcall (tree-il-src x) 'values (list x))))
;; Peval will do a one-pass analysis on the source program to determine
;; the set of assigned lexicals, and to identify unreferenced and
(let ((var (cdr (vhash-assq gensym res))))
(set-var-refcount! var (1+ (var-refcount var)))
res))
- (_ res)))
- (lambda (exp res)
- (match exp
(($ <lambda-case> src req opt rest kw init gensyms body alt)
(fold (lambda (name sym res)
(vhash-consq sym (make-var name sym 0 #f) res))
(%set-operand-residual-value!
op
(match val
- (($ <application> src ($ <primitive-ref> _ 'values) (first))
+ (($ <primcall> src 'values (first))
;; The continuation of a residualized binding does not need the
;; introduced `values' node, so undo the effects of truncation.
first)
(define local-toplevel-env
;; The top-level environment of the module being compiled.
- (match exp
- (($ <toplevel-define> _ name)
- (vhash-consq name #t env))
- (($ <sequence> _ exps)
- (fold (lambda (x r)
- (match x
- (($ <toplevel-define> _ name)
- (vhash-consq name #t r))
- (_ r)))
- env
- exps))
- (_ env)))
+ (let ()
+ (define (env-folder x env)
+ (match x
+ (($ <toplevel-define> _ name)
+ (vhash-consq name #t env))
+ (($ <seq> _ head tail)
+ (env-folder tail (env-folder head env)))
+ (_ env)))
+ (env-folder exp vlist-null)))
(define (local-toplevel? name)
(vhash-assq name local-toplevel-env))
(define (lexical-refcount sym)
(var-refcount (lookup-var sym)))
+ (define (with-temporaries src exps refcount can-copy? k)
+ (let* ((pairs (map (match-lambda
+ ((and exp (? can-copy?))
+ (cons #f exp))
+ (exp
+ (let ((sym (gensym "tmp ")))
+ (record-new-temporary! 'tmp sym refcount)
+ (cons sym exp))))
+ exps))
+ (tmps (filter car pairs)))
+ (match tmps
+ (() (k exps))
+ (tmps
+ (make-let src
+ (make-list (length tmps) 'tmp)
+ (map car tmps)
+ (map cdr tmps)
+ (k (map (match-lambda
+ ((#f . val) val)
+ ((sym . _)
+ (make-lexical-ref #f 'tmp sym)))
+ pairs)))))))
+
+ (define (make-begin0 src first second)
+ (make-let-values
+ src
+ first
+ (let ((vals (gensym "vals ")))
+ (record-new-temporary! 'vals vals 1)
+ (make-lambda-case
+ #f
+ '() #f 'vals #f '() (list vals)
+ (make-seq
+ src
+ second
+ (make-primcall #f 'apply
+ (list
+ (make-primitive-ref #f 'values)
+ (make-lexical-ref #f 'vals vals))))
+ #f))))
+
;; ORIG has been alpha-renamed to NEW. Analyze NEW and record a link
;; from it to ORIG.
;;
(values #t results))))
(lambda _
(values #f '()))))
-
(define (make-values src values)
(match values
((single) single) ; 1 value
((_ ...) ; 0, or 2 or more values
- (make-application src (make-primitive-ref src 'values)
- values))))
+ (make-primcall src 'values values))))
(define (residualize-call)
- (make-application src (make-primitive-ref #f name) args))
+ (make-primcall src name args))
(cond
((every const? args)
(let-values (((success? values)
($ <toplevel-ref>)
($ <module-ref>)
($ <primitive-ref>)
- ($ <dynref>)
($ <lexical-set>) ; FIXME: these set! expressions
($ <toplevel-set>) ; could return zero values in
($ <toplevel-define>) ; the future
($ <module-set>) ;
- ($ <dynset>) ;
- ($ <application> src
- ($ <primitive-ref> _ (? singly-valued-primitive?))))
+ ($ <primcall> src (? singly-valued-primitive?)))
(and (<= nmin 1) (or (not nmax) (>= nmax 1))
- (make-application src (make-lambda #f '() consumer) (list exp))))
+ (make-call src (make-lambda #f '() consumer) (list exp))))
;; Statically-known number of values.
- (($ <application> src ($ <primitive-ref> _ 'values) vals)
+ (($ <primcall> src 'values vals)
(and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals)))
- (make-application src (make-lambda #f '() consumer) vals)))
+ (make-call src (make-lambda #f '() consumer) vals)))
;; Not going to copy code into both branches.
(($ <conditional>) #f)
;; Bail on other applications.
- (($ <application>) #f)
+ (($ <call>) #f)
+ (($ <primcall>) #f)
;; Bail on prompt and abort.
(($ <prompt>) #f)
(make-let-values src exp
(make-lambda-case src2 req opt rest kw
inits gensyms body #f)))))
- (($ <dynwind> src winder body unwinder)
- (let ((body (loop body)))
- (and body
- (make-dynwind src winder body unwinder))))
- (($ <dynlet> src fluids vals body)
- (let ((body (loop body)))
- (and body
- (make-dynlet src fluids vals body))))
- (($ <sequence> src exps)
- (match exps
- ((head ... tail)
- (let ((tail (loop tail)))
- (and tail
- (make-sequence src (append head (list tail)))))))))))
+ (($ <seq> src head tail)
+ (let ((tail (loop tail)))
+ (and tail (make-seq src head tail)))))))
(define compute-effects
(make-effects-analyzer assigned-lexical?))
(if (null? effects)
body
(let ((effect-vals (map operand-residual-value effects)))
- (make-sequence #f (reverse (cons body effect-vals)))))))
+ (list->seq #f (reverse (cons body effect-vals)))))))
(if (null? values)
body
(let ((values (reverse values)))
(define (small-expression? x limit)
(let/ec k
(tree-il-fold
- (lambda (x res) ; leaf
- (1+ res))
(lambda (x res) ; down
(1+ res))
(lambda (x res) ; up
(let ((exp (for-effect exp)))
(if (void? exp)
exp
- (make-sequence src (list exp (make-void #f)))))
+ (make-seq src exp (make-void #f))))
(begin
(record-operand-use op)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
(($ <let> src
(names ... rest)
(gensyms ... rest-sym)
- (vals ... ($ <application> _ ($ <primitive-ref> _ 'list) rest-args))
- ($ <application> asrc
- ($ <primitive-ref> _ (or 'apply '@apply))
+ (vals ... ($ <primcall> _ 'list rest-args))
+ ($ <primcall> asrc 'apply
(proc args ...
($ <lexical-ref> _
(? (cut eq? <> rest))
(append names tmps)
(append gensyms tmp-syms)
(append vals rest-args)
- (make-application
+ (make-call
asrc
proc
(append args
(body (loop body env counter ctx)))
(cond
((const? body)
- (for-tail (make-sequence src (append vals (list body)))))
+ (for-tail (list->seq src (append vals (list body)))))
((and (lexical-ref? body)
(memq (lexical-ref-gensym body) new))
(let ((sym (lexical-ref-gensym body))
(pairs (map cons new vals)))
;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
(for-tail
- (make-sequence
+ (list->seq
src
(append (map cdr (alist-delete sym pairs eq?))
(list (assq-ref pairs sym)))))))
;; reconstruct the let-values, pevaling the consumer.
(let ((producer (for-values producer)))
(or (match consumer
+ (($ <lambda-case> src (req-name) #f #f #f () (req-sym) body #f)
+ (for-tail
+ (make-let src (list req-name) (list req-sym) (list producer)
+ body)))
+ ((and ($ <lambda-case> src () #f rest #f () (rest-sym) body #f)
+ (? (lambda _ (singly-valued-expression? producer))))
+ (let ((tmp (gensym "tmp ")))
+ (record-new-temporary! 'tmp tmp 1)
+ (for-tail
+ (make-let
+ src (list 'tmp) (list tmp) (list producer)
+ (make-let
+ src (list rest) (list rest-sym)
+ (list
+ (make-primcall #f 'list
+ (list (make-lexical-ref #f 'tmp tmp))))
+ body)))))
(($ <lambda-case> src req opt rest #f inits gensyms body #f)
(let* ((nmin (length req))
(nmax (and (not rest) (+ nmin (if opt (length opt) 0)))))
(else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynwind> src winder body unwinder)
- (let ((pre (for-value winder))
- (body (for-tail body))
- (post (for-value unwinder)))
- (cond
- ((not (constant-expression? pre))
- (cond
- ((not (constant-expression? post))
- (let ((pre-sym (gensym "pre-")) (post-sym (gensym "post-")))
- (record-new-temporary! 'pre pre-sym 1)
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(pre post) (list pre-sym post-sym) (list pre post)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (let ((pre-sym (gensym "pre-")))
- (record-new-temporary! 'pre pre-sym 1)
- (make-let src '(pre) (list pre-sym) (list pre)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- post))))))
- ((not (constant-expression? post))
- (let ((post-sym (gensym "post-")))
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(post) (list post-sym) (list post)
- (make-dynwind src
- pre
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (make-dynwind src pre body post)))))
- (($ <dynlet> src fluids vals body)
- (make-dynlet src (map for-value fluids) (map for-value vals)
- (for-tail body)))
- (($ <dynref> src fluid)
- (make-dynref src (for-value fluid)))
- (($ <dynset> src fluid exp)
- (make-dynset src (for-value fluid) (for-value exp)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
- (if (local-toplevel? name)
- exp
- (let ((exp (resolve-primitives! exp cenv)))
- (if (primitive-ref? exp)
- (for-tail exp)
- exp))))
+ exp)
(($ <toplevel-ref>)
;; todo: open private local bindings.
exp)
(($ <conditional> src condition subsequent alternate)
(define (call-with-failure-thunk exp proc)
(match exp
- (($ <application> _ _ ()) (proc exp))
+ (($ <call> _ _ ()) (proc exp))
+ (($ <primcall> _ _ ()) (proc exp))
(($ <const>) (proc exp))
(($ <void>) (proc exp))
(($ <lexical-ref>) (proc exp))
(make-lambda
#f '()
(make-lambda-case #f '() #f #f #f '() '() exp #f)))
- (proc (make-application #f (make-lexical-ref #f 'failure t)
- '())))))))
+ (proc (make-call #f (make-lexical-ref #f 'failure t)
+ '())))))))
(define (simplify-conditional c)
(match c
;; Swap the arms of (if (not FOO) A B), to simplify.
- (($ <conditional> src
- ($ <application> _ ($ <primitive-ref> _ 'not) (pred))
+ (($ <conditional> src ($ <primcall> _ 'not (pred))
subsequent alternate)
(simplify-conditional
(make-conditional src pred alternate subsequent)))
(simplify-conditional
(make-conditional src c (for-tail subsequent)
(for-tail alternate))))))
- (($ <application> src
- ($ <primitive-ref> _ '@call-with-values)
+ (($ <primcall> src 'call-with-values
(producer
($ <lambda> _ _
(and consumer
;; No optional or kwargs.
($ <lambda-case>
_ req #f rest #f () gensyms body #f)))))
- (for-tail (make-let-values src (make-application src producer '())
+ (for-tail (make-let-values src (make-call src producer '())
consumer)))
- (($ <application> src ($ <primitive-ref> _ 'values) exps)
+ (($ <primcall> src 'dynamic-wind (w thunk u))
+ (for-tail
+ (with-temporaries
+ src (list w u) 2 constant-expression?
+ (match-lambda
+ ((w u)
+ (make-seq
+ src
+ (make-seq
+ src
+ (make-conditional
+ src
+ ;; fixme: introduce logic to fold thunk?
+ (make-primcall src 'thunk? (list u))
+ (make-call src w '())
+ (make-primcall
+ src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "dynamic-wind")
+ (make-const #f "Wrong type (expecting thunk): ~S")
+ (make-primcall #f 'list (list u))
+ (make-primcall #f 'list (list u)))))
+ (make-primcall src 'wind (list w u)))
+ (make-begin0 src
+ (make-call src thunk '())
+ (make-seq src
+ (make-primcall src 'unwind '())
+ (make-call src u '())))))))))
+
+ (($ <primcall> src 'with-fluid* (f v thunk))
+ (for-tail
+ (with-temporaries
+ src (list f v thunk) 1 constant-expression?
+ (match-lambda
+ ((f v thunk)
+ (make-seq src
+ (make-primcall src 'push-fluid (list f v))
+ (make-begin0 src
+ (make-call src thunk '())
+ (make-primcall src 'pop-fluid '()))))))))
+
+ (($ <primcall> src 'values exps)
(cond
((null? exps)
(if (eq? ctx 'effect)
((value test effect) #t)
(else (null? (cdr vals))))
(every singly-valued-expression? vals))
- (for-tail (make-sequence src (append (cdr vals) (list (car vals)))))
- (make-application src (make-primitive-ref #f 'values) vals))))))
- (($ <application> src (and apply ($ <primitive-ref> _ (or 'apply '@apply)))
- (proc args ... tail))
+ (for-tail (list->seq src (append (cdr vals) (list (car vals)))))
+ (make-primcall src 'values vals))))))
+
+ (($ <primcall> src 'apply (proc args ... tail))
(let lp ((tail* (find-definition tail 1)) (speculative? #t))
(define (copyable? x)
;; Inlining a result from find-definition effectively copies it,
(match tail*
(($ <const> _ (args* ...))
(let ((args* (map (cut make-const #f <>) args*)))
- (for-tail (make-application src proc (append args args*)))))
- (($ <application> _ ($ <primitive-ref> _ 'cons)
+ (for-tail (make-call src proc (append args args*)))))
+ (($ <primcall> _ 'cons
((and head (? copyable?)) (and tail (? copyable?))))
- (for-tail (make-application src apply
- (cons proc
- (append args (list head tail))))))
- (($ <application> _ ($ <primitive-ref> _ 'list)
+ (for-tail (make-primcall src 'apply
+ (cons proc
+ (append args (list head tail))))))
+ (($ <primcall> _ 'list
(and args* ((? copyable?) ...)))
- (for-tail (make-application src proc (append args args*))))
+ (for-tail (make-call src proc (append args args*))))
(tail*
(if speculative?
(lp (for-value tail) #f)
(let ((args (append (map for-value args) (list tail*))))
- (make-application src apply
- (cons (for-value proc) args))))))))
- (($ <application> src orig-proc orig-args)
+ (make-primcall src 'apply
+ (cons (for-value proc) args))))))))
+
+ (($ <primcall> src (? constructor-primitive? name) args)
+ (cond
+ ((and (memq ctx '(effect test))
+ (match (cons name args)
+ ((or ('cons _ _)
+ ('list . _)
+ ('vector . _)
+ ('make-prompt-tag)
+ ('make-prompt-tag ($ <const> _ (? string?))))
+ #t)
+ (_ #f)))
+ ;; Some expressions can be folded without visiting the
+ ;; arguments for value.
+ (let ((res (if (eq? ctx 'effect)
+ (make-void #f)
+ (make-const #f #t))))
+ (for-tail (list->seq src (append args (list res))))))
+ (else
+ (match (cons name (map for-value args))
+ (('cons x ($ <const> _ (? (cut eq? <> '()))))
+ (make-primcall src 'list (list x)))
+ (('cons x ($ <primcall> _ 'list elts))
+ (make-primcall src 'list (cons x elts)))
+ (('list)
+ (make-const src '()))
+ (('vector)
+ (make-const src '#()))
+ ((name . args)
+ (make-primcall src name args))))))
+
+ (($ <primcall> src 'thunk? (proc))
+ (case ctx
+ ((effect)
+ (for-tail (make-seq src proc (make-void src))))
+ (else
+ (match (for-value proc)
+ (($ <lambda> _ _ ($ <lambda-case> _ req))
+ (for-tail (make-const src (null? req))))
+ (proc
+ (match (find-definition proc 2)
+ (($ <lambda> _ _ ($ <lambda-case> _ req))
+ (for-tail (make-const src (null? req))))
+ (_
+ (make-primcall src 'thunk? (list proc)))))))))
+
+ (($ <primcall> src name args)
+ (match (cons name (map for-value args))
+ ;; FIXME: these for-tail recursions could take place outside
+ ;; an effort counter.
+ (('car ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src tail head)))
+ (('cdr ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src head tail)))
+ (('car ($ <primcall> src 'list (head . tail)))
+ (for-tail (list->seq src (append tail (list head)))))
+ (('cdr ($ <primcall> src 'list (head . tail)))
+ (for-tail (make-seq src head (make-primcall #f 'list tail))))
+
+ (('car ($ <const> src (head . tail)))
+ (for-tail (make-const src head)))
+ (('cdr ($ <const> src (head . tail)))
+ (for-tail (make-const src tail)))
+ (((or 'memq 'memv) k ($ <const> _ (elts ...)))
+ ;; FIXME: factor
+ (case ctx
+ ((effect)
+ (for-tail
+ (make-seq src k (make-void #f))))
+ ((test)
+ (cond
+ ((const? k)
+ ;; A shortcut. The `else' case would handle it, but
+ ;; this way is faster.
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (and (member (const-exp k) elts) #t))))
+ ((null? elts)
+ (for-tail
+ (make-seq src k (make-const #f #f))))
+ (else
+ (let ((t (gensym "t "))
+ (eq (if (eq? name 'memq) 'eq? 'eqv?)))
+ (record-new-temporary! 't t (length elts))
+ (for-tail
+ (make-let
+ src (list 't) (list t) (list k)
+ (let lp ((elts elts))
+ (define test
+ (make-primcall #f eq
+ (list (make-lexical-ref #f 't t)
+ (make-const #f (car elts)))))
+ (if (null? (cdr elts))
+ test
+ (make-conditional src test
+ (make-const #f #t)
+ (lp (cdr elts)))))))))))
+ (else
+ (cond
+ ((const? k)
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (member (const-exp k) elts))))
+ ((null? elts)
+ (for-tail (make-seq src k (make-const #f #f))))
+ (else
+ (make-primcall src name (list k (make-const #f elts))))))))
+ (((? equality-primitive?)
+ ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym))
+ (for-tail (make-const #f #t)))
+
+ (('= ($ <primcall> src2 'logand (a b)) ($ <const> _ 0))
+ (let ((src (or src src2)))
+ (make-primcall src 'not
+ (list (make-primcall src 'logtest (list a b))))))
+
+ (('logbit? ($ <const> src2
+ (? (lambda (bit)
+ (and (exact-integer? bit) (not (negative? bit))))
+ bit))
+ val)
+ (fold-constants src 'logtest
+ (list (make-const (or src2 src) (ash 1 bit)) val)
+ ctx))
+
+ (((? effect-free-primitive?) . args)
+ (fold-constants src name args ctx))
+
+ ((name . args)
+ (make-primcall src name args))))
+
+ (($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
(let revisit-proc ((proc (visit orig-proc 'operator)))
(match proc
- (($ <primitive-ref> _ (? constructor-primitive? name))
- (cond
- ((and (memq ctx '(effect test))
- (match (cons name orig-args)
- ((or ('cons _ _)
- ('list . _)
- ('vector . _)
- ('make-prompt-tag)
- ('make-prompt-tag ($ <const> _ (? string?))))
- #t)
- (_ #f)))
- ;; Some expressions can be folded without visiting the
- ;; arguments for value.
- (let ((res (if (eq? ctx 'effect)
- (make-void #f)
- (make-const #f #t))))
- (for-tail (make-sequence src (append orig-args (list res))))))
- (else
- (match (cons name (map for-value orig-args))
- (('cons head tail)
- (match tail
- (($ <const> src (? (cut eq? <> '())))
- (make-application src (make-primitive-ref #f 'list)
- (list head)))
- (($ <application> src ($ <primitive-ref> _ 'list) elts)
- (make-application src (make-primitive-ref #f 'list)
- (cons head elts)))
- (_ (make-application src proc (list head tail)))))
- ((_ . args)
- (make-application src proc args))))))
- (($ <primitive-ref> _ (? accessor-primitive? name))
- (match (cons name (map for-value orig-args))
- ;; FIXME: these for-tail recursions could take place outside
- ;; an effort counter.
- (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list tail head))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list head tail))))
- (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence src (append tail (list head)))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence
- src
- (list head
- (make-application
- src (make-primitive-ref #f 'list) tail)))))
-
- (('car ($ <const> src (head . tail)))
- (for-tail (make-const src head)))
- (('cdr ($ <const> src (head . tail)))
- (for-tail (make-const src tail)))
- (((or 'memq 'memv) k ($ <const> _ (elts ...)))
- ;; FIXME: factor
- (case ctx
- ((effect)
- (for-tail
- (make-sequence src (list k (make-void #f)))))
- ((test)
- (cond
- ((const? k)
- ;; A shortcut. The `else' case would handle it, but
- ;; this way is faster.
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (and (member (const-exp k) elts) #t))))
- ((null? elts)
- (for-tail
- (make-sequence src (list k (make-const #f #f)))))
- (else
- (let ((t (gensym "t-"))
- (eq (if (eq? name 'memq) 'eq? 'eqv?)))
- (record-new-temporary! 't t (length elts))
- (for-tail
- (make-let
- src (list 't) (list t) (list k)
- (let lp ((elts elts))
- (define test
- (make-application
- #f (make-primitive-ref #f eq)
- (list (make-lexical-ref #f 't t)
- (make-const #f (car elts)))))
- (if (null? (cdr elts))
- test
- (make-conditional src test
- (make-const #f #t)
- (lp (cdr elts)))))))))))
- (else
- (cond
- ((const? k)
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (member (const-exp k) elts))))
- ((null? elts)
- (for-tail (make-sequence src (list k (make-const #f #f)))))
- (else
- (make-application src proc (list k (make-const #f elts))))))))
- ((_ . args)
- (or (fold-constants src name args ctx)
- (make-application src proc args)))))
- (($ <primitive-ref> _ (? effect-free-primitive? name))
- (let ((args (map for-value orig-args)))
- (or (fold-constants src name args ctx)
- (make-application src proc args))))
+ (($ <primitive-ref> _ name)
+ (for-tail (make-primcall src name orig-args)))
(($ <lambda> _ _
($ <lambda-case> _ req opt rest #f inits gensyms body #f))
;; Simple case: no keyword arguments.
;; todo: handle the more complex cases
(let* ((nargs (length orig-args))
(nreq (length req))
- (nopt (if opt (length opt) 0))
+ (opt (or opt '()))
+ (rest (if rest (list rest) '()))
+ (nopt (length opt))
(key (source-expression proc)))
- (define (inlined-application)
- (cond
- ((= nargs (+ nreq nopt))
- (make-let src
- (append req
- (or opt '())
- (if rest (list rest) '()))
- gensyms
- (append orig-args
- (if rest
- (list (make-const #f '()))
- '()))
- body))
- ((> nargs (+ nreq nopt))
- (make-let src
- (append req
- (or opt '())
- (list rest))
- gensyms
- (append (take orig-args (+ nreq nopt))
- (list (make-application
- #f
- (make-primitive-ref #f 'list)
- (drop orig-args (+ nreq nopt)))))
- body))
- (else
- ;; Here we handle the case where nargs < nreq + nopt,
- ;; so the rest argument (if any) will be empty, and
- ;; there will be optional arguments that rely on their
- ;; default initializers.
- ;;
- ;; The default initializers of optional arguments
- ;; may refer to earlier arguments, so in the general
- ;; case we must expand into a series of nested let
- ;; expressions.
- ;;
- ;; In the generated code, the outermost let
- ;; expression will bind all arguments provided by
- ;; the application's argument list, as well as the
- ;; empty rest argument, if any. Each remaining
- ;; optional argument that relies on its default
- ;; initializer will be bound within an inner let.
- ;;
- ;; rest-gensyms, rest-vars and rest-inits will have
- ;; either 0 or 1 elements. They are oddly named, but
- ;; allow simpler code below.
- (let*-values
- (((non-rest-gensyms rest-gensyms)
- (split-at gensyms (+ nreq nopt)))
- ((provided-gensyms default-gensyms)
- (split-at non-rest-gensyms nargs))
- ((provided-vars default-vars)
- (split-at (append req opt) nargs))
- ((rest-vars)
- (if rest (list rest) '()))
- ((rest-inits)
- (if rest
- (list (make-const #f '()))
- '()))
- ((default-inits)
- (drop inits (- nargs nreq))))
- (make-let src
- (append provided-vars rest-vars)
- (append provided-gensyms rest-gensyms)
- (append orig-args rest-inits)
- (fold-right (lambda (var gensym init body)
- (make-let src
- (list var)
- (list gensym)
- (list init)
- body))
- body
- default-vars
- default-gensyms
- default-inits))))))
+ (define (singly-referenced-lambda? orig-proc)
+ (match orig-proc
+ (($ <lambda>) #t)
+ (($ <lexical-ref> _ _ sym)
+ (and (not (assigned-lexical? sym))
+ (= (lexical-refcount sym) 1)
+ (singly-referenced-lambda?
+ (operand-source (lookup sym)))))
+ (_ #f)))
+ (define (inlined-call)
+ (let ((req-vals (list-head orig-args nreq))
+ (opt-vals (let lp ((args (drop orig-args nreq))
+ (inits inits)
+ (out '()))
+ (match inits
+ (() (reverse out))
+ ((init . inits)
+ (match args
+ (()
+ (lp '() inits (cons init out)))
+ ((arg . args)
+ (lp args inits (cons arg out))))))))
+ (rest-vals (cond
+ ((> nargs (+ nreq nopt))
+ (list (make-primcall
+ #f 'list
+ (drop orig-args (+ nreq nopt)))))
+ (rest (list (make-const #f '())))
+ (else '()))))
+ (if (>= nargs (+ nreq nopt))
+ (make-let src
+ (append req opt rest)
+ gensyms
+ (append req-vals opt-vals rest-vals)
+ body)
+ ;; The default initializers of optional arguments
+ ;; may refer to earlier arguments, so in the general
+ ;; case we must expand into a series of nested let
+ ;; expressions.
+ ;;
+ ;; In the generated code, the outermost let
+ ;; expression will bind all required arguments, as
+ ;; well as the empty rest argument, if any. Each
+ ;; optional argument will be bound within an inner
+ ;; let.
+ (make-let src
+ (append req rest)
+ (append (list-head gensyms nreq)
+ (last-pair gensyms))
+ (append req-vals rest-vals)
+ (fold-right (lambda (var gensym val body)
+ (make-let src
+ (list var)
+ (list gensym)
+ (list val)
+ body))
+ body
+ opt
+ (list-head (drop gensyms nreq) nopt)
+ opt-vals)))))
(cond
((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
;; An error, or effecting arguments.
- (make-application src (for-call orig-proc)
- (map for-value orig-args)))
+ (make-call src (for-call orig-proc) (map for-value orig-args)))
((or (and=> (find-counter key counter) counter-recursive?)
- (lambda? orig-proc))
+ (singly-referenced-lambda? orig-proc))
;; A recursive call, or a lambda in the operator
;; position of the source expression. Process again in
;; tail context.
(lp (counter-prev counter)))))))
(log 'inline-recurse key)
- (loop (inlined-application) env counter ctx))
+ (loop (inlined-call) env counter ctx))
(else
;; An integration at the top-level, the first
;; recursion of a recursive procedure, or a nested
(let/ec k
(define (abort)
(log 'inline-abort exp)
- (k (make-application src (for-call orig-proc)
- (map for-value orig-args))))
+ (k (make-call src (for-call orig-proc)
+ (map for-value orig-args))))
(define new-counter
(cond
;; These first two cases will transfer effort
(make-top-counter effort-limit operand-size-limit
abort key))))
(define result
- (loop (inlined-application) env new-counter ctx))
+ (loop (inlined-call) env new-counter ctx))
(if counter
;; The nested inlining attempt succeeded.
(log 'inline-let orig-proc)
(for-tail
(make-let lsrc names syms vals
- (make-application src body orig-args))))
+ (make-call src body orig-args))))
;; It's possible for a `let' to go away after the
;; visit due to the fact that visiting a procedure in
;; value context will prune unused bindings, whereas
;; traverse through lambdas. In that case re-visit
;; the procedure.
(proc (revisit-proc proc)))
- (make-application src (for-call orig-proc)
- (map for-value orig-args))))
+ (make-call src (for-call orig-proc)
+ (map for-value orig-args))))
(_
- (make-application src (for-call orig-proc)
- (map for-value orig-args))))))
+ (make-call src (for-call orig-proc) (map for-value orig-args))))))
(($ <lambda> src meta body)
(case ctx
((effect) (make-void #f))
(define (lift-applied-lambda body gensyms)
(and (not opt) rest (not kw)
(match body
- (($ <application> _
- ($ <primitive-ref> _ '@apply)
+ (($ <primcall> _ 'apply
(($ <lambda> _ _ (and lcase ($ <lambda-case>)))
($ <lexical-ref> _ _ sym)
...))
new
body
(and alt (for-tail alt))))))
- (($ <sequence> src exps)
- (let lp ((exps exps) (effects '()))
- (match exps
- ((last)
- (if (null? effects)
- (for-tail last)
- (make-sequence
- src
- (reverse (cons (for-tail last) effects)))))
- ((head . rest)
- (let ((head (for-effect head)))
- (cond
- ((sequence? head)
- (lp (append (sequence-exps head) rest) effects))
- ((void? head)
- (lp rest effects))
- (else
- (lp rest (cons head effects)))))))))
- (($ <prompt> src tag body handler)
+ (($ <seq> src head tail)
+ (let ((head (for-effect head))
+ (tail (for-tail tail)))
+ (if (void? head)
+ tail
+ (make-seq src
+ (if (and (seq? head)
+ (void? (seq-tail head)))
+ (seq-head head)
+ head)
+ tail))))
+ (($ <prompt> src escape-only? tag body handler)
(define (make-prompt-tag? x)
(match x
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
- (or () ((? constant-expression?))))
+ (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
#t)
(_ #f)))
(let ((tag (for-value tag))
- (body (for-tail body)))
+ (body (if escape-only? (for-tail body) (for-value body))))
(cond
((find-definition tag 1)
(lambda (val op)
;; for this <prompt>, so we can elide the <prompt>
;; entirely.
(unrecord-operand-uses op 1)
- body))
- ((find-definition tag 2)
- (lambda (val op)
- (and (make-prompt-tag? val)
- (abort? body)
- (tree-il=? (abort-tag body) tag)))
- => (lambda (val op)
- ;; (let ((t (make-prompt-tag)))
- ;; (call-with-prompt t
- ;; (lambda () (abort-to-prompt t val ...))
- ;; (lambda (k arg ...) e ...)))
- ;; => (let-values (((k arg ...) (values values val ...)))
- ;; e ...)
- (unrecord-operand-uses op 2)
- (for-tail
- (make-let-values
- src
- (make-application #f (make-primitive-ref #f 'apply)
- `(,(make-primitive-ref #f 'values)
- ,(make-primitive-ref #f 'values)
- ,@(abort-args body)
- ,(abort-tail body)))
- (for-value handler)))))
+ (for-tail (if escape-only? body (make-call src body '())))))
(else
- (make-prompt src tag body (for-value handler))))))
+ (let ((handler (for-value handler)))
+ (define (escape-only-handler? handler)
+ (match handler
+ (($ <lambda> _ _
+ ($ <lambda-case> _ (_ . _) _ _ _ _ (k . _) body #f))
+ (not (tree-il-any
+ (match-lambda
+ (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t)
+ (_ #f))
+ body)))
+ (else #f)))
+ (if (and (not escape-only?) (escape-only-handler? handler))
+ ;; Prompt transitioning to escape-only; transition body
+ ;; to be an expression.
+ (for-tail
+ (make-prompt src #t tag (make-call #f body '()) handler))
+ (make-prompt src escape-only? tag body handler)))))))
+
(($ <abort> src tag args tail)
(make-abort src (for-value tag) (map for-value args)
(for-value tail))))))
;;; open-coding primitive procedures
-;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015 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 (language tree-il)
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-16)
- #:export (resolve-primitives! add-interesting-primitive!
- expand-primitives!
+ #:export (resolve-primitives add-interesting-primitive!
+ expand-primitives
effect-free-primitive? effect+exception-free-primitive?
- constructor-primitive? accessor-primitive?
- singly-valued-primitive? bailout-primitive?
+ constructor-primitive?
+ singly-valued-primitive? equality-primitive?
+ bailout-primitive?
negate-primitive))
;; When adding to this, be sure to update *multiply-valued-primitives*
;; if appropriate.
-(define *interesting-primitive-names*
- '(apply @apply
- call-with-values @call-with-values
- call-with-current-continuation @call-with-current-continuation
+(define *interesting-primitive-names*
+ '(apply
+ call-with-values
+ call-with-current-continuation
call/cc
dynamic-wind
- @dynamic-wind
values
eq? eqv? equal?
memq memv
= < > <= >= zero? positive? negative?
+ * - / 1- 1+ quotient remainder modulo
- ash logand logior logxor lognot
+ ash logand logior logxor lognot logtest logbit?
+ sqrt abs
not
- pair? null? list? symbol? vector? string? struct? number? char?
+ pair? null? list? symbol? vector? string? struct? number? char? nil?
+ bytevector? keyword? bitvector?
+
+ procedure? thunk?
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
- variable-ref variable-set!
+ length
+
+ make-vector vector-length vector-ref vector-set!
+ variable? variable-ref variable-set!
variable-bound?
- fluid-ref fluid-set!
+ current-module define!
+
+ fluid-ref fluid-set! with-fluid*
- @prompt call-with-prompt @abort abort-to-prompt
+ call-with-prompt
+ abort-to-prompt* abort-to-prompt
make-prompt-tag
throw error scm-error
string-length string-ref string-set!
- struct-vtable make-struct struct-ref struct-set!
+ allocate-struct struct-vtable make-struct struct-ref struct-set!
+
+ bytevector-length
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
(define *primitive-constructors*
;; Primitives that return a fresh object.
- '(acons cons cons* list vector make-struct make-struct/no-tail
+ '(acons cons cons* list vector make-vector
+ allocate-struct make-struct make-struct/no-tail
make-prompt-tag))
(define *primitive-accessors*
;; Primitives that are pure, but whose result depends on the mutable
;; memory pointed to by their operands.
+ ;;
+ ;; Note: if you add an accessor here, be sure to add a corresponding
+ ;; case in (language tree-il effects)!
'(vector-ref
car cdr
memq memv
`(values
eq? eqv? equal?
= < > <= >= zero? positive? negative?
- ash logand logior logxor lognot
- + * - / 1- 1+ quotient remainder modulo
+ ash logand logior logxor lognot logtest logbit?
+ + * - / 1- 1+ sqrt abs quotient remainder modulo
not
- pair? null? list? symbol? vector? struct? string? number? char?
+ pair? null? nil? list?
+ symbol? variable? vector? struct? string? number? char?
+ bytevector? keyword? bitvector?
complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
char<? char<=? char>=? char>?
integer->char char->integer number->string string->number
struct-vtable
- string-length
- ;; These all should get expanded out by expand-primitives!.
+ length string-length vector-length bytevector-length
+ ;; These all should get expanded out by expand-primitives.
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
'(values
eq? eqv? equal?
not
- pair? null? list? symbol? vector? struct? string? number? char?
+ pair? null? nil? list?
+ symbol? variable? vector? struct? string? number? char?
+ bytevector? keyword? bitvector?
+ procedure? thunk?
acons cons cons* list vector))
;; Primitives that don't always return one value.
(define *multiply-valued-primitives*
- '(apply @apply
- call-with-values @call-with-values
- call-with-current-continuation @call-with-current-continuation
+ '(apply
+ call-with-values
+ call-with-current-continuation
call/cc
dynamic-wind
- @dynamic-wind
values
- @prompt call-with-prompt @abort abort-to-prompt))
+ call-with-prompt
+ @abort abort-to-prompt))
;; Procedures that cause a nonlocal, non-resumable abort.
(define *bailout-primitives*
(char<? . char>=?)
(char>? . char<=?)))
+(define *equality-primitives*
+ '(eq? eqv? equal?))
+
(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))
+(define *equality-primitive-table* (make-hash-table))
(define *multiply-valued-primitive-table* (make-hash-table))
(define *bailout-primitive-table* (make-hash-table))
(define *negatable-primitive-table* (make-hash-table))
(for-each (lambda (x)
(hashq-set! *effect+exceptions-free-primitive-table* x #t))
*effect+exception-free-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *equality-primitive-table* x #t))
+ *equality-primitives*)
(for-each (lambda (x)
(hashq-set! *multiply-valued-primitive-table* x #t))
*multiply-valued-primitives*)
(define (constructor-primitive? prim)
(memq prim *primitive-constructors*))
-(define (accessor-primitive? prim)
- (memq prim *primitive-accessors*))
(define (effect-free-primitive? prim)
(hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
(hashq-ref *effect+exceptions-free-primitive-table* prim))
+(define (equality-primitive? prim)
+ (hashq-ref *equality-primitive-table* prim))
(define (singly-valued-primitive? prim)
(not (hashq-ref *multiply-valued-primitive-table* prim)))
(define (bailout-primitive? prim)
(define (negate-primitive prim)
(hashq-ref *negatable-primitive-table* prim))
-(define (resolve-primitives! x mod)
- (post-order!
+(define (resolve-primitives x mod)
+ (define local-definitions
+ (make-hash-table))
+
+ ;; Assume that any definitions with primitive names in the root module
+ ;; have the same semantics as the primitives.
+ (unless (eq? mod the-root-module)
+ (let collect-local-definitions ((x x))
+ (record-case x
+ ((<toplevel-define> name)
+ (hashq-set! local-definitions name #t))
+ ((<seq> head tail)
+ (collect-local-definitions head)
+ (collect-local-definitions tail))
+ (else #f))))
+
+ (post-order
(lambda (x)
- (record-case x
- ((<toplevel-ref> src name)
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable mod name))
- (lambda (name) (make-primitive-ref src name))))
- ((<module-ref> src mod name public?)
- (and=> (and=> (resolve-module mod)
- (if public?
- module-public-interface
- identity))
- (lambda (m)
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable m name))
- (lambda (name)
- (make-primitive-ref src name))))))
- (else #f)))
+ (or
+ (record-case x
+ ((<toplevel-ref> src name)
+ (and=> (and (not (hashq-ref local-definitions name))
+ (hashq-ref *interesting-primitive-vars*
+ (module-variable mod name)))
+ (lambda (name) (make-primitive-ref src name))))
+ ((<module-ref> src mod name public?)
+ ;; for the moment, we're disabling primitive resolution for
+ ;; public refs because resolve-interface can raise errors.
+ (and=> (and=> (resolve-module mod)
+ (if public?
+ module-public-interface
+ identity))
+ (lambda (m)
+ (and=> (hashq-ref *interesting-primitive-vars*
+ (module-variable m name))
+ (lambda (name)
+ (make-primitive-ref src name))))))
+ ((<call> src proc args)
+ (and (primitive-ref? proc)
+ (make-primcall src (primitive-ref-name proc) args)))
+ (else #f))
+ x))
x))
\f
(define *primitive-expand-table* (make-hash-table))
-(define (expand-primitives! x)
- (pre-order!
+(define (expand-primitives x)
+ (pre-order
(lambda (x)
(record-case x
- ((<application> src proc args)
- (and (primitive-ref? proc)
- (let ((expand (hashq-ref *primitive-expand-table*
- (primitive-ref-name proc))))
- (and expand (apply expand src args)))))
- (else #f)))
+ ((<primcall> src name args)
+ (let ((expand (hashq-ref *primitive-expand-table* name)))
+ (or (and expand (apply expand src args))
+ x)))
+ (else x)))
x))
;;; I actually did spend about 10 minutes trying to redo this with
(lp (cdr in)
(cons (if (eq? (caar in) 'quote)
`(make-const src ,@(cdar in))
- `(make-application src (make-primitive-ref src ',(caar in))
- ,(inline-args (cdar in))))
+ `(make-primcall src ',(caar in)
+ ,(inline-args (cdar in))))
out)))
((symbol? (car in))
;; assume it's locally bound
,(consequent then)
,(consequent else)))
(else
- `(make-application src (make-primitive-ref src ',(car exp))
- ,(inline-args (cdr exp))))))
+ `(make-primcall src ',(car exp)
+ ,(inline-args (cdr exp))))))
((symbol? exp)
;; assume locally bound
exp)
(define-primitive-expander acons (x y z)
(cons (cons x y) z))
-(define-primitive-expander apply (f a0 . args)
- (@apply f a0 . args))
-
-(define-primitive-expander call-with-values (producer consumer)
- (@call-with-values producer consumer))
-
-(define-primitive-expander call-with-current-continuation (proc)
- (@call-with-current-continuation proc))
-
(define-primitive-expander call/cc (proc)
- (@call-with-current-continuation proc))
+ (call-with-current-continuation proc))
(define-primitive-expander make-struct (vtable tail-size . args)
(if (and (const? tail-size)
((src a) #f)
((src a b) #f)
((src a b . rest)
- (let* ((prim (make-primitive-ref src prim-name))
- (b-sym (gensym "b"))
+ (let* ((b-sym (gensym "b"))
(b* (make-lexical-ref src 'b b-sym)))
(make-let src
'(b)
(list b-sym)
(list b)
(make-conditional src
- (make-application src prim (list a b*))
- (make-application src prim (cons b* rest))
+ (make-primcall src prim-name (list a b*))
+ (make-primcall src prim-name (cons b* rest))
(make-const src #f)))))))
(for-each (lambda (prim-name)
'(< > <= >= =))
;; Appropriate for use with either 'eqv?' or 'equal?'.
-(define maybe-simplify-to-eq
+(define (maybe-simplify-to-eq prim)
(case-lambda
+ ((src) (make-const src #t))
+ ((src a) (make-const src #t))
((src a b)
;; Simplify cases where either A or B is constant.
(define (maybe-simplify a b)
(symbol? v)
(and (integer? v)
(exact? v)
- (<= most-negative-fixnum v most-positive-fixnum)))
- (make-application src (make-primitive-ref #f 'eq?)
- (list a b))))))
+ (<= v most-positive-fixnum)
+ (>= v most-negative-fixnum)))
+ (make-primcall src 'eq? (list a b))))))
(or (maybe-simplify a b) (maybe-simplify b a)))
+ ((src a b . rest)
+ (make-conditional src (make-primcall src prim (list a b))
+ (make-primcall src prim (cons b rest))
+ (make-const src #f)))
(else #f)))
-(hashq-set! *primitive-expand-table* 'eqv? maybe-simplify-to-eq)
-(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
-
-(hashq-set! *primitive-expand-table*
- 'dynamic-wind
- (case-lambda
- ((src pre thunk post)
- (let ((PRE (gensym "pre-"))
- (THUNK (gensym "thunk-"))
- (POST (gensym "post-")))
- (make-let
- src
- '(pre thunk post)
- (list PRE THUNK POST)
- (list pre thunk post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
- (make-lexical-ref #f 'post POST)))))
- (else #f)))
-
-(hashq-set! *primitive-expand-table*
- '@dynamic-wind
- (case-lambda
- ((src pre expr post)
- (let ((PRE (gensym "pre-"))
- (POST (gensym "post-")))
- (make-let
- src
- '(pre post)
- (list PRE POST)
- (list pre post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- expr
- (make-lexical-ref #f 'post POST)))))))
+(hashq-set! *primitive-expand-table* 'eqv? (maybe-simplify-to-eq 'eqv?))
+(hashq-set! *primitive-expand-table* 'equal? (maybe-simplify-to-eq 'equal?))
-(hashq-set! *primitive-expand-table*
- 'fluid-ref
- (case-lambda
- ((src fluid) (make-dynref src fluid))
- (else #f)))
-
-(hashq-set! *primitive-expand-table*
- 'fluid-set!
- (case-lambda
- ((src fluid exp) (make-dynset src fluid exp))
- (else #f)))
+(define (expand-chained-comparisons prim)
+ (case-lambda
+ ((src) (make-const src #t))
+ ((src a) (make-const src #t))
+ ((src a b) #f)
+ ((src a b . rest)
+ (make-conditional src (make-primcall src prim (list a b))
+ (make-primcall src prim (cons b rest))
+ (make-const src #f)))
+ (else #f)))
-(hashq-set! *primitive-expand-table*
- '@prompt
- (case-lambda
- ((src tag exp handler)
- (let ((args-sym (gensym)))
- (make-prompt
- src tag exp
- ;; If handler itself is a lambda, the inliner can do some
- ;; trickery here.
- (make-lambda-case
- (tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-application #f (make-primitive-ref #f 'apply)
- (list handler
- (make-lexical-ref #f 'args args-sym)))
- #f))))
- (else #f)))
+(for-each (lambda (prim)
+ (hashq-set! *primitive-expand-table* prim
+ (expand-chained-comparisons prim)))
+ '(< <= = >= > eq?))
(hashq-set! *primitive-expand-table*
'call-with-prompt
(case-lambda
((src tag thunk handler)
- (let ((handler-sym (gensym))
- (args-sym (gensym)))
- (make-let
- src '(handler) (list handler-sym) (list handler)
- (make-prompt
- src tag (make-application #f thunk '())
- ;; If handler itself is a lambda, the inliner can do some
- ;; trickery here.
- (make-lambda-case
- (tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-application
- #f (make-primitive-ref #f 'apply)
- (list (make-lexical-ref #f 'handler handler-sym)
- (make-lexical-ref #f 'args args-sym)))
- #f)))))
+ (make-prompt src #f tag thunk handler))
(else #f)))
(hashq-set! *primitive-expand-table*
- '@abort
+ 'abort-to-prompt*
(case-lambda
((src tag tail-args)
(make-abort src tag '() tail-args))
;;; Tree Intermediate Language
-;; Copyright (C) 2009, 2010, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2013 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 (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)
+ #:use-module (language tree-il compile-cps)
#:export (tree-il))
(define (write-tree-il exp . port)
(pmatch exps
(() (make-void #f))
((,x) x)
- (else (make-sequence #f exps))))
+ ((,x . ,rest)
+ (make-seq #f x (join rest env)))
+ (else (error "what!" exps env))))
(define-language tree-il
#:title "Tree Intermediate Language"
#:printer write-tree-il
#:parser parse-tree-il
#:joiner join
- #:compilers `((glil . ,compile-glil))
+ #:compilers `((cps . ,compile-cps))
#:for-humans? #f
)
;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;;
(define-module (oop goops)
- :use-module (srfi srfi-1)
- :export-syntax (define-class class standard-define-class
- define-generic define-accessor define-method
- define-extended-generic define-extended-generics
- method)
- :export (is-a? class-of
- ensure-metaclass ensure-metaclass-with-supers
- make-class
- make-generic ensure-generic
- make-extended-generic
- make-accessor ensure-accessor
- add-method!
- class-slot-ref class-slot-set! slot-unbound slot-missing
- slot-definition-name slot-definition-options
- slot-definition-allocation
- slot-definition-getter slot-definition-setter
- slot-definition-accessor
- slot-definition-init-value slot-definition-init-form
- slot-definition-init-thunk slot-definition-init-keyword
- slot-init-function class-slot-definition
- method-source
- compute-cpl compute-std-cpl compute-get-n-set compute-slots
- compute-getter-method compute-setter-method
- allocate-instance initialize make-instance make
- no-next-method no-applicable-method no-method
- change-class update-instance-for-different-class
- shallow-clone deep-clone
- class-redefinition
- apply-generic apply-method apply-methods
- compute-applicable-methods %compute-applicable-methods
- method-more-specific? sort-applicable-methods
- class-subclasses class-methods
- goops-error
- min-fixnum max-fixnum
- ;;; *fixme* Should go into goops.c
- instance? slot-ref-using-class
- slot-set-using-class! slot-bound-using-class?
- 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
- 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)
- :no-backtrace)
+ #:use-module (srfi srfi-1)
+ #:export-syntax (define-class class standard-define-class
+ define-generic define-accessor define-method
+ define-extended-generic define-extended-generics
+ method)
+ #:export ( ;; The root of everything.
+ <top>
+ <class> <object>
+
+ ;; Slot types.
+ <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
+ <read-only-slot> <self-slot> <protected-opaque-slot>
+ <protected-hidden-slot> <protected-read-only-slot>
+ <scm-slot> <int-slot> <float-slot> <double-slot>
+
+ ;; Methods are implementations of generic functions.
+ <method> <accessor-method>
+
+ ;; Applicable objects, either procedures or applicable structs.
+ <procedure-class> <applicable>
+ <procedure> <primitive-generic>
+
+ ;; Applicable structs.
+ <applicable-struct-class>
+ <applicable-struct>
+ <generic> <extended-generic>
+ <generic-with-setter> <extended-generic-with-setter>
+ <accessor> <extended-accessor>
+
+ ;; Types with their own allocated typecodes.
+ <boolean> <char> <list> <pair> <null> <string> <symbol>
+ <vector> <bytevector> <uvec> <foreign> <hashtable>
+ <fluid> <dynamic-state> <frame> <vm> <vm-continuation>
+ <keyword>
+
+ ;; Numbers.
+ <number> <complex> <real> <integer> <fraction>
+
+ ;; Unknown.
+ <unknown>
+
+ ;; Particular SMOB data types. All SMOB types have
+ ;; corresponding classes, which may be obtained via class-of,
+ ;; once you have an instance. Perhaps FIXME to provide a
+ ;; smob-type-name->class procedure.
+ <arbiter> <promise> <thread> <mutex> <condition-variable>
+ <regexp> <hook> <bitvector> <random-state> <async>
+ <directory> <array> <character-set>
+ <dynamic-object> <guardian> <macro>
+
+ ;; Modules.
+ <module>
+
+ ;; Ports.
+ <port> <input-port> <output-port> <input-output-port>
+
+ ;; Like SMOB types, all port types have their own classes,
+ ;; which can be accessed via `class-of' once you have an
+ ;; instance. Here we export bindings just for file ports.
+ <file-port>
+ <file-input-port> <file-output-port> <file-input-output-port>
+
+ is-a? class-of
+ ensure-metaclass ensure-metaclass-with-supers
+ make-class
+ make-generic ensure-generic
+ make-extended-generic
+ make-accessor ensure-accessor
+ add-method!
+ class-slot-ref class-slot-set! slot-unbound slot-missing
+ slot-definition-name slot-definition-options
+ slot-definition-allocation
+
+ slot-definition-getter slot-definition-setter
+ slot-definition-accessor
+ slot-definition-init-value slot-definition-init-form
+ slot-definition-init-thunk slot-definition-init-keyword
+ slot-init-function class-slot-definition
+ method-source
+ compute-cpl compute-std-cpl compute-get-n-set compute-slots
+ compute-getter-method compute-setter-method
+ allocate-instance initialize make-instance make
+ no-next-method no-applicable-method no-method
+ change-class update-instance-for-different-class
+ shallow-clone deep-clone
+ class-redefinition
+ apply-generic apply-method apply-methods
+ compute-applicable-methods %compute-applicable-methods
+ method-more-specific? sort-applicable-methods
+ class-subclasses class-methods
+ goops-error
+ min-fixnum max-fixnum
+
+;;; *fixme* Should go into goops.c
+ instance? slot-ref-using-class
+ slot-set-using-class! slot-bound-using-class?
+ 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
+ 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)
+ #:no-backtrace)
(define *goops-module* (current-module))
+;; XXX FIXME: figure out why the 'eval-when's in this file must use
+;; 'compile' and must avoid 'expand', but only in 2.2, and only when
+;; compiling something that imports goops, e.g. (ice-9 occam-channel),
+;; before (oop goops) itself has been compiled.
+
;; First initialize the builtin part of GOOPS
-(eval-when (expand load eval)
+(eval-when (compile load eval)
(%init-goops-builtins))
-(eval-when (expand load eval)
+(eval-when (compile load eval)
(use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
(add-interesting-primitive! 'class-of))
(oop goops compile))
\f
-(eval-when (expand load eval)
+;; FIXME: deprecate.
+(eval-when (compile load eval)
(define min-fixnum (- (expt 2 29)))
(define max-fixnum (- (expt 2 29) 1)))
;;; Handling of duplicate bindings in the module system
;;;
+(define (find-subclass super name)
+ (let lp ((classes (class-direct-subclasses super)))
+ (cond
+ ((null? classes)
+ (error "class not found" name))
+ ((and (slot-bound? (car classes) 'name)
+ (eq? (class-name (car classes)) name))
+ (car classes))
+ (else
+ (lp (cdr classes))))))
+
+;; A record type.
+(define <module> (find-subclass <top> '<module>))
+
(define-method (merge-generics (module <module>)
(name <symbol>)
(int1 <module>)
(define (make-generic-bound-check-getter proc)
(lambda (o) (assert-bound (proc o) o)))
-;; the idea is to compile the index into the procedure, for fastest
-;; lookup.
-
-(eval-when (expand load eval)
- (define num-standard-pre-cache 20))
-
-(define-macro (define-standard-accessor-method form . body)
- (let ((name (caar form))
- (n-var (cadar form))
- (args (cdr form)))
- (define (make-one x)
- (define (body-trans form)
- (cond ((not (pair? form)) form)
- ((eq? (car form) 'struct-ref)
- `(,(car form) ,(cadr form) ,x))
- ((eq? (car form) 'struct-set!)
- `(,(car form) ,(cadr form) ,x ,(cadddr form)))
- (else
- (map body-trans form))))
- `(lambda ,args ,@(map body-trans body)))
- `(define ,name
- (let ((cache (vector ,@(map make-one (iota num-standard-pre-cache)))))
- (lambda (n)
- (if (< n ,num-standard-pre-cache)
- (vector-ref cache n)
- ((lambda (,n-var) (lambda ,args ,@body)) n)))))))
+;;; Pre-generate getters and setters for the first 20 slots.
+(define-syntax define-standard-accessor-method
+ (lambda (stx)
+ (define num-standard-pre-cache 20)
+ (syntax-case stx ()
+ ((_ ((proc n) arg ...) body)
+ #`(define proc
+ (let ((cache (vector #,@(map (lambda (n*)
+ #`(lambda (arg ...)
+ (let ((n #,n*))
+ body)))
+ (iota num-standard-pre-cache)))))
+ (lambda (n)
+ (if (< n #,num-standard-pre-cache)
+ (vector-ref cache n)
+ (lambda (arg ...) body)))))))))
(define-standard-accessor-method ((bound-check-get n) o)
(let ((x (struct-ref o n)))
;; Tell C code that the main bulk of Goops has been loaded
(%goops-loaded)
+
+
+\f
+
+;;;
+;;; {SMOB and port classes}
+;;;
+
+(define <arbiter> (find-subclass <top> '<arbiter>))
+(define <promise> (find-subclass <top> '<promise>))
+(define <thread> (find-subclass <top> '<thread>))
+(define <mutex> (find-subclass <top> '<mutex>))
+(define <condition-variable> (find-subclass <top> '<condition-variable>))
+(define <regexp> (find-subclass <top> '<regexp>))
+(define <hook> (find-subclass <top> '<hook>))
+(define <bitvector> (find-subclass <top> '<bitvector>))
+(define <random-state> (find-subclass <top> '<random-state>))
+(define <async> (find-subclass <top> '<async>))
+(define <directory> (find-subclass <top> '<directory>))
+(define <array> (find-subclass <top> '<array>))
+(define <character-set> (find-subclass <top> '<character-set>))
+(define <dynamic-object> (find-subclass <top> '<dynamic-object>))
+(define <guardian> (find-subclass <applicable> '<guardian>))
+(define <macro> (find-subclass <top> '<macro>))
+
+(define (define-class-subtree class)
+ (define! (class-name class) class)
+ (for-each define-class-subtree (class-direct-subclasses class)))
+
+(define-class-subtree (find-subclass <port> '<file-port>))
-;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
((memv (car l) (cdr l)) (car l))
(else (find-duplicate (cdr l)))))
-(begin-deprecated
- (define (top-level-env)
- (let ((mod (current-module)))
- (if mod
- (module-eval-closure mod)
- '())))
-
- (define (top-level-env? env)
- (or (null? env)
- (procedure? (car env))))
-
- (export top-level-env? top-level-env))
-
(define (map* fn . l) ; A map which accepts dotted lists (arg lists
(cond ; must be "isomorph"
((null? (car l)) '())
(define (port-transcoder port)
"Return the transcoder object associated with @var{port}, or @code{#f}
if the port has no transcoder."
- (cond ((port-encoding port)
- => (lambda (encoding)
- (make-transcoder
- encoding
- (native-eol-style)
- (case (port-conversion-strategy port)
- ((error) 'raise)
- ((substitute) 'replace)
- (else
- (assertion-violation 'port-transcoder
- "unsupported error handling mode"))))))
- (else
- #f)))
+ (and (textual-port? port)
+ ;; All textual ports have transcoders.
+ (make-transcoder
+ (port-encoding port)
+ (native-eol-style)
+ (case (port-conversion-strategy port)
+ ((error) 'raise)
+ ((substitute) 'replace)
+ (else
+ (assertion-violation 'port-transcoder
+ "unsupported error handling mode"))))))
(define (binary-port? port)
- "Returns @code{#t} if @var{port} does not have an associated encoding,
-@code{#f} otherwise."
- (not (port-encoding port)))
+ "Always returns @code{#t}, as all ports can be used for binary I/O in
+Guile."
+ (equal? (port-encoding port) "ISO-8859-1"))
(define (textual-port? port)
"Always returns @code{#t}, as all ports can be used for textual I/O in
(define (open-string-input-port str)
"Open an input port that will read from @var{str}."
- (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string str)))
+ (open-input-string str))
(define (r6rs-open filename mode buffer-mode transcoder)
(let ((port (with-i/o-filename-conditions filename
(define (open-string-output-port)
"Return two values: an output port that will collect characters written to it
as a string, and a thunk to retrieve the characters associated with that port."
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-output-string))))
+ (let ((port (open-output-string)))
(values port
(lambda () (get-output-string port)))))
;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*-
-;; Copyright 2005, 2008, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
+;; Copyright 2005, 2008-2011, 2013, 2014 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
(cons #:O o)
o)))
(from (or (assoc-ref options 'from) 'scheme))
- (to (or (assoc-ref options 'to) 'objcode))
+ (to (or (assoc-ref options 'to) 'bytecode))
(target (or (assoc-ref options 'target) %host-type))
(input-files (assoc-ref options 'input-files))
(output-file (assoc-ref options 'output-file))
for a list of available warnings
-f, --from=LANG specify a source language other than `scheme'
- -t, --to=LANG specify a target language other than `objcode'
+ -t, --to=LANG specify a target language other than `bytecode'
-T, --target=TRIPLET produce bytecode for host TRIPLET
Note that auto-compilation will be turned off.
;;; Disassemble --- Disassemble .go files into something human-readable
-;; Copyright 2005, 2008, 2009, 2011, 2014 Free Software Foundation, Inc.
+;; Copyright 2005, 2008, 2009, 2011, 2012, 2013 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
;;; Commentary:
-;; Usage: disassemble [ARGS]
+;; Usage: disassemble FILE...
;;; Code:
(define-module (scripts disassemble)
- #:use-module (system vm objcode)
- #:use-module ((language assembly disassemble) #:prefix asm:)
+ #:use-module (system vm disassembler)
#:export (disassemble))
(define %summary "Disassemble a compiled .go file.")
(define (disassemble . files)
- (for-each (lambda (file)
- (asm:disassemble (load-objcode file)))
- files))
+ (for-each disassemble-file files))
(define main disassemble)
;;; srfi-1.scm --- List Library
-;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014 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
;;; Fold, unfold & map
-(define (fold kons knil list1 . rest)
- "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
+(define fold
+ (case-lambda
+ "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
that result. See the manual for details."
- (check-arg procedure? kons fold)
- (if (null? rest)
- (let f ((knil knil) (list1 list1))
- (if (null? list1)
- knil
- (f (kons (car list1) knil) (cdr list1))))
- (let f ((knil knil) (lists (cons list1 rest)))
- (if (any null? lists)
- knil
- (let ((cars (map car lists))
- (cdrs (map cdr lists)))
- (f (apply kons (append! cars (list knil))) cdrs))))))
+ ((kons knil list1)
+ (check-arg procedure? kons fold)
+ (check-arg list? list1 fold)
+ (let fold1 ((knil knil) (list1 list1))
+ (if (pair? list1)
+ (fold1 (kons (car list1) knil) (cdr list1))
+ knil)))
+ ((kons knil list1 list2)
+ (check-arg procedure? kons fold)
+ (let* ((len1 (length+ list1))
+ (len2 (length+ list2))
+ (len (if (and len1 len2)
+ (min len1 len2)
+ (or len1 len2))))
+ (unless len
+ (scm-error 'wrong-type-arg "fold"
+ "Args do not contain a proper (finite) list: ~S"
+ (list (list list1 list2)) #f))
+ (let fold2 ((knil knil) (list1 list1) (list2 list2) (len len))
+ (if (zero? len)
+ knil
+ (fold2 (kons (car list1) (car list2) knil)
+ (cdr list1) (cdr list2) (1- len))))))
+ ((kons knil list1 . rest)
+ (check-arg procedure? kons fold)
+ (let foldn ((knil knil) (lists (cons list1 rest)))
+ (if (any null? lists)
+ knil
+ (let ((cars (map car lists))
+ (cdrs (map cdr lists)))
+ (foldn (apply kons (append! cars (list knil))) cdrs)))))))
(define (fold-right kons knil clist1 . rest)
(check-arg procedure? kons fold-right)
(case-lambda
((f l)
(check-arg procedure? f map)
- (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
- (if (pair? hare)
- (if move?
- (if (eq? tortoise hare)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l) #f)
- (map1 (cdr hare) (cdr tortoise) #f
- (cons (f (car hare)) out)))
- (map1 (cdr hare) tortoise #t
- (cons (f (car hare)) out)))
- (if (null? hare)
- (reverse! out)
- (scm-error 'wrong-type-arg "map" "Not a list: ~S"
- (list l) #f)))))
+ (check-arg list? l map)
+ (let map1 ((l l))
+ (if (pair? l)
+ (cons (f (car l)) (map1 (cdr l)))
+ '())))
+ ((f l1 l2)
+ (check-arg procedure? f map)
+ (let* ((len1 (length+ l1))
+ (len2 (length+ l2))
+ (len (if (and len1 len2)
+ (min len1 len2)
+ (or len1 len2))))
+ (unless len
+ (scm-error 'wrong-type-arg "map"
+ "Args do not contain a proper (finite) list: ~S"
+ (list (list l1 l2)) #f))
+ (let map2 ((l1 l1) (l2 l2) (len len))
+ (if (zero? len)
+ '()
+ (cons (f (car l1) (car l2))
+ (map2 (cdr l1) (cdr l2) (1- len)))))))
+
((f l1 . rest)
(check-arg procedure? f map)
(let ((len (fold (lambda (ls len)
(scm-error 'wrong-type-arg "map"
"Args do not contain a proper (finite) list: ~S"
(list (cons l1 rest)) #f))
- (let mapn ((l1 l1) (rest rest) (len len) (out '()))
+ (let mapn ((l1 l1) (rest rest) (len len))
(if (zero? len)
- (reverse! out)
- (mapn (cdr l1) (map cdr rest) (1- len)
- (cons (apply f (car l1) (map car rest)) out))))))))
+ '()
+ (cons (apply f (car l1) (map car rest))
+ (mapn (cdr l1) (map cdr rest) (1- len)))))))))
(define map-in-order map)
(case-lambda
((f l)
(check-arg procedure? f for-each)
- (let for-each1 ((hare l) (tortoise l) (move? #f))
- (if (pair? hare)
- (if move?
- (if (eq? tortoise hare)
- (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
- (list l) #f)
- (begin
- (f (car hare))
- (for-each1 (cdr hare) (cdr tortoise) #f)))
- (begin
- (f (car hare))
- (for-each1 (cdr hare) tortoise #t)))
-
- (if (not (null? hare))
- (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
- (list l) #f)))))
-
+ (check-arg list? l for-each)
+ (let for-each1 ((l l))
+ (unless (null? l)
+ (f (car l))
+ (for-each1 (cdr l)))))
+
+ ((f l1 l2)
+ (check-arg procedure? f for-each)
+ (let* ((len1 (length+ l1))
+ (len2 (length+ l2))
+ (len (if (and len1 len2)
+ (min len1 len2)
+ (or len1 len2))))
+ (unless len
+ (scm-error 'wrong-type-arg "for-each"
+ "Args do not contain a proper (finite) list: ~S"
+ (list (list l1 l2)) #f))
+ (let for-each2 ((l1 l1) (l2 l2) (len len))
+ (unless (zero? len)
+ (f (car l1) (car l2))
+ (for-each2 (cdr l1) (cdr l2) (1- len))))))
+
((f l1 . rest)
(check-arg procedure? f for-each)
(let ((len (fold (lambda (ls len)
;;; srfi-18.scm --- Multithreading support
-;; Copyright (C) 2008, 2009, 2010, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2008, 2009, 2010, 2012, 2014 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
(check-arg-type procedure? handler "with-exception-handler")
(check-arg-type thunk? thunk "with-exception-handler")
(hashq-set! thread-exception-handlers ct (cons handler hl))
- (apply (@ (srfi srfi-34) with-exception-handler)
- (list (lambda (obj)
- (hashq-set! thread-exception-handlers ct hl)
- (handler obj))
- (lambda ()
- (call-with-values thunk
- (lambda res
- (hashq-set! thread-exception-handlers ct hl)
- (apply values res))))))))
+ ((@ (srfi srfi-34) with-exception-handler)
+ (lambda (obj)
+ (hashq-set! thread-exception-handlers ct hl)
+ (handler obj))
+ (lambda ()
+ (call-with-values thunk
+ (lambda res
+ (hashq-set! thread-exception-handlers ct hl)
+ (apply values res)))))))
(define (current-exception-handler)
(car (current-handler-stack)))
(define (thread-join! thread . args)
(define thread-join-inner!
(wrap (lambda ()
- (let ((v (apply join-thread (cons thread args)))
+ (let ((v (apply join-thread thread args))
(e (thread->exception thread)))
(if (and (= (length args) 1) (not v))
(raise join-timeout-exception))
(define mutex-lock-inner!
(wrap (lambda ()
(catch 'abandoned-mutex-error
- (lambda () (apply lock-mutex (cons mutex args)))
+ (lambda () (apply lock-mutex mutex args))
(lambda (key . args) (raise abandoned-mutex-exception))))))
(call/cc mutex-lock-inner!))
(define (mutex-unlock! mutex . args)
- (apply unlock-mutex (cons mutex args)))
+ (apply unlock-mutex mutex args))
;; CONDITION VARIABLES
;; These functions are all pass-thrus to the existing Guile implementations.
;;; srfi-6.scm --- Basic String Ports
-;; Copyright (C) 2001, 2002, 2003, 2006, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2003, 2006, 2012,
+;; 2013 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-6)
- #:replace (open-input-string open-output-string)
- #:re-export (get-output-string))
-
-;; SRFI-6 says nothing about encodings, and assumes that any character
-;; or string can be written to a string port. Thus, make all SRFI-6
-;; string ports Unicode capable. See <http://bugs.gnu.org/11197>.
-
-(define (open-input-string s)
- (with-fluids ((%default-port-encoding "UTF-8"))
- ((@ (guile) open-input-string) s)))
-
-(define (open-output-string)
- (with-fluids ((%default-port-encoding "UTF-8"))
- ((@ (guile) open-output-string))))
-
-(cond-expand-provide (current-module) '(srfi-6))
+ #:re-export (open-input-string open-output-string get-output-string))
;;; srfi-6.scm ends here
;;; srfi-9.scm --- define-record-type
;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012,
-;; 2013 Free Software Foundation, Inc.
+;; 2013, 2014 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
(loop (cdr fields) (+ 1 off)))))
(display ">" p))
-(define (throw-bad-struct s who)
- (throw 'wrong-type-arg who
- "Wrong type argument: ~S" (list s)
- (list s)))
+(define-syntax-rule (throw-bad-struct s who)
+ (let ((s* s))
+ (throw 'wrong-type-arg who
+ "Wrong type argument: ~S" (list s*)
+ (list s*))))
(define (make-copier-id type-name)
(datum->syntax type-name
((_ type-name (getter-id ...) check? s (getter expr) ...)
(every identifier? #'(getter ...))
(let ((copier-name (syntax->datum (make-copier-id #'type-name)))
- (getter+exprs #'((getter expr) ...)))
+ (getter+exprs #'((getter expr) ...))
+ (nfields (length #'(getter-id ...))))
(define (lookup id default-expr)
(let ((results
(filter (lambda (g+e)
copier-name "unknown getter" x id)))
#'(getter ...))
(with-syntax ((unsafe-expr
- #`(make-struct
- type-name 0
- #,@(map (lambda (getter index)
- (lookup getter #`(struct-ref s #,index)))
- #'(getter-id ...)
- (iota (length #'(getter-id ...)))))))
+ #`(let ((new (allocate-struct type-name #,nfields)))
+ #,@(map (lambda (getter index)
+ #`(struct-set!
+ new
+ #,index
+ #,(lookup getter
+ #`(struct-ref s #,index))))
+ #'(getter-id ...)
+ (iota nfields))
+ new)))
(if (syntax->datum #'check?)
#`(if (eq? (struct-vtable s) type-name)
unsafe-expr
((name getter setter) #'getter)))
field-specs))
- (define (constructor form type-name constructor-spec field-names)
+ (define (constructor form type-name constructor-spec field-ids)
(syntax-case constructor-spec ()
((ctor field ...)
(every identifier? #'(field ...))
- (let ((ctor-args (map (lambda (field)
- (let ((name (syntax->datum field)))
- (or (memq name field-names)
- (syntax-violation
- (syntax-case form ()
- ((macro . args)
- (syntax->datum #'macro)))
- "unknown field in constructor spec"
- form field))
- (cons name field)))
- #'(field ...))))
+ (let ((slots (map (lambda (field)
+ (or (list-index (lambda (x)
+ (free-identifier=? x field))
+ field-ids)
+ (syntax-violation
+ (syntax-case form ()
+ ((macro . args)
+ (syntax->datum #'macro)))
+ "unknown field in constructor spec"
+ form field)))
+ #'(field ...))))
#`(define-inlinable #,constructor-spec
- (make-struct #,type-name 0
- #,@(map (lambda (name)
- (assq-ref ctor-args name))
- field-names)))))))
+ (let ((s (allocate-struct #,type-name #,(length field-ids))))
+ #,@(map (lambda (arg slot)
+ #`(struct-set! s #,slot #,arg))
+ #'(field ...) slots)
+ s))))))
(define (getters type-name getter-ids copier-id)
(map (lambda (getter index)
(iota (length field-specs))))
(define (record-layout immutable? count)
- (let ((desc (if immutable? "pr" "pw")))
- (string-concatenate (make-list count desc))))
+ ;; Mutability is expressed on the record level; all structs in the
+ ;; future will be mutable.
+ (string-concatenate (make-list count "pw")))
(syntax-case x ()
((_ immutable? form type-name constructor-spec predicate-name
(field-count (length field-ids))
(immutable? (syntax->datum #'immutable?))
(layout (record-layout immutable? field-count))
- (field-names (map syntax->datum field-ids))
(ctor-name (syntax-case #'constructor-spec ()
((ctor args ...) #'ctor)))
(copier-id (make-copier-id #'type-name)))
#`(begin
- #,(constructor #'form #'type-name #'constructor-spec field-names)
+ #,(constructor #'form #'type-name #'constructor-spec field-ids)
(define type-name
(let ((rtd (make-struct/no-tail
-;;;; (statprof) -- a statistical profiler for Guile
-;;;; -*-scheme-*-
-;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2015 Free Software Foundation, Inc.
-;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
-;;;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
-;;;;
-;;;; 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:
-;;
-;;@code{(statprof)} is intended to be a fairly simple
-;;statistical profiler for guile. It is in the early stages yet, so
-;;consider its output still suspect, and please report any bugs to
-;;@email{guile-devel at gnu.org}, or to me directly at @email{rlb at
-;;defaultvalue.org}.
-;;
-;;A simple use of statprof would look like this:
-;;
-;;@example
-;; (statprof-reset 0 50000 #t)
-;; (statprof-start)
-;; (do-something)
-;; (statprof-stop)
-;; (statprof-display)
-;;@end example
-;;
-;;This would reset statprof, clearing all accumulated statistics, then
-;;start profiling, run some code, stop profiling, and finally display a
-;;gprof flat-style table of statistics which will look something like
-;;this:
-;;
-;;@example
-;; % cumulative self self total
-;; time seconds seconds calls ms/call ms/call name
-;; 35.29 0.23 0.23 2002 0.11 0.11 -
-;; 23.53 0.15 0.15 2001 0.08 0.08 positive?
-;; 23.53 0.15 0.15 2000 0.08 0.08 +
-;; 11.76 0.23 0.08 2000 0.04 0.11 do-nothing
-;; 5.88 0.64 0.04 2001 0.02 0.32 loop
-;; 0.00 0.15 0.00 1 0.00 150.59 do-something
-;; ...
-;;@end example
-;;
-;;All of the numerical data with the exception of the calls column is
-;;statistically approximate. In the following column descriptions, and
-;;in all of statprof, "time" refers to execution time (both user and
-;;system), not wall clock time.
-;;
-;;@table @asis
-;;@item % time
-;;The percent of the time spent inside the procedure itself
-;;(not counting children).
-;;@item cumulative seconds
-;;The total number of seconds spent in the procedure, including
-;;children.
-;;@item self seconds
-;;The total number of seconds spent in the procedure itself (not counting
-;;children).
-;;@item calls
-;;The total number of times the procedure was called.
-;;@item self ms/call
-;;The average time taken by the procedure itself on each call, in ms.
-;;@item total ms/call
-;;The average time taken by each call to the procedure, including time
-;;spent in child functions.
-;;@item name
-;;The name of the procedure.
-;;@end table
-;;
-;;The profiler uses @code{eq?} and the procedure object itself to
-;;identify the procedures, so it won't confuse different procedures with
-;;the same name. They will show up as two different rows in the output.
-;;
-;;Right now the profiler is quite simplistic. I cannot provide
-;;call-graphs or other higher level information. What you see in the
-;;table is pretty much all there is. Patches are welcome :-)
-;;
-;;@section Implementation notes
-;;
-;;The profiler works by setting the unix profiling signal
-;;@code{ITIMER_PROF} to go off after the interval you define in the call
-;;to @code{statprof-reset}. When the signal fires, a sampling routine is
-;;run which looks at the current procedure that's executing, and then
-;;crawls up the stack, and for each procedure encountered, increments
-;;that procedure's sample count. Note that if a procedure is encountered
-;;multiple times on a given stack, it is only counted once. After the
-;;sampling is complete, the profiler resets profiling timer to fire
-;;again after the appropriate interval.
-;;
-;;Meanwhile, the profiler keeps track, via @code{get-internal-run-time},
-;;how much CPU time (system and user -- which is also what
-;;@code{ITIMER_PROF} tracks), has elapsed while code has been executing
-;;within a statprof-start/stop block.
-;;
-;;The profiler also tries to avoid counting or timing its own code as
-;;much as possible.
-;;
-;;; Code:
-
-;; When you add new features, please also add tests to ./tests/ if you
-;; have time, and then add the new files to ./run-tests. Also, if
-;; anyone's bored, there are a lot of existing API bits that don't
-;; have tests yet.
-
-;; TODO
-;;
-;; Check about profiling C functions -- does profiling primitives work?
-;; Also look into stealing code from qprof so we can sample the C stack
-;; Call graphs?
-
-(define-module (statprof)
- #:use-module (srfi srfi-1)
- #:autoload (ice-9 format) (format)
- #:use-module (system vm vm)
- #:use-module (system vm frame)
- #:use-module (system vm program)
- #:export (statprof-active?
- statprof-start
- statprof-stop
- statprof-reset
-
- statprof-accumulated-time
- statprof-sample-count
- statprof-fold-call-data
- statprof-proc-call-data
- statprof-call-data-name
- statprof-call-data-calls
- statprof-call-data-cum-samples
- statprof-call-data-self-samples
- statprof-call-data->stats
-
- statprof-stats-proc-name
- statprof-stats-%-time-in-proc
- statprof-stats-cum-secs-in-proc
- statprof-stats-self-secs-in-proc
- statprof-stats-calls
- statprof-stats-self-secs-per-call
- statprof-stats-cum-secs-per-call
-
- statprof-display
- statprof-display-anomolies
-
- statprof-fetch-stacks
- statprof-fetch-call-tree
-
- statprof
- with-statprof
-
- gcprof))
-
-
-;; This profiler tracks two numbers for every function called while
-;; it's active. It tracks the total number of calls, and the number
-;; of times the function was active when the sampler fired.
-;;
-;; Globally the profiler tracks the total time elapsed and the number
-;; of times the sampler was fired.
-;;
-;; Right now, this profiler is not per-thread and is not thread safe.
-
-(define accumulated-time #f) ; total so far.
-(define last-start-time #f) ; start-time when timer is active.
-(define sample-count #f) ; total count of sampler calls.
-(define sampling-frequency #f) ; in (seconds . microseconds)
-(define remaining-prof-time #f) ; time remaining when prof suspended.
-(define profile-level 0) ; for user start/stop nesting.
-(define %count-calls? #t) ; whether to catch apply-frame.
-(define gc-time-taken 0) ; gc time between statprof-start and
- ; statprof-stop.
-(define record-full-stacks? #f) ; if #t, stash away the stacks
- ; for later analysis.
-(define stacks '())
-
-;; procedure-data will be a hash where the key is the function object
-;; itself and the value is the data. The data will be a vector like
-;; this: #(name call-count cum-sample-count self-sample-count)
-(define procedure-data #f)
-
-;; If you change the call-data data structure, you need to also change
-;; sample-uncount-frame.
-(define (make-call-data proc call-count cum-sample-count self-sample-count)
- (vector proc call-count cum-sample-count self-sample-count))
-(define (call-data-proc cd) (vector-ref cd 0))
-(define (call-data-name cd) (procedure-name (call-data-proc cd)))
-(define (call-data-printable cd)
- (or (call-data-name cd)
- (with-output-to-string (lambda () (write (call-data-proc cd))))))
-(define (call-data-call-count cd) (vector-ref cd 1))
-(define (call-data-cum-sample-count cd) (vector-ref cd 2))
-(define (call-data-self-sample-count cd) (vector-ref cd 3))
-
-(define (inc-call-data-call-count! cd)
- (vector-set! cd 1 (1+ (vector-ref cd 1))))
-(define (inc-call-data-cum-sample-count! cd)
- (vector-set! cd 2 (1+ (vector-ref cd 2))))
-(define (inc-call-data-self-sample-count! cd)
- (vector-set! cd 3 (1+ (vector-ref cd 3))))
-
-(define-macro (accumulate-time stop-time)
- `(set! accumulated-time
- (+ accumulated-time 0.0 (- ,stop-time last-start-time))))
-
-(define (get-call-data proc)
- (let ((k (if (or (not (program? proc))
- (zero? (program-num-free-variables proc)))
- proc
- (program-objcode proc))))
- (or (hashq-ref procedure-data k)
- (let ((call-data (make-call-data proc 0 0 0)))
- (hashq-set! procedure-data k call-data)
- call-data))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; SIGPROF handler
-
-(define (sample-stack-procs stack)
- (let ((stacklen (stack-length stack))
- (hit-count-call? #f))
-
- (if record-full-stacks?
- (set! stacks (cons stack stacks)))
-
- (set! sample-count (+ sample-count 1))
- ;; Now accumulate stats for the whole stack.
- (let loop ((frame (stack-ref stack 0))
- (procs-seen (make-hash-table 13))
- (self #f))
- (cond
- ((not frame)
- (hash-fold
- (lambda (proc val accum)
- (inc-call-data-cum-sample-count!
- (get-call-data proc)))
- #f
- procs-seen)
- (and=> (and=> self get-call-data)
- inc-call-data-self-sample-count!))
- ((frame-procedure frame)
- => (lambda (proc)
- (cond
- ((eq? proc count-call)
- ;; We're not supposed to be sampling count-call and
- ;; its sub-functions, so loop again with a clean
- ;; slate.
- (set! hit-count-call? #t)
- (loop (frame-previous frame) (make-hash-table 13) #f))
- (else
- (hashq-set! procs-seen proc #t)
- (loop (frame-previous frame)
- procs-seen
- (or self proc))))))
- (else
- (loop (frame-previous frame) procs-seen self))))
- hit-count-call?))
-
-(define inside-profiler? #f)
-
-(define (profile-signal-handler sig)
- (set! inside-profiler? #t)
-
- ;; FIXME: with-statprof should be able to set an outer frame for the
- ;; stack cut
- (if (positive? profile-level)
- (let* ((stop-time (get-internal-run-time))
- ;; cut down to the signal handler. note that this will only
- ;; work if statprof.scm is compiled; otherwise we get
- ;; `eval' on the stack instead, because if it's not
- ;; compiled, profile-signal-handler is a thunk that
- ;; tail-calls eval. perhaps we should always compile the
- ;; signal handler instead...
- (stack (or (make-stack #t profile-signal-handler)
- (pk 'what! (make-stack #t))))
- (inside-apply-trap? (sample-stack-procs stack)))
-
- (if (not inside-apply-trap?)
- (begin
- ;; disabling here is just a little more efficient, but
- ;; not necessary given inside-profiler?. We can't just
- ;; disable unconditionally at the top of this function
- ;; and eliminate inside-profiler? because it seems to
- ;; confuse guile wrt re-enabling the trap when
- ;; count-call finishes.
- (if %count-calls?
- (set-vm-trace-level! (the-vm)
- (1- (vm-trace-level (the-vm)))))
- (accumulate-time stop-time)))
-
- (setitimer ITIMER_PROF
- 0 0
- (car sampling-frequency)
- (cdr sampling-frequency))
-
- (if (not inside-apply-trap?)
- (begin
- (set! last-start-time (get-internal-run-time))
- (if %count-calls?
- (set-vm-trace-level! (the-vm)
- (1+ (vm-trace-level (the-vm)))))))))
-
- (set! inside-profiler? #f))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Count total calls.
-
-(define (count-call frame)
- (if (not inside-profiler?)
- (begin
- (accumulate-time (get-internal-run-time))
-
- (and=> (frame-procedure frame)
- (lambda (proc)
- (inc-call-data-call-count!
- (get-call-data proc))))
-
- (set! last-start-time (get-internal-run-time)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (statprof-active?)
- "Returns @code{#t} if @code{statprof-start} has been called more times
-than @code{statprof-stop}, @code{#f} otherwise."
- (positive? profile-level))
-
-;; Do not call this from statprof internal functions -- user only.
-(define (statprof-start)
- "Start the profiler.@code{}"
- ;; After some head-scratching, I don't *think* I need to mask/unmask
- ;; signals here, but if I'm wrong, please let me know.
- (set! profile-level (+ profile-level 1))
- (if (= profile-level 1)
- (let* ((rpt remaining-prof-time)
- (use-rpt? (and rpt
- (or (positive? (car rpt))
- (positive? (cdr rpt))))))
- (set! remaining-prof-time #f)
- (set! last-start-time (get-internal-run-time))
- (set! gc-time-taken
- (cdr (assq 'gc-time-taken (gc-stats))))
- (if use-rpt?
- (setitimer ITIMER_PROF 0 0 (car rpt) (cdr rpt))
- (setitimer ITIMER_PROF
- 0 0
- (car sampling-frequency)
- (cdr sampling-frequency)))
- (if %count-calls?
- (add-hook! (vm-apply-hook (the-vm)) count-call))
- (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
- #t)))
-
-;; Do not call this from statprof internal functions -- user only.
-(define (statprof-stop)
- "Stop the profiler.@code{}"
- ;; After some head-scratching, I don't *think* I need to mask/unmask
- ;; signals here, but if I'm wrong, please let me know.
- (set! profile-level (- profile-level 1))
- (if (zero? profile-level)
- (begin
- (set! gc-time-taken
- (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
- (set-vm-trace-level! (the-vm) (1- (vm-trace-level (the-vm))))
- (if %count-calls?
- (remove-hook! (vm-apply-hook (the-vm)) count-call))
- ;; I believe that we need to do this before getting the time
- ;; (unless we want to make things even more complicated).
- (set! remaining-prof-time (setitimer ITIMER_PROF 0 0 0 0))
- (accumulate-time (get-internal-run-time))
- (set! last-start-time #f))))
-
-(define* (statprof-reset sample-seconds sample-microseconds count-calls?
- #:optional full-stacks?)
- "Reset the statprof sampler interval to @var{sample-seconds} and
-@var{sample-microseconds}. If @var{count-calls?} is true, arrange to
-instrument procedure calls as well as collecting statistical profiling
-data. If @var{full-stacks?} is true, collect all sampled stacks into a
-list for later analysis.
-
-Enables traps and debugging as necessary."
- (if (positive? profile-level)
- (error "Can't reset profiler while profiler is running."))
- (set! %count-calls? count-calls?)
- (set! accumulated-time 0)
- (set! last-start-time #f)
- (set! sample-count 0)
- (set! sampling-frequency (cons sample-seconds sample-microseconds))
- (set! remaining-prof-time #f)
- (set! procedure-data (make-hash-table 131))
- (set! record-full-stacks? full-stacks?)
- (set! stacks '())
- (sigaction SIGPROF profile-signal-handler)
- #t)
-
-(define (statprof-fold-call-data proc init)
- "Fold @var{proc} over the call-data accumulated by statprof. Cannot be
-called while statprof is active. @var{proc} should take two arguments,
-@code{(@var{call-data} @var{prior-result})}.
-
-Note that a given proc-name may appear multiple times, but if it does,
-it represents different functions with the same name."
- (if (positive? profile-level)
- (error "Can't call statprof-fold-called while profiler is running."))
-
- (hash-fold
- (lambda (key value prior-result)
- (proc value prior-result))
- init
- procedure-data))
-
-(define (statprof-proc-call-data proc)
- "Returns the call-data associated with @var{proc}, or @code{#f} if
-none is available."
- (if (positive? profile-level)
- (error "Can't call statprof-fold-called while profiler is running."))
-
- (hashq-ref procedure-data proc))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Stats
-
-(define (statprof-call-data->stats call-data)
- "Returns an object of type @code{statprof-stats}."
- ;; returns (vector proc-name
- ;; %-time-in-proc
- ;; cum-seconds-in-proc
- ;; self-seconds-in-proc
- ;; num-calls
- ;; self-secs-per-call
- ;; total-secs-per-call)
-
- (let* ((proc-name (call-data-printable call-data))
- (self-samples (call-data-self-sample-count call-data))
- (cum-samples (call-data-cum-sample-count call-data))
- (all-samples (statprof-sample-count))
- (secs-per-sample (/ (statprof-accumulated-time)
- (statprof-sample-count)))
- (num-calls (and %count-calls? (statprof-call-data-calls call-data))))
-
- (vector proc-name
- (* (/ self-samples all-samples) 100.0)
- (* cum-samples secs-per-sample 1.0)
- (* self-samples secs-per-sample 1.0)
- num-calls
- (and num-calls ;; maybe we only sampled in children
- (if (zero? self-samples) 0.0
- (/ (* self-samples secs-per-sample) 1.0 num-calls)))
- (and num-calls ;; cum-samples must be positive
- (/ (* cum-samples secs-per-sample)
- 1.0
- ;; num-calls might be 0 if we entered statprof during the
- ;; dynamic extent of the call
- (max num-calls 1))))))
-
-(define (statprof-stats-proc-name stats) (vector-ref stats 0))
-(define (statprof-stats-%-time-in-proc stats) (vector-ref stats 1))
-(define (statprof-stats-cum-secs-in-proc stats) (vector-ref stats 2))
-(define (statprof-stats-self-secs-in-proc stats) (vector-ref stats 3))
-(define (statprof-stats-calls stats) (vector-ref stats 4))
-(define (statprof-stats-self-secs-per-call stats) (vector-ref stats 5))
-(define (statprof-stats-cum-secs-per-call stats) (vector-ref stats 6))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (stats-sorter x y)
- (let ((diff (- (statprof-stats-self-secs-in-proc x)
- (statprof-stats-self-secs-in-proc y))))
- (positive?
- (if (= diff 0)
- (- (statprof-stats-cum-secs-in-proc x)
- (statprof-stats-cum-secs-in-proc y))
- diff))))
-
-(define (statprof-display . port)
- "Displays a gprof-like summary of the statistics collected. Unless an
-optional @var{port} argument is passed, uses the current output port."
- (if (null? port) (set! port (current-output-port)))
-
- (cond
- ((zero? (statprof-sample-count))
- (format port "No samples recorded.\n"))
- (else
- (let* ((stats-list (statprof-fold-call-data
- (lambda (data prior-value)
- (cons (statprof-call-data->stats data)
- prior-value))
- '()))
- (sorted-stats (sort stats-list stats-sorter)))
-
- (define (display-stats-line stats)
- (if %count-calls?
- (format port "~6,2f ~9,2f ~9,2f ~7d ~8,2f ~8,2f "
- (statprof-stats-%-time-in-proc stats)
- (statprof-stats-cum-secs-in-proc stats)
- (statprof-stats-self-secs-in-proc stats)
- (statprof-stats-calls stats)
- (* 1000 (statprof-stats-self-secs-per-call stats))
- (* 1000 (statprof-stats-cum-secs-per-call stats)))
- (format port "~6,2f ~9,2f ~9,2f "
- (statprof-stats-%-time-in-proc stats)
- (statprof-stats-cum-secs-in-proc stats)
- (statprof-stats-self-secs-in-proc stats)))
- (display (statprof-stats-proc-name stats) port)
- (newline port))
-
- (if %count-calls?
- (begin
- (format port "~5a ~10a ~7a ~8a ~8a ~8a ~8@a\n"
- "% " "cumulative" "self" "" "self" "total" "")
- (format port "~5a ~9a ~8a ~8a ~8a ~8a ~8@a\n"
- "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "name"))
- (begin
- (format port "~5a ~10a ~7a ~8@a\n"
- "%" "cumulative" "self" "")
- (format port "~5a ~10a ~7a ~8@a\n"
- "time" "seconds" "seconds" "name")))
-
- (for-each display-stats-line sorted-stats)
-
- (display "---\n" port)
- (simple-format #t "Sample count: ~A\n" (statprof-sample-count))
- (simple-format #t "Total time: ~A seconds (~A seconds in GC)\n"
- (statprof-accumulated-time)
- (/ gc-time-taken 1.0 internal-time-units-per-second))))))
-
-(define (statprof-display-anomolies)
- "A sanity check that attempts to detect anomolies in statprof's
-statistics.@code{}"
- (statprof-fold-call-data
- (lambda (data prior-value)
- (if (and %count-calls?
- (zero? (call-data-call-count data))
- (positive? (call-data-cum-sample-count data)))
- (simple-format #t
- "==[~A ~A ~A]\n"
- (call-data-name data)
- (call-data-call-count data)
- (call-data-cum-sample-count data))))
- #f)
- (simple-format #t "Total time: ~A\n" (statprof-accumulated-time))
- (simple-format #t "Sample count: ~A\n" (statprof-sample-count)))
-
-(define (statprof-accumulated-time)
- "Returns the time accumulated during the last statprof run.@code{}"
- (if (positive? profile-level)
- (error "Can't get accumulated time while profiler is running."))
- (/ accumulated-time internal-time-units-per-second))
-
-(define (statprof-sample-count)
- "Returns the number of samples taken during the last statprof run.@code{}"
- (if (positive? profile-level)
- (error "Can't get accumulated time while profiler is running."))
- sample-count)
-
-(define statprof-call-data-name call-data-name)
-(define statprof-call-data-calls call-data-call-count)
-(define statprof-call-data-cum-samples call-data-cum-sample-count)
-(define statprof-call-data-self-samples call-data-self-sample-count)
-
-(define (statprof-fetch-stacks)
- "Returns a list of stacks, as they were captured since the last call
-to @code{statprof-reset}.
-
-Note that stacks are only collected if the @var{full-stacks?} argument
-to @code{statprof-reset} is true."
- stacks)
-
-(define procedure=?
- (lambda (a b)
- (cond
- ((eq? a b))
- ((and (program? a) (program? b))
- (eq? (program-objcode a) (program-objcode b)))
- (else
- #f))))
-
-;; tree ::= (car n . tree*)
-
-(define (lists->trees lists equal?)
- (let lp ((in lists) (n-terminal 0) (tails '()))
- (cond
- ((null? in)
- (let ((trees (map (lambda (tail)
- (cons (car tail)
- (lists->trees (cdr tail) equal?)))
- tails)))
- (cons (apply + n-terminal (map cadr trees))
- (sort trees
- (lambda (a b) (> (cadr a) (cadr b)))))))
- ((null? (car in))
- (lp (cdr in) (1+ n-terminal) tails))
- ((find (lambda (x) (equal? (car x) (caar in)))
- tails)
- => (lambda (tail)
- (lp (cdr in)
- n-terminal
- (assq-set! tails
- (car tail)
- (cons (cdar in) (cdr tail))))))
- (else
- (lp (cdr in)
- n-terminal
- (acons (caar in) (list (cdar in)) tails))))))
-
-(define (stack->procedures stack)
- (filter identity
- (unfold-right (lambda (x) (not x))
- frame-procedure
- frame-previous
- (stack-ref stack 0))))
-
-(define (statprof-fetch-call-tree)
- "Return a call tree for the previous statprof run.
-
-The return value is a list of nodes, each of which is of the type:
-@code
- node ::= (@var{proc} @var{count} . @var{nodes})
-@end code"
- (cons #t (lists->trees (map stack->procedures stacks) procedure=?)))
-
-(define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f)
- (full-stacks? #f))
- "Profile the execution of @var{thunk}, and return its return values.
-
-The stack will be sampled @var{hz} times per second, and the thunk
-itself will be called @var{loop} times.
-
-If @var{count-calls?} is true, all procedure calls will be recorded. This
-operation is somewhat expensive.
-
-If @var{full-stacks?} is true, at each sample, statprof will store away the
-whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
-@code{statprof-fetch-call-tree} to retrieve the last-stored stacks."
- (dynamic-wind
- (lambda ()
- (statprof-reset (inexact->exact (floor (/ 1 hz)))
- (inexact->exact (* 1e6 (- (/ 1 hz)
- (floor (/ 1 hz)))))
- count-calls?
- full-stacks?)
- (statprof-start))
- (lambda ()
- (let lp ((i loop)
- (result '()))
- (if (zero? i)
- (apply values result)
- (call-with-values thunk
- (lambda result
- (lp (1- i) result))))))
- (lambda ()
- (statprof-stop)
- (statprof-display)
- (set! procedure-data #f))))
-
-(define-macro (with-statprof . args)
- "Profile the expressions in the body, and return the body's return values.
-
-Keyword arguments:
-
-@table @code
-@item #:loop
-Execute the body @var{loop} number of times, or @code{#f} for no looping
-
-default: @code{#f}
-@item #:hz
-Sampling rate
-
-default: @code{20}
-@item #:count-calls?
-Whether to instrument each function call (expensive)
-
-default: @code{#f}
-@item #:full-stacks?
-Whether to collect away all sampled stacks into a list
-
-default: @code{#f}
-@end table"
- (define (kw-arg-ref kw args def)
- (cond
- ((null? args) (error "Invalid macro body"))
- ((keyword? (car args))
- (if (eq? (car args) kw)
- (cadr args)
- (kw-arg-ref kw (cddr args) def)))
- ((eq? kw #f def) ;; asking for the body
- args)
- (else def))) ;; kw not found
- `((@ (statprof) statprof)
- (lambda () ,@(kw-arg-ref #f args #f))
- #:loop ,(kw-arg-ref #:loop args 1)
- #:hz ,(kw-arg-ref #:hz args 100)
- #:count-calls? ,(kw-arg-ref #:count-calls? args #f)
- #:full-stacks? ,(kw-arg-ref #:full-stacks? args #f)))
-
-(define* (gcprof thunk #:key (loop 1) (full-stacks? #f))
- "Do an allocation profile of the execution of @var{thunk}.
-
-The stack will be sampled soon after every garbage collection, yielding
-an approximate idea of what is causing allocation in your program.
-
-Since GC does not occur very frequently, you may need to use the
-@var{loop} parameter, to cause @var{thunk} to be called @var{loop}
-times.
-
-If @var{full-stacks?} is true, at each sample, statprof will store away the
-whole call tree, for later analysis. Use @code{statprof-fetch-stacks} or
-@code{statprof-fetch-call-tree} to retrieve the last-stored stacks."
-
- (define (reset)
- (if (positive? profile-level)
- (error "Can't reset profiler while profiler is running."))
- (set! accumulated-time 0)
- (set! last-start-time #f)
- (set! sample-count 0)
- (set! %count-calls? #f)
- (set! procedure-data (make-hash-table 131))
- (set! record-full-stacks? full-stacks?)
- (set! stacks '()))
-
- (define (gc-callback)
- (cond
- (inside-profiler?)
- (else
- (set! inside-profiler? #t)
-
- ;; FIXME: should be able to set an outer frame for the stack cut
- (let ((stop-time (get-internal-run-time))
- ;; Cut down to gc-callback, and then one before (the
- ;; after-gc async). See the note in profile-signal-handler
- ;; also.
- (stack (or (make-stack #t gc-callback 0 1)
- (pk 'what! (make-stack #t)))))
- (sample-stack-procs stack)
- (accumulate-time stop-time)
- (set! last-start-time (get-internal-run-time)))
-
- (set! inside-profiler? #f))))
-
- (define (start)
- (set! profile-level (+ profile-level 1))
- (if (= profile-level 1)
- (begin
- (set! remaining-prof-time #f)
- (set! last-start-time (get-internal-run-time))
- (set! gc-time-taken (cdr (assq 'gc-time-taken (gc-stats))))
- (add-hook! after-gc-hook gc-callback)
- (set-vm-trace-level! (the-vm) (1+ (vm-trace-level (the-vm))))
- #t)))
-
- (define (stop)
- (set! profile-level (- profile-level 1))
- (if (zero? profile-level)
- (begin
- (set! gc-time-taken
- (- (cdr (assq 'gc-time-taken (gc-stats))) gc-time-taken))
- (remove-hook! after-gc-hook gc-callback)
- (accumulate-time (get-internal-run-time))
- (set! last-start-time #f))))
-
- (dynamic-wind
- (lambda ()
- (reset)
- (start))
- (lambda ()
- (let lp ((i loop))
- (if (not (zero? i))
- (begin
- (thunk)
- (lp (1- i))))))
- (lambda ()
- (stop)
- (statprof-display)
- (set! procedure-data #f))))
+;;;; (statprof) -- a statistical profiler for Guile
+;;;; -*-scheme-*-
+;;;;
+;;;; Copyright (C) 2009, 2010, 2011, 2013-2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com>
+;;;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
+;;;;
+;;;; 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:
+;;;
+;;; @code{(statprof)} is a statistical profiler for Guile.
+;;;
+;;; A simple use of statprof would look like this:
+;;;
+;;; @example
+;;; (statprof (lambda () (do-something))
+;;; #:hz 100
+;;; #:count-calls? #t)
+;;; @end example
+;;;
+;;; This would run the thunk with statistical profiling, finally
+;;; displaying a gprof flat-style table of statistics which could
+;;; something like this:
+;;;
+;;; @example
+;;; % cumulative self self total
+;;; time seconds seconds calls ms/call ms/call name
+;;; 35.29 0.23 0.23 2002 0.11 0.11 -
+;;; 23.53 0.15 0.15 2001 0.08 0.08 positive?
+;;; 23.53 0.15 0.15 2000 0.08 0.08 +
+;;; 11.76 0.23 0.08 2000 0.04 0.11 do-nothing
+;;; 5.88 0.64 0.04 2001 0.02 0.32 loop
+;;; 0.00 0.15 0.00 1 0.00 150.59 do-something
+;;; ...
+;;; @end example
+;;;
+;;; All of the numerical data with the exception of the calls column is
+;;; statistically approximate. In the following column descriptions, and
+;;; in all of statprof, "time" refers to execution time (both user and
+;;; system), not wall clock time.
+;;;
+;;; @table @asis
+;;; @item % time
+;;; The percent of the time spent inside the procedure itself
+;;; (not counting children).
+;;; @item cumulative seconds
+;;; The total number of seconds spent in the procedure, including
+;;; children.
+;;; @item self seconds
+;;; The total number of seconds spent in the procedure itself (not counting
+;;; children).
+;;; @item calls
+;;; The total number of times the procedure was called.
+;;; @item self ms/call
+;;; The average time taken by the procedure itself on each call, in ms.
+;;; @item total ms/call
+;;; The average time taken by each call to the procedure, including time
+;;; spent in child functions.
+;;; @item name
+;;; The name of the procedure.
+;;; @end table
+;;;
+;;; The profiler uses @code{eq?} and the procedure object itself to
+;;; identify the procedures, so it won't confuse different procedures with
+;;; the same name. They will show up as two different rows in the output.
+;;;
+;;; Right now the profiler is quite simplistic. I cannot provide
+;;; call-graphs or other higher level information. What you see in the
+;;; table is pretty much all there is. Patches are welcome :-)
+;;;
+;;; @section Implementation notes
+;;;
+;;; The profiler works by setting the unix profiling signal
+;;; @code{ITIMER_PROF} to go off after the interval you define in the call
+;;; to @code{statprof-reset}. When the signal fires, a sampling routine is
+;;; run which looks at the current procedure that's executing, and then
+;;; crawls up the stack, and for each procedure encountered, increments
+;;; that procedure's sample count. Note that if a procedure is encountered
+;;; multiple times on a given stack, it is only counted once. After the
+;;; sampling is complete, the profiler resets profiling timer to fire
+;;; again after the appropriate interval.
+;;;
+;;; Meanwhile, the profiler keeps track, via @code{get-internal-run-time},
+;;; how much CPU time (system and user -- which is also what
+;;; @code{ITIMER_PROF} tracks), has elapsed while code has been executing
+;;; within a statprof-start/stop block.
+;;;
+;;; The profiler also tries to avoid counting or timing its own code as
+;;; much as possible.
+;;;
+;;; Code:
+
+(define-module (statprof)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:autoload (ice-9 format) (format)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module (system vm debug)
+ #:use-module (system vm program)
+ #:export (statprof-active?
+ statprof-start
+ statprof-stop
+ statprof-reset
+
+ statprof-accumulated-time
+ statprof-sample-count
+ statprof-fold-call-data
+ statprof-proc-call-data
+ statprof-call-data-name
+ statprof-call-data-calls
+ statprof-call-data-cum-samples
+ statprof-call-data-self-samples
+ statprof-call-data->stats
+
+ statprof-stats-proc-name
+ statprof-stats-proc-source
+ statprof-stats-%-time-in-proc
+ statprof-stats-cum-secs-in-proc
+ statprof-stats-self-secs-in-proc
+ statprof-stats-calls
+ statprof-stats-self-secs-per-call
+ statprof-stats-cum-secs-per-call
+
+ statprof-display
+ statprof-display-anomalies
+ statprof-display-anomolies ; Deprecated spelling.
+
+ statprof-fetch-stacks
+ statprof-fetch-call-tree
+
+ statprof
+ with-statprof
+
+ gcprof))
+
+
+;;; ~ Implementation notes ~
+;;;
+;;; Statprof can be divided into two pieces: data collection and data
+;;; analysis.
+;;;
+;;; The data collection runs concurrently with the program, and is
+;;; designed to be as cheap as possible. The main data collection
+;;; instrument is the stack sampler, driven by SIGPROF signals that are
+;;; scheduled with periodic setitimer calls. The stack sampler simply
+;;; looks at every frame on the stack, and writes a representation of
+;;; the frame's procedure into a growable buffer.
+;;;
+;;; For most frames, this representation is the instruction pointer of
+;;; that frame, because it's cheap to get and you can map from
+;;; instruction pointer to procedure fairly cheaply. This won't
+;;; distinguish between different closures which share the same code,
+;;; but that is usually what we want anyway.
+;;;
+;;; One case in which we do want to distinguish closures is the case of
+;;; primitive procedures. If slot 0 in the frame is a primitive
+;;; procedure, we record the procedure's name into the buffer instead of
+;;; the IP. It's fairly cheap to check whether a value is a primitive
+;;; procedure, and then get its name, as its name is stored in the
+;;; closure data. Calling procedure-name in the stack sampler isn't
+;;; something you want to do for other kinds of procedures, though, as
+;;; that involves grovelling the debug information.
+;;;
+;;; The other part of data collection is the exact call counter, which
+;;; uses the VM's "apply" hook to record each procedure call.
+;;; Naturally, this is quite expensive, and it is off by default.
+;;; Running code at every procedure call effectively penalizes procedure
+;;; calls. Still, it's useful sometimes. If the profiler state has a
+;;; call-counts table, then calls will be counted. As with the stack
+;;; counter, usually the key in the hash table is the code pointer of
+;;; the procedure being called, except for primitive procedures, in
+;;; which case it is the name of the primitive. The call counter can
+;;; also see calls of non-programs, for example in the case of
+;;; applicable structs. In that case the key is the procedure itself.
+;;;
+;;; After collection is finished, the data can be analyzed. The first
+;;; step is usually to run over the stack traces, tabulating sample
+;;; counts by procedure; the stack-samples->procedure-data does that.
+;;; The result of stack-samples->procedure-data is a hash table mapping
+;;; procedures to "call data" records. The call data values are exposed
+;;; to users via the statprof-fold-call-data procedure.
+;;;
+;;; Usually all the analysis is triggered by calling statprof-display,
+;;; or having the statprof procedure call it for you.
+;;;
+;;; The other thing we can do is to look at the stacks themselves, for
+;;; example via statprof-fetch-call-tree.
+;;;
+
+;;; ~ Threads and state ~
+;;;
+;;; The state of the profiler is contained in a <state> record, which is
+;;; bound to a thread-local parameter. The accurate call counter uses
+;;; the VM apply hook, which is also local to the current thread, so all
+;;; is good there.
+;;;
+;;; The problem comes in the statistical stack sampler's use of
+;;; `setitimer' and SIGPROF. The timer manipulated by setitimer is a
+;;; whole-process timer, so it decrements as other threads execute,
+;;; which is the wrong thing if you want to profile just one thread. On
+;;; the other hand, SIGPROF is delivered to the process as a whole,
+;;; which is fine given Guile's signal-handling thread, but then only
+;;; delivered to the thread running statprof, which isn't the right
+;;; thing if you want to profile the whole system.
+;;;
+;;; The summary is that statprof works more or less well as a per-thread
+;;; profiler if no other threads are running on their own when
+;;; profiling. If the other threads are running on behalf of the thread
+;;; being profiled (as via futures or parallel marking) things still
+;;; mostly work as expected. You can run statprof in one thread,
+;;; finish, and then run statprof in another thread, and the profile
+;;; runs won't affect each other. But if you want true per-thread
+;;; profiles when other things are happening in the process, including
+;;; other statprof runs, or whole-process profiles with per-thread
+;;; breakdowns, the use of setitimer currently prevents that.
+;;;
+;;; The solution would be to switch to POSIX.1-2001's timer_create(2),
+;;; and to add some more threading-related API to statprof. Some other
+;;; day.
+;;;
+
+(define-record-type <state>
+ (make-state accumulated-time last-start-time sample-count
+ sampling-period remaining-prof-time profile-level
+ call-counts gc-time-taken inside-profiler?
+ prev-sigprof-handler outer-cut buffer buffer-pos)
+ state?
+ ;; Total time so far.
+ (accumulated-time accumulated-time set-accumulated-time!)
+ ;; Start-time when timer is active.
+ (last-start-time last-start-time set-last-start-time!)
+ ;; Total count of sampler calls.
+ (sample-count sample-count set-sample-count!)
+ ;; Microseconds.
+ (sampling-period sampling-period set-sampling-period!)
+ ;; Time remaining when prof suspended.
+ (remaining-prof-time remaining-prof-time set-remaining-prof-time!)
+ ;; For user start/stop nesting.
+ (profile-level profile-level set-profile-level!)
+ ;; Hash table mapping ip -> call count, or #f if not counting calls.
+ (call-counts call-counts set-call-counts!)
+ ;; GC time between statprof-start and statprof-stop.
+ (gc-time-taken gc-time-taken set-gc-time-taken!)
+ ;; True if we are inside the profiler.
+ (inside-profiler? inside-profiler? set-inside-profiler?!)
+ ;; Previous sigprof handler.
+ (prev-sigprof-handler prev-sigprof-handler set-prev-sigprof-handler!)
+ ;; Outer stack cut, or 0.
+ (outer-cut outer-cut)
+ ;; Stack samples.
+ (buffer buffer set-buffer!)
+ (buffer-pos buffer-pos set-buffer-pos!))
+
+(define profiler-state (make-parameter #f))
+
+(define (fresh-buffer)
+ (make-vector 1024 #f))
+
+(define (expand-buffer buf)
+ (let* ((size (vector-length buf))
+ (new (make-vector (* size 2) #f)))
+ (vector-move-left! buf 0 (vector-length buf) new 0)
+ new))
+
+(define* (fresh-profiler-state #:key (count-calls? #f)
+ (sampling-period 10000)
+ (outer-cut 0))
+ (make-state 0 #f 0
+ sampling-period 0 0
+ (and count-calls? (make-hash-table)) 0 #f
+ #f outer-cut (fresh-buffer) 0))
+
+(define (ensure-profiler-state)
+ (or (profiler-state)
+ (let ((state (fresh-profiler-state)))
+ (profiler-state state)
+ state)))
+
+(define (existing-profiler-state)
+ (or (profiler-state)
+ (error "expected there to be a profiler state")))
+
+(define (accumulate-time state stop-time)
+ (set-accumulated-time! state
+ (+ (accumulated-time state)
+ (- stop-time (last-start-time state)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SIGPROF handler
+
+(define (sample-stack-procs state stack)
+ (set-sample-count! state (+ (sample-count state) 1))
+
+ (let lp ((frame (stack-ref stack 0))
+ (len (stack-length stack))
+ (buffer (buffer state))
+ (pos (buffer-pos state)))
+ (define (write-sample sample)
+ (vector-set! buffer pos sample))
+ (define (continue pos)
+ (lp (frame-previous frame) (1- len) buffer pos))
+ (define (write-sample-and-continue sample)
+ (write-sample sample)
+ (continue (1+ pos)))
+ (cond
+ ((= pos (vector-length buffer))
+ (lp frame len (expand-buffer buffer) pos))
+ ((or (zero? len) (not frame))
+ (write-sample #f)
+ (set-buffer! state buffer)
+ (set-buffer-pos! state (1+ pos)))
+ (else
+ (let ((proc (frame-procedure frame)))
+ (write-sample-and-continue (if (primitive? proc)
+ (procedure-name proc)
+ (frame-instruction-pointer frame))))))))
+
+(define (reset-sigprof-timer usecs)
+ ;; Guile's setitimer binding is terrible.
+ (let ((prev (setitimer ITIMER_PROF 0 0 0 usecs)))
+ (+ (* (caadr prev) #e1e6) (cdadr prev))))
+
+(define profile-signal-handler
+ (let ()
+ (define (profile-signal-handler sig)
+ (define state (existing-profiler-state))
+
+ (set-inside-profiler?! state #t)
+
+ (when (positive? (profile-level state))
+ (let* ((stop-time (get-internal-run-time))
+ ;; Cut down to the signal handler. Note that this will
+ ;; only work if statprof.scm is compiled; otherwise we
+ ;; get `eval' on the stack instead, because if it's not
+ ;; compiled, profile-signal-handler is a thunk that
+ ;; tail-calls eval. For the same reason we define the
+ ;; handler in an inner letrec, so that the compiler sees
+ ;; the inner reference to profile-signal-handler as the
+ ;; same as the procedure, and therefore keeps slot 0
+ ;; alive. Nastiness, that.
+ (stack
+ (or (make-stack #t profile-signal-handler (outer-cut state))
+ (pk 'what! (make-stack #t)))))
+
+ (sample-stack-procs state stack)
+ (accumulate-time state stop-time)
+ (set-last-start-time! state (get-internal-run-time))
+
+ (reset-sigprof-timer (sampling-period state))))
+
+ (set-inside-profiler?! state #f))
+ profile-signal-handler))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Count total calls.
+
+(define (count-call frame)
+ (let ((state (existing-profiler-state)))
+ (unless (inside-profiler? state)
+ (accumulate-time state (get-internal-run-time))
+
+ (let* ((key (let ((proc (frame-procedure frame)))
+ (cond
+ ((primitive? proc) (procedure-name proc))
+ ((program? proc) (program-code proc))
+ (else proc))))
+ (handle (hashv-create-handle! (call-counts state) key 0)))
+ (set-cdr! handle (1+ (cdr handle))))
+
+ (set-last-start-time! state (get-internal-run-time)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (statprof-active?)
+ "Returns @code{#t} if @code{statprof-start} has been called more times
+than @code{statprof-stop}, @code{#f} otherwise."
+ (define state (profiler-state))
+ (and state (positive? (profile-level state))))
+
+;; Do not call this from statprof internal functions -- user only.
+(define* (statprof-start #:optional (state (ensure-profiler-state)))
+ "Start the profiler.@code{}"
+ ;; After some head-scratching, I don't *think* I need to mask/unmask
+ ;; signals here, but if I'm wrong, please let me know.
+ (set-profile-level! state (+ (profile-level state) 1))
+ (when (= (profile-level state) 1)
+ (let ((rpt (remaining-prof-time state)))
+ (set-remaining-prof-time! state 0)
+ ;; FIXME: Use per-thread run time.
+ (set-last-start-time! state (get-internal-run-time))
+ (set-gc-time-taken! state (assq-ref (gc-stats) 'gc-time-taken))
+ (let ((prev (sigaction SIGPROF profile-signal-handler)))
+ (set-prev-sigprof-handler! state (car prev)))
+ (reset-sigprof-timer (if (zero? rpt) (sampling-period state) rpt))
+ (when (call-counts state)
+ (add-hook! (vm-apply-hook) count-call)
+ (set-vm-trace-level! (1+ (vm-trace-level))))
+ #t)))
+
+;; Do not call this from statprof internal functions -- user only.
+(define* (statprof-stop #:optional (state (ensure-profiler-state)))
+ "Stop the profiler.@code{}"
+ ;; After some head-scratching, I don't *think* I need to mask/unmask
+ ;; signals here, but if I'm wrong, please let me know.
+ (set-profile-level! state (- (profile-level state) 1))
+ (when (zero? (profile-level state))
+ (when (call-counts state)
+ (set-vm-trace-level! (1- (vm-trace-level)))
+ (remove-hook! (vm-apply-hook) count-call))
+ (set-gc-time-taken! state
+ (- (assq-ref (gc-stats) 'gc-time-taken)
+ (gc-time-taken state)))
+ ;; I believe that we need to do this before getting the time
+ ;; (unless we want to make things even more complicated).
+ (set-remaining-prof-time! state (reset-sigprof-timer 0))
+ (accumulate-time state (get-internal-run-time))
+ (sigaction SIGPROF (prev-sigprof-handler state))
+ (set-prev-sigprof-handler! state #f)
+ (set-last-start-time! state #f)))
+
+(define* (statprof-reset sample-seconds sample-microseconds count-calls?
+ #:optional full-stacks?)
+ "Reset the statprof sampler interval to @var{sample-seconds} and
+@var{sample-microseconds}. If @var{count-calls?} is true, arrange to
+instrument procedure calls as well as collecting statistical profiling
+data. (The optional @var{full-stacks?} argument is deprecated; statprof
+always collects full stacks.)"
+ (when (statprof-active?)
+ (error "Can't reset profiler while profiler is running."))
+ (profiler-state
+ (fresh-profiler-state #:count-calls? count-calls?
+ #:sampling-period (+ (* sample-seconds #e1e6)
+ sample-microseconds)))
+ (values))
+
+(define-record-type call-data
+ (make-call-data name printable source
+ call-count cum-sample-count self-sample-count)
+ call-data?
+ (name call-data-name)
+ (printable call-data-printable)
+ (source call-data-source)
+ (call-count call-data-call-count set-call-data-call-count!)
+ (cum-sample-count call-data-cum-sample-count set-call-data-cum-sample-count!)
+ (self-sample-count call-data-self-sample-count set-call-data-self-sample-count!))
+
+(define (source->string source)
+ (format #f "~a:~a:~a"
+ (or (source-file source) "<current input>")
+ (source-line-for-user source)
+ (source-column source)))
+
+(define (program-debug-info-printable pdi)
+ (let* ((addr (program-debug-info-addr pdi))
+ (name (or (and=> (program-debug-info-name pdi) symbol->string)
+ (string-append "#x" (number->string addr 16))))
+ (loc (and=> (find-source-for-addr addr) source->string)))
+ (if loc
+ (string-append name " at " loc)
+ name)))
+
+(define (addr->pdi addr cache)
+ (cond
+ ((hashv-get-handle cache addr) => cdr)
+ (else
+ (let ((data (find-program-debug-info addr)))
+ (hashv-set! cache addr data)
+ data))))
+
+(define (addr->printable addr pdi)
+ (or (and=> (and=> pdi program-debug-info-name) symbol->string)
+ (string-append "anon #x" (number->string addr 16))))
+
+(define (inc-call-data-cum-sample-count! cd)
+ (set-call-data-cum-sample-count! cd (1+ (call-data-cum-sample-count cd))))
+(define (inc-call-data-self-sample-count! cd)
+ (set-call-data-self-sample-count! cd (1+ (call-data-self-sample-count cd))))
+
+(define (stack-samples->procedure-data state)
+ (let ((table (make-hash-table))
+ (addr-cache (make-hash-table))
+ (call-counts (call-counts state))
+ (buffer (buffer state))
+ (len (buffer-pos state)))
+ (define (addr->call-data addr)
+ (let* ((pdi (addr->pdi addr addr-cache))
+ (entry (if pdi (program-debug-info-addr pdi) addr)))
+ (or (hashv-ref table entry)
+ (let ((data (make-call-data (and=> pdi program-debug-info-name)
+ (addr->printable entry pdi)
+ (find-source-for-addr entry)
+ (and call-counts
+ (hashv-ref call-counts entry))
+ 0
+ 0)))
+ (hashv-set! table entry data)
+ data))))
+
+ (define (callee->call-data callee)
+ (cond
+ ((number? callee) (addr->call-data callee))
+ ((hashv-ref table callee))
+ (else
+ (let ((data (make-call-data
+ (cond ((procedure? callee) (procedure-name callee))
+ ;; a primitive
+ ((symbol? callee) callee)
+ (else #f))
+ (with-output-to-string (lambda () (write callee)))
+ #f
+ (and call-counts (hashv-ref call-counts callee))
+ 0
+ 0)))
+ (hashv-set! table callee data)
+ data))))
+
+ (when call-counts
+ (hash-for-each (lambda (callee count)
+ (callee->call-data callee))
+ call-counts))
+
+ (let visit-stacks ((pos 0))
+ (cond
+ ((< pos len)
+ ;; FIXME: if we are counting all procedure calls, and
+ ;; count-call is on the stack, we need to not count the part
+ ;; of the stack that is within count-call.
+ (inc-call-data-self-sample-count!
+ (callee->call-data (vector-ref buffer pos)))
+ (let visit-stack ((pos pos))
+ (cond
+ ((vector-ref buffer pos)
+ => (lambda (callee)
+ (inc-call-data-cum-sample-count! (callee->call-data callee))
+ (visit-stack (1+ pos))))
+ (else
+ (visit-stacks (1+ pos))))))
+ (else table)))))
+
+(define (stack-samples->callee-lists state)
+ (let ((buffer (buffer state))
+ (len (buffer-pos state)))
+ (let visit-stacks ((pos 0) (out '()))
+ (cond
+ ((< pos len)
+ ;; FIXME: if we are counting all procedure calls, and
+ ;; count-call is on the stack, we need to not count the part
+ ;; of the stack that is within count-call.
+ (let visit-stack ((pos pos) (stack '()))
+ (cond
+ ((vector-ref buffer pos)
+ => (lambda (callee)
+ (visit-stack (1+ pos) (cons callee stack))))
+ (else
+ (visit-stacks (1+ pos) (cons (reverse stack) out))))))
+ (else (reverse out))))))
+
+(define* (statprof-fold-call-data proc init #:optional
+ (state (existing-profiler-state)))
+ "Fold @var{proc} over the call-data accumulated by statprof. Cannot be
+called while statprof is active. @var{proc} should take two arguments,
+@code{(@var{call-data} @var{prior-result})}.
+
+Note that a given proc-name may appear multiple times, but if it does,
+it represents different functions with the same name."
+ (when (statprof-active?)
+ (error "Can't call statprof-fold-call-data while profiler is running."))
+ (hash-fold
+ (lambda (key value prior-result)
+ (proc value prior-result))
+ init
+ (stack-samples->procedure-data state)))
+
+(define* (statprof-proc-call-data proc #:optional
+ (state (existing-profiler-state)))
+ "Returns the call-data associated with @var{proc}, or @code{#f} if
+none is available."
+ (when (statprof-active?)
+ (error "Can't call statprof-proc-call-data while profiler is running."))
+ (hashv-ref (stack-samples->procedure-data state)
+ (cond
+ ((primitive? proc) (procedure-name proc))
+ ((program? proc) (program-code proc))
+ (else (program-code proc)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Stats
+
+(define-record-type stats
+ (make-stats proc-name proc-source
+ %-time-in-proc cum-secs-in-proc self-secs-in-proc
+ calls self-secs-per-call cum-secs-per-call)
+ stats?
+ (proc-name statprof-stats-proc-name)
+ (proc-source statprof-stats-proc-source)
+ (%-time-in-proc statprof-stats-%-time-in-proc)
+ (cum-secs-in-proc statprof-stats-cum-secs-in-proc)
+ (self-secs-in-proc statprof-stats-self-secs-in-proc)
+ (calls statprof-stats-calls)
+ (self-secs-per-call statprof-stats-self-secs-per-call)
+ (cum-secs-per-call statprof-stats-cum-secs-per-call))
+
+(define (statprof-call-data->stats call-data)
+ "Returns an object of type @code{statprof-stats}."
+ (define state (existing-profiler-state))
+
+ (let* ((proc-name (call-data-name call-data))
+ (proc-source (and=> (call-data-source call-data) source->string))
+ (self-samples (call-data-self-sample-count call-data))
+ (cum-samples (call-data-cum-sample-count call-data))
+ (all-samples (statprof-sample-count state))
+ (secs-per-sample (/ (statprof-accumulated-time state)
+ (statprof-sample-count state)))
+ (num-calls (and (call-counts state)
+ (statprof-call-data-calls call-data))))
+
+ (make-stats (or proc-name
+ ;; If there is no name and no source, fall back to
+ ;; printable.
+ (and (not proc-source) (call-data-printable call-data)))
+ proc-source
+ (* (/ self-samples all-samples) 100.0)
+ (* cum-samples secs-per-sample 1.0)
+ (* self-samples secs-per-sample 1.0)
+ num-calls
+ (and num-calls ;; maybe we only sampled in children
+ (if (zero? self-samples) 0.0
+ (/ (* self-samples secs-per-sample) 1.0 num-calls)))
+ (and num-calls ;; cum-samples must be positive
+ (/ (* cum-samples secs-per-sample)
+ 1.0
+ ;; num-calls might be 0 if we entered statprof during the
+ ;; dynamic extent of the call
+ (max num-calls 1))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (stats-sorter x y)
+ (let ((diff (- (statprof-stats-self-secs-in-proc x)
+ (statprof-stats-self-secs-in-proc y))))
+ (positive?
+ (if (= diff 0)
+ (- (statprof-stats-cum-secs-in-proc x)
+ (statprof-stats-cum-secs-in-proc y))
+ diff))))
+
+(define* (statprof-display #:optional (port (current-output-port))
+ (state (existing-profiler-state)))
+ "Displays a gprof-like summary of the statistics collected. Unless an
+optional @var{port} argument is passed, uses the current output port."
+ (cond
+ ((zero? (statprof-sample-count state))
+ (format port "No samples recorded.\n"))
+ (else
+ (let* ((stats-list (statprof-fold-call-data
+ (lambda (data prior-value)
+ (cons (statprof-call-data->stats data)
+ prior-value))
+ '()
+ state))
+ (sorted-stats (sort stats-list stats-sorter)))
+
+ (define (display-stats-line stats)
+ (format port "~6,2f ~9,2f ~9,2f"
+ (statprof-stats-%-time-in-proc stats)
+ (statprof-stats-cum-secs-in-proc stats)
+ (statprof-stats-self-secs-in-proc stats))
+ (if (call-counts state)
+ (if (statprof-stats-calls stats)
+ (format port " ~7d ~8,2f ~8,2f "
+ (statprof-stats-calls stats)
+ (* 1000 (statprof-stats-self-secs-per-call stats))
+ (* 1000 (statprof-stats-cum-secs-per-call stats)))
+ (format port " "))
+ (display " " port))
+ (let ((source (statprof-stats-proc-source stats))
+ (name (statprof-stats-proc-name stats)))
+ (when source
+ (display source port)
+ (when name
+ (display ":" port)))
+ (when name
+ (display name port))
+ (newline port)))
+
+ (if (call-counts state)
+ (begin
+ (format port "~5a ~10a ~7a ~8a ~8a ~8a ~8@a\n"
+ "% " "cumulative" "self" "" "self" "total" "")
+ (format port "~5a ~9a ~8a ~8a ~8a ~8a ~a\n"
+ "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "procedure"))
+ (begin
+ (format port "~5a ~10a ~7a ~8a\n"
+ "%" "cumulative" "self" "")
+ (format port "~5a ~10a ~7a ~a\n"
+ "time" "seconds" "seconds" "procedure")))
+
+ (for-each display-stats-line sorted-stats)
+
+ (display "---\n" port)
+ (simple-format #t "Sample count: ~A\n" (statprof-sample-count state))
+ (simple-format #t "Total time: ~A seconds (~A seconds in GC)\n"
+ (statprof-accumulated-time state)
+ (/ (gc-time-taken state)
+ 1.0 internal-time-units-per-second))))))
+
+(define* (statprof-display-anomalies #:optional (state
+ (existing-profiler-state)))
+ "A sanity check that attempts to detect anomalies in statprof's
+statistics.@code{}"
+ (statprof-fold-call-data
+ (lambda (data prior-value)
+ (when (and (call-counts state)
+ (zero? (call-data-call-count data))
+ (positive? (call-data-cum-sample-count data)))
+ (simple-format #t
+ "==[~A ~A ~A]\n"
+ (call-data-name data)
+ (call-data-call-count data)
+ (call-data-cum-sample-count data))))
+ #f
+ state)
+ (simple-format #t "Total time: ~A\n" (statprof-accumulated-time state))
+ (simple-format #t "Sample count: ~A\n" (statprof-sample-count state)))
+
+(define (statprof-display-anomolies)
+ (issue-deprecation-warning "statprof-display-anomolies is a misspelling. "
+ "Use statprof-display-anomalies instead.")
+ (statprof-display-anomalies))
+
+(define* (statprof-accumulated-time #:optional (state
+ (existing-profiler-state)))
+ "Returns the time accumulated during the last statprof run.@code{}"
+ (/ (accumulated-time state) 1.0 internal-time-units-per-second))
+
+(define* (statprof-sample-count #:optional (state (existing-profiler-state)))
+ "Returns the number of samples taken during the last statprof run.@code{}"
+ (sample-count state))
+
+(define statprof-call-data-name call-data-name)
+(define statprof-call-data-calls call-data-call-count)
+(define statprof-call-data-cum-samples call-data-cum-sample-count)
+(define statprof-call-data-self-samples call-data-self-sample-count)
+
+(define* (statprof-fetch-stacks #:optional (state (existing-profiler-state)))
+ "Returns a list of stacks, as they were captured since the last call
+to @code{statprof-reset}."
+ (stack-samples->callee-lists state))
+
+(define procedure=?
+ (lambda (a b)
+ (cond
+ ((eq? a b))
+ ((and (program? a) (program? b))
+ (eq? (program-code a) (program-code b)))
+ (else
+ #f))))
+
+;; tree ::= (car n . tree*)
+
+(define (lists->trees lists equal?)
+ (let lp ((in lists) (n-terminal 0) (tails '()))
+ (cond
+ ((null? in)
+ (let ((trees (map (lambda (tail)
+ (cons (car tail)
+ (lists->trees (cdr tail) equal?)))
+ tails)))
+ (cons (apply + n-terminal (map cadr trees))
+ (sort trees
+ (lambda (a b) (> (cadr a) (cadr b)))))))
+ ((null? (car in))
+ (lp (cdr in) (1+ n-terminal) tails))
+ ((find (lambda (x) (equal? (car x) (caar in)))
+ tails)
+ => (lambda (tail)
+ (lp (cdr in)
+ n-terminal
+ (assq-set! tails
+ (car tail)
+ (cons (cdar in) (cdr tail))))))
+ (else
+ (lp (cdr in)
+ n-terminal
+ (acons (caar in) (list (cdar in)) tails))))))
+
+(define* (statprof-fetch-call-tree #:optional (state (existing-profiler-state)))
+ "Return a call tree for the previous statprof run.
+
+The return value is a list of nodes, each of which is of the type:
+@code
+ node ::= (@var{proc} @var{count} . @var{nodes})
+@end code"
+ (define (callee->printable callee)
+ (cond
+ ((number? callee)
+ (addr->printable callee (find-program-debug-info callee)))
+ (else
+ (with-output-to-string (lambda () (write callee))))))
+ (define (memoizev/1 proc table)
+ (lambda (x)
+ (cond
+ ((hashv-get-handle table x) => cdr)
+ (else
+ (let ((res (proc x)))
+ (hashv-set! table x res)
+ res)))))
+ (let ((callee->printable (memoizev/1 callee->printable (make-hash-table))))
+ (cons #t (lists->trees (map (lambda (callee-list)
+ (map callee->printable callee-list))
+ (stack-samples->callee-lists state))
+ equal?))))
+
+(define (call-thunk thunk)
+ (call-with-values (lambda () (thunk))
+ (lambda results
+ (apply values results))))
+
+(define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f)
+ (port (current-output-port)) full-stacks?)
+ "Profile the execution of @var{thunk}, and return its return values.
+
+The stack will be sampled @var{hz} times per second, and the thunk
+itself will be called @var{loop} times.
+
+If @var{count-calls?} is true, all procedure calls will be recorded. This
+operation is somewhat expensive."
+
+ (let ((state (fresh-profiler-state #:count-calls? count-calls?
+ #:sampling-period
+ (inexact->exact (round (/ 1e6 hz)))
+ #:outer-cut
+ (program-address-range call-thunk))))
+ (parameterize ((profiler-state state))
+ (dynamic-wind
+ (lambda ()
+ (statprof-start state))
+ (lambda ()
+ (let lp ((i loop))
+ (unless (= i 1)
+ (call-thunk thunk)
+ (lp (1- i))))
+ (call-thunk thunk))
+ (lambda ()
+ (statprof-stop state)
+ (statprof-display port state))))))
+
+(define-macro (with-statprof . args)
+ "Profile the expressions in the body, and return the body's return values.
+
+Keyword arguments:
+
+@table @code
+@item #:loop
+Execute the body @var{loop} number of times, or @code{#f} for no looping
+
+default: @code{#f}
+@item #:hz
+Sampling rate
+
+default: @code{20}
+@item #:count-calls?
+Whether to instrument each function call (expensive)
+
+default: @code{#f}
+@end table"
+ (define (kw-arg-ref kw args def)
+ (cond
+ ((null? args) (error "Invalid macro body"))
+ ((keyword? (car args))
+ (if (eq? (car args) kw)
+ (cadr args)
+ (kw-arg-ref kw (cddr args) def)))
+ ((eq? kw #f def) ;; asking for the body
+ args)
+ (else def))) ;; kw not found
+ `((@ (statprof) statprof)
+ (lambda () ,@(kw-arg-ref #f args #f))
+ #:loop ,(kw-arg-ref #:loop args 1)
+ #:hz ,(kw-arg-ref #:hz args 100)
+ #:count-calls? ,(kw-arg-ref #:count-calls? args #f)
+ #:full-stacks? ,(kw-arg-ref #:full-stacks? args #f)))
+
+(define* (gcprof thunk #:key (loop 1) full-stacks? (port (current-output-port)))
+ "Do an allocation profile of the execution of @var{thunk}.
+
+The stack will be sampled soon after every garbage collection, yielding
+an approximate idea of what is causing allocation in your program.
+
+Since GC does not occur very frequently, you may need to use the
+@var{loop} parameter, to cause @var{thunk} to be called @var{loop}
+times."
+
+ (let ((state (fresh-profiler-state #:outer-cut
+ (program-address-range call-thunk))))
+ (parameterize ((profiler-state state))
+ (define (gc-callback)
+ (unless (inside-profiler? state)
+ (set-inside-profiler?! state #t)
+
+ (let ((stop-time (get-internal-run-time))
+ ;; Cut down to gc-callback, and then one before (the
+ ;; after-gc async). See the note in profile-signal-handler
+ ;; also.
+ (stack (or (make-stack #t gc-callback (outer-cut state) 1)
+ (pk 'what! (make-stack #t)))))
+ (sample-stack-procs state stack)
+ (accumulate-time state stop-time)
+ (set-last-start-time! state (get-internal-run-time)))
+
+ (set-inside-profiler?! state #f)))
+
+ (dynamic-wind
+ (lambda ()
+ (set-profile-level! state 1)
+ (set-last-start-time! state (get-internal-run-time))
+ (set-gc-time-taken! state (assq-ref (gc-stats) 'gc-time-taken))
+ (add-hook! after-gc-hook gc-callback))
+ (lambda ()
+ (let lp ((i loop))
+ (unless (zero? i)
+ (call-thunk thunk)
+ (lp (1- i)))))
+ (lambda ()
+ (remove-hook! after-gc-hook gc-callback)
+ (set-gc-time-taken! state
+ (- (assq-ref (gc-stats) 'gc-time-taken)
+ (gc-time-taken state)))
+ (accumulate-time state (get-internal-run-time))
+ (set-profile-level! state 0)
+ (statprof-display port state))))))
(define* (compile-file file #:key
(output-file #f)
(from (current-language))
- (to 'objcode)
+ (to 'bytecode)
(env (default-environment from))
(opts '())
(canonicalization 'relative))
(call-with-output-file/atomic comp
(lambda (port)
((language-printer (ensure-language to))
- (read-and-compile in #:env env #:from from #:to to #:opts opts)
+ (read-and-compile in #:env env #:from from #:to to #:opts
+ (cons* #:to-file? #t opts))
port))
file)
comp)))
(define* (read-and-compile port #:key
(from (current-language))
- (to 'objcode)
+ (to 'bytecode)
(env (default-environment from))
(opts '()))
(let ((from (ensure-language from))
(define* (decompile x #:key
(env #f)
- (from 'value)
- (to 'assembly)
+ (from 'tree-il)
+ (to 'scheme)
(opts '()))
(decompile-fold (decompile-passes from to opts)
x
;;;
(define %native-word-size
- ;; The native word size. Note: don't use `word-size' from
- ;; (system vm objcode) to avoid a circular dependency.
((@ (system foreign) sizeof) '*))
(define %target-type (make-fluid %host-type))
;;; 'SCM' type tag decoding.
-;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015 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
(define %tc7-stringbuf 39)
(define %tc7-dynamic-state 45)
(define %tc7-frame 47)
-(define %tc7-objcode 53)
-(define %tc7-vm 55)
+(define %tc7-keyword 53)
+(define %tc7-program 69)
(define %tc7-vm-continuation 71)
(define %tc7-bytevector 77)
-(define %tc7-program 79)
-(define %tc7-array 85)
-(define %tc7-bitvector 87)
+(define %tc7-weak-set 85)
+(define %tc7-weak-table 87)
+(define %tc7-array 93)
+(define %tc7-bitvector 95)
(define %tc7-port 125)
(define %tc7-smob 127)
(((_ & #x7f = %tc7-bytevector) len address)
(let ((bv-port (memory-port backend address len)))
(get-bytevector-all bv-port)))
- ((((len << 7) || %tc7-vector) weakv-data)
- (let* ((len (arithmetic-shift len -1))
- (words (get-bytevector-n port (* len %word-size)))
- (vector (make-vector len)))
+ ((((len << 8) || %tc7-vector))
+ (let ((words (get-bytevector-n port (* len %word-size)))
+ (vector (make-vector len)))
(visited (address -> vector)
(fold (lambda (element index)
(vector-set! vector index element)
(inferior-object 'hash-table address))
(((_ & #x7f = %tc7-pointer) address)
(make-pointer address))
- (((_ & #x7f = %tc7-objcode))
- (inferior-object 'objcode address))
- (((_ & #x7f = %tc7-vm))
- (inferior-object 'vm address))
+ (((_ & #x7f = %tc7-keyword) symbol)
+ (symbol->keyword (cell->object symbol backend)))
(((_ & #x7f = %tc7-vm-continuation))
(inferior-object 'vm-continuation address))
+ (((_ & #x7f = %tc7-weak-set))
+ (inferior-object 'weak-set address))
+ (((_ & #x7f = %tc7-weak-table))
+ (inferior-object 'weak-table address))
(((_ & #x7f = %tc7-array))
(inferior-object 'array address))
(((_ & #x7f = %tc7-bitvector))
;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
(let ((ptr->obj (make-weak-value-hash-table 3000)))
(lambda (ptr)
- ;; XXX: We can't use `hash-create-handle!' +
- ;; `set-cdr!' here because the former would create a
- ;; weak-cdr pair but the latter wouldn't register a
- ;; disappearing link (see `scm_hash_fn_set_x'.)
(or (hash-ref ptr->obj ptr)
(let ((o (%wrap ptr)))
(hash-set! ptr->obj ptr o)
;;; Repl commands
-;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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 (system base compile)
#:use-module (system repl common)
#:use-module (system repl debug)
- #:use-module (system vm objcode)
+ #:use-module (system vm disassembler)
+ #:use-module (system vm loader)
#:use-module (system vm program)
#:use-module (system vm trap-state)
#:use-module (system vm vm)
- #:use-module ((system vm frame) #:select (frame-return-values))
#:autoload (system base language) (lookup-language language-reader)
#:autoload (system vm trace) (call-with-trace)
#:use-module (ice-9 format)
#:use-module (ice-9 control)
#:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
+ #:use-module (rnrs bytevectors)
#:use-module (statprof)
#:export (meta-command define-meta-command))
;;; Compile commands
;;;
+(define (load-image x)
+ (let ((thunk (load-thunk-from-memory x)))
+ (find-mapped-elf-image (program-code thunk))))
+
(define-meta-command (compile repl (form))
"compile EXP
Generate compiled code."
(let ((x (repl-compile repl (repl-parse repl form))))
- (cond ((objcode? x) (guile:disassemble x))
+ (cond ((bytevector? x) (disassemble-image (load-image x)))
(else (repl-print repl x)))))
(define-meta-command (compile-file repl file . opts)
(run-hook before-print-hook x)
(pp x)))
-(define (guile:disassemble x)
- ((@ (language assembly disassemble) disassemble) x))
-
(define-meta-command (disassemble repl (form))
"disassemble EXP
Disassemble a compiled procedure."
(let ((obj (repl-eval repl (repl-parse repl form))))
- (if (or (program? obj) (objcode? obj))
- (guile:disassemble obj)
- (format #t "Argument to ,disassemble not a procedure or objcode: ~a~%"
- obj))))
+ (cond
+ ((program? obj)
+ (disassemble-program obj))
+ ((bytevector? obj)
+ (disassemble-image (load-image obj)))
+ (else
+ (format #t
+ "Argument to ,disassemble not a procedure or a bytevector: ~a~%"
+ obj)))))
(define-meta-command (disassemble-file repl file)
"disassemble-file FILE
Disassemble a file."
- (guile:disassemble (load-objcode (->string file))))
+ (disassemble-file (->string file)))
\f
;;;
(identifier-syntax (debug-frames debug)))
(#,(datum->syntax #'repl 'message)
(identifier-syntax (debug-error-message debug)))
- (#,(datum->syntax #'repl 'for-trap?)
- (identifier-syntax (debug-for-trap? debug)))
(#,(datum->syntax #'repl 'index)
(identifier-syntax
(id (debug-index debug))
(print-frames frames
#:count count
#:width width
- #:full? full?
- #:for-trap? for-trap?))
+ #:full? full?))
(define-stack-command (up repl #:optional (count 1))
"up [COUNT]
(format #t "Already at outermost frame.\n"))
(else
(set! index (1- (vector-length frames)))
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (print-frame cur #:index index))))
(else
(set! index (+ count index))
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (print-frame cur #:index index))))
(define-stack-command (down repl #:optional (count 1))
"down [COUNT]
(format #t "Already at innermost frame.\n"))
(else
(set! index 0)
- (print-frame cur #:index index #:next-source? for-trap?))))
+ (print-frame cur #:index index))))
(else
(set! index (- index count))
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (print-frame cur #:index index))))
(define-stack-command (frame repl #:optional idx)
"frame [IDX]
(format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%"))
((< idx (vector-length frames))
(set! index idx)
- (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))
+ (print-frame cur #:index index))
(else
(format #t "No such frame.~%"))))
- (else (print-frame cur #:index index
- #:next-source? (and (zero? index) for-trap?)))))
+ (else (print-frame cur #:index index))))
(define-stack-command (procedure repl)
"procedure
(format #t "Trap ~a: ~a.~%" idx (trap-name idx)))))
(define (repl-pop-continuation-resumer repl msg)
- ;; Capture the dynamic environment with this prompt thing. The
- ;; result is a procedure that takes a frame.
+ ;; Capture the dynamic environment with this prompt thing. The result
+ ;; is a procedure that takes a frame and number of values returned.
(% (call-with-values
(lambda ()
(abort
;; Call frame->stack-vector before reinstating the
;; continuation, so that we catch the %stacks fluid at
;; the time of capture.
- (lambda (frame)
+ (lambda (frame . values)
(k frame
(frame->stack-vector
- (frame-previous frame)))))))
- (lambda (from stack)
+ (frame-previous frame))
+ values)))))
+ (lambda (from stack values)
(format #t "~a~%" msg)
- (let ((vals (frame-return-values from)))
- (if (null? vals)
- (format #t "No return values.~%")
- (begin
- (format #t "Return values:~%")
- (for-each (lambda (x) (repl-print repl x)) vals))))
+ (if (null? values)
+ (format #t "No return values.~%")
+ (begin
+ (format #t "Return values:~%")
+ (for-each (lambda (x) (repl-print repl x)) values)))
((module-ref (resolve-interface '(system repl repl)) 'start-repl)
- #:debug (make-debug stack 0 msg #t))))))
+ #:debug (make-debug stack 0 msg))))))
(define-stack-command (finish repl)
"finish
(k (frame->stack-vector frame)))))))
(format #t "~a~%" msg)
((module-ref (resolve-interface '(system repl repl)) 'start-repl)
- #:debug (make-debug stack 0 msg #t)))))
+ #:debug (make-debug stack 0 msg)))))
(define-stack-command (step repl)
"step
#:use-module (system base language)
#:use-module (system base message)
#:use-module (system vm program)
- #:autoload (language tree-il optimize) (optimize!)
+ #:use-module (system vm loader)
+ #:autoload (language tree-il optimize) (optimize)
#:use-module (ice-9 control)
#:use-module (ice-9 history)
#:export (<repl> make-repl repl-language repl-options
(define (repl-compile repl form)
(let ((from (repl-language repl))
(opts (repl-compile-options repl)))
- (compile form #:from from #:to 'objcode #:opts opts
+ (compile form #:from from #:to 'bytecode #:opts opts
#:env (current-module))))
(define (repl-expand repl form)
(define (repl-optimize repl form)
(let ((from (repl-language repl))
(opts (repl-compile-options repl)))
- (decompile (optimize! (compile form #:from from #:to 'tree-il #:opts opts
- #:env (current-module))
- (current-module)
- opts)
+ (decompile (optimize (compile form #:from from #:to 'tree-il #:opts opts
+ #:env (current-module))
+ (current-module)
+ opts)
#:from 'tree-il #:to from)))
(define (repl-parse repl form)
(or (null? (language-compilers (repl-language repl)))
(repl-option-ref repl 'interp)))
(lambda () (eval form (current-module)))
- (make-program (repl-compile repl form)))))
+ (load-thunk-from-memory (repl-compile repl form)))))
(define (repl-eval repl form)
(let ((thunk (repl-prepare-eval-thunk repl form)))
;;; Guile VM debugging facilities
-;;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2011, 2013, 2014 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 (system vm program)
#:export (<debug>
make-debug debug?
- debug-frames debug-index debug-error-message debug-for-trap?
+ debug-frames debug-index debug-error-message
terminal-width
print-registers print-locals print-frame print-frames frame->module
stack->vector narrow-stack->vector
;;; accessors, and provides some helper functions.
;;;
-(define-record <debug> frames index error-message for-trap?)
+(define-record <debug> frames index error-message)
\f
(format port fmt val))
(format port "~aRegisters:~%" per-line-prefix)
- (print "ip = ~d\n" (frame-instruction-pointer frame))
- (print "sp = #x~x\n" (frame-stack-pointer frame))
- (print "fp = #x~x\n" (frame-address frame)))
+ (print "ip = #x~x" (frame-instruction-pointer frame))
+ (when (program? (frame-procedure frame))
+ (let ((code (program-code (frame-procedure frame))))
+ (format port " (#x~x~@d)" code
+ (- (frame-instruction-pointer frame) code))))
+ (newline port)
+ (print "sp = ~a\n" (frame-stack-pointer frame))
+ (print "fp = ~a\n" (frame-address frame)))
(define* (print-locals frame #:optional (port (current-output-port))
#:key (width (terminal-width)) (per-line-prefix " "))
(format port "~aLocal variables:~%" per-line-prefix)
(for-each
(lambda (binding)
- (let ((v (let ((x (frame-local-ref frame (binding:index binding))))
- (if (binding:boxed? binding)
- (variable-ref x)
- x))))
+ (let ((v (frame-local-ref frame (binding-slot binding))))
(display per-line-prefix port)
(run-hook before-print-hook v)
- (format port "~a~:[~; (boxed)~] = ~v:@y\n"
- (binding:name binding) (binding:boxed? binding) width v)))
+ (format port "~a = ~v:@y\n" (binding-name binding) width v)))
(frame-bindings frame))))))
(define* (print-frame frame #:optional (port (current-output-port))
(if source
(or (source:file source) "current input")
"unknown file"))
- (let* ((source ((if next-source? frame-next-source frame-source) frame))
+ (let* ((source (frame-source frame))
(file (source:pretty-file source))
(line (and=> source source:line-for-user))
(col (and=> source source:column)))
(define* (print-frames frames
#:optional (port (current-output-port))
#:key (width (terminal-width)) (full? #f)
- (forward? #f) count for-trap?)
+ (forward? #f) count)
(let* ((len (vector-length frames))
(lower-idx (if (or (not count) (positive? count))
0
(if (<= lower-idx i upper-idx)
(let* ((frame (vector-ref frames i)))
(print-frame frame port #:index i #:width width #:full? full?
- #:last-source last-source
- #:next-source? (and (zero? i) for-trap?))
+ #:last-source last-source)
(lp (+ i inc)
- (if (and (zero? i) for-trap?)
- (frame-next-source frame)
- (frame-source frame))))))))
+ (frame-source frame)))))))
;; Ideally here we would have something much more syntactic, in that a set! to a
;; local var that is not settable would raise an error, and export etc forms
;; Patches welcome!
(define (frame->module frame)
(let ((proc (frame-procedure frame)))
- (if (program? proc)
+ (if #f
+ ;; FIXME: program-module does not exist.
(let* ((mod (or (program-module proc) (current-module)))
(mod* (make-module)))
(module-use! mod* mod)
(for-each
(lambda (binding)
- (let* ((x (frame-local-ref frame (binding:index binding)))
- (var (if (binding:boxed? binding) x (make-variable x))))
+ (let* ((x (frame-local-ref frame (binding-slot binding)))
+ (var (if (variable? x) x (make-variable x))))
(format #t
"~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n"
- (binding:boxed? binding)
- (binding:name binding)
+ (not (variable? x))
+ (binding-name binding)
(if (variable-bound? var) (variable-ref var) var))
- (module-add! mod* (binding:name binding) var)))
+ (module-add! mod* (binding-name binding) var)))
(frame-bindings frame))
mod*)
(current-module))))
;;; Error handling in the REPL
-;; Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 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* (call-with-error-handling thunk #:key
(on-error 'debug) (post-error 'catch)
- (pass-keys '(quit)) (trap-handler 'debug))
+ (pass-keys '(quit)) (trap-handler 'debug)
+ (report-keys '(stack-overflow out-of-memory)))
(let ((in (current-input-port))
(out (current-output-port))
(err (current-error-port)))
(error-msg (if trap-idx
(format #f "Trap ~d: ~a" trap-idx trap-name)
trap-name))
- (debug (make-debug stack 0 error-msg #t)))
+ (debug (make-debug stack 0 error-msg)))
(with-saved-ports
(lambda ()
(if trap-idx
((disabled) #f)
(else (error "Unknown trap-handler strategy" trap-handler))))
+ (define (report-error key args)
+ (with-saved-ports
+ (lambda ()
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err))))
+
(catch #t
(lambda ()
(with-default-trap-handler le-trap-handler
(if (memq key pass-keys)
(apply throw key args)
(begin
- (with-saved-ports
- (lambda ()
- (run-hook before-error-hook)
- (print-exception err #f key args)
- (run-hook after-error-hook)
- (force-output err)))
+ (report-error key args)
(if #f #f)))))
((catch)
(lambda (key . args)
- (if (memq key pass-keys)
- (apply throw key args))))
+ (when (memq key pass-keys)
+ (apply throw key args))
+ (when (memq key report-keys)
+ (report-error key args))
+ (if #f #f)))
(else
(if (procedure? post-error)
(lambda (k . args)
;; the start-stack thunk has its own frame too.
0 (and tag 1)))
(error-msg (error-string stack key args))
- (debug (make-debug stack 0 error-msg #f)))
+ (debug (make-debug stack 0 error-msg)))
(with-saved-ports
(lambda ()
(format #t "~a~%" error-msg)
((@ (system repl repl) start-repl) #:debug debug)))))))
((report)
(lambda (key . args)
- (if (not (memq key pass-keys))
- (begin
- (with-saved-ports
- (lambda ()
- (run-hook before-error-hook)
- (print-exception err #f key args)
- (run-hook after-error-hook)
- (force-output err)))
- (if #f #f)))))
+ (unless (memq key pass-keys)
+ (report-error key args))
+ (if #f #f)))
((backtrace)
(lambda (key . args)
(if (not (memq key pass-keys))
(make-stack #t)
;; Narrow as above, for the debugging case.
3 tag 0 (and tag 1))))
- (with-saved-ports
- (lambda ()
- (print-frames frames)
- (run-hook before-error-hook)
- (print-exception err #f key args)
- (run-hook after-error-hook)
- (force-output err)))
+ (with-saved-ports (lambda () (print-frames frames)))
+ (report-error key args)
(if #f #f)))))
((pass)
(lambda (key . args)
--- /dev/null
+;;; Guile bytecode assembler
+
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015 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
+
+;;; Commentary:
+;;;
+;;; This module implements an assembler that creates an ELF image from
+;;; bytecode assembly and macro-assembly. The input can be given in
+;;; s-expression form, like ((OP ARG ...) ...). Internally there is a
+;;; procedural interface, the emit-OP procedures, but that is not
+;;; currently exported.
+;;;
+;;; "Primitive instructions" correspond to VM operations. Assemblers
+;;; for primitive instructions are generated programmatically from
+;;; (instruction-list), which itself is derived from the VM sources.
+;;; There are also "macro-instructions" like "label" or "load-constant"
+;;; that expand to 0 or more primitive instructions.
+;;;
+;;; The assembler also handles some higher-level tasks, like creating
+;;; the symbol table, other metadata sections, creating a constant table
+;;; for the whole compilation unit, and writing the dynamic section of
+;;; the ELF file along with the appropriate initialization routines.
+;;;
+;;; Most compilers will want to use the trio of make-assembler,
+;;; emit-text, and link-assembly. That will result in the creation of
+;;; an ELF image as a bytevector, which can then be loaded using
+;;; load-thunk-from-memory, or written to disk as a .go file.
+;;;
+;;; Code:
+
+(define-module (system vm assembler)
+ #:use-module (system base target)
+ #:use-module (system vm dwarf)
+ #:use-module (system vm elf)
+ #:use-module (system vm linker)
+ #:use-module (language bytecode)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:export (make-assembler
+
+ emit-call
+ emit-call-label
+ emit-tail-call
+ emit-tail-call-label
+ (emit-receive* . emit-receive)
+ emit-receive-values
+ emit-return
+ emit-return-values
+ emit-call/cc
+ emit-abort
+ (emit-builtin-ref* . emit-builtin-ref)
+ emit-br-if-nargs-ne
+ emit-br-if-nargs-lt
+ emit-br-if-nargs-gt
+ emit-assert-nargs-ee
+ emit-assert-nargs-ge
+ emit-assert-nargs-le
+ emit-alloc-frame
+ emit-reset-frame
+ emit-assert-nargs-ee/locals
+ emit-br-if-npos-gt
+ emit-bind-kwargs
+ emit-bind-rest
+ emit-br
+ emit-br-if-true
+ emit-br-if-null
+ emit-br-if-nil
+ emit-br-if-pair
+ emit-br-if-struct
+ emit-br-if-char
+ emit-br-if-tc7
+ (emit-br-if-eq* . emit-br-if-eq)
+ (emit-br-if-eqv* . emit-br-if-eqv)
+ (emit-br-if-equal* . emit-br-if-equal)
+ (emit-br-if-=* . emit-br-if-=)
+ (emit-br-if-<* . emit-br-if-<)
+ (emit-br-if-<=* . emit-br-if-<=)
+ (emit-br-if-logtest* . emit-br-if-logtest)
+ (emit-mov* . emit-mov)
+ (emit-box* . emit-box)
+ (emit-box-ref* . emit-box-ref)
+ (emit-box-set!* . emit-box-set!)
+ emit-make-closure
+ (emit-free-ref* . emit-free-ref)
+ (emit-free-set!* . emit-free-set!)
+ emit-current-module
+ emit-resolve
+ (emit-define!* . emit-define!)
+ emit-toplevel-box
+ emit-module-box
+ emit-prompt
+ (emit-wind* . emit-wind)
+ emit-unwind
+ (emit-push-fluid* . emit-push-fluid)
+ emit-pop-fluid
+ (emit-fluid-ref* . emit-fluid-ref)
+ (emit-fluid-set* . emit-fluid-set)
+ (emit-string-length* . emit-string-length)
+ (emit-string-ref* . emit-string-ref)
+ (emit-string->number* . emit-string->number)
+ (emit-string->symbol* . emit-string->symbol)
+ (emit-symbol->keyword* . emit-symbol->keyword)
+ (emit-cons* . emit-cons)
+ (emit-car* . emit-car)
+ (emit-cdr* . emit-cdr)
+ (emit-set-car!* . emit-set-car!)
+ (emit-set-cdr!* . emit-set-cdr!)
+ (emit-add* . emit-add)
+ (emit-add1* . emit-add1)
+ (emit-sub* . emit-sub)
+ (emit-sub1* . emit-sub1)
+ (emit-mul* . emit-mul)
+ (emit-div* . emit-div)
+ (emit-quo* . emit-quo)
+ (emit-rem* . emit-rem)
+ (emit-mod* . emit-mod)
+ (emit-ash* . emit-ash)
+ (emit-logand* . emit-logand)
+ (emit-logior* . emit-logior)
+ (emit-logxor* . emit-logxor)
+ (emit-make-vector* . emit-make-vector)
+ (emit-make-vector/immediate* . emit-make-vector/immediate)
+ (emit-vector-length* . emit-vector-length)
+ (emit-vector-ref* . emit-vector-ref)
+ (emit-vector-ref/immediate* . emit-vector-ref/immediate)
+ (emit-vector-set!* . emit-vector-set!)
+ (emit-vector-set!/immediate* . emit-vector-set!/immediate)
+ (emit-struct-vtable* . emit-struct-vtable)
+ (emit-allocate-struct/immediate* . emit-allocate-struct/immediate)
+ (emit-struct-ref/immediate* . emit-struct-ref/immediate)
+ (emit-struct-set!/immediate* . emit-struct-set!/immediate)
+ (emit-allocate-struct* . emit-allocate-struct)
+ (emit-struct-ref* . emit-struct-ref)
+ (emit-struct-set!* . emit-struct-set!)
+ (emit-class-of* . emit-class-of)
+ (emit-make-array* . emit-make-array)
+ (emit-bv-u8-ref* . emit-bv-u8-ref)
+ (emit-bv-s8-ref* . emit-bv-s8-ref)
+ (emit-bv-u16-ref* . emit-bv-u16-ref)
+ (emit-bv-s16-ref* . emit-bv-s16-ref)
+ (emit-bv-u32-ref* . emit-bv-u32-ref)
+ (emit-bv-s32-ref* . emit-bv-s32-ref)
+ (emit-bv-u64-ref* . emit-bv-u64-ref)
+ (emit-bv-s64-ref* . emit-bv-s64-ref)
+ (emit-bv-f32-ref* . emit-bv-f32-ref)
+ (emit-bv-f64-ref* . emit-bv-f64-ref)
+ (emit-bv-u8-set!* . emit-bv-u8-set!)
+ (emit-bv-s8-set!* . emit-bv-s8-set!)
+ (emit-bv-u16-set!* . emit-bv-u16-set!)
+ (emit-bv-s16-set!* . emit-bv-s16-set!)
+ (emit-bv-u32-set!* . emit-bv-u32-set!)
+ (emit-bv-s32-set!* . emit-bv-s32-set!)
+ (emit-bv-u64-set!* . emit-bv-u64-set!)
+ (emit-bv-s64-set!* . emit-bv-s64-set!)
+ (emit-bv-f32-set!* . emit-bv-f32-set!)
+ (emit-bv-f64-set!* . emit-bv-f64-set!)
+
+ emit-text
+ link-assembly))
+
+
+\f
+
+;; Like define-inlinable, but only for first-order uses of the defined
+;; routine. Should residualize less code.
+(eval-when (expand)
+ (define-syntax define-inline
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (name arg ...) body ...)
+ (with-syntax (((temp ...) (generate-temporaries #'(arg ...))))
+ #`(eval-when (expand)
+ (define-syntax-rule (name temp ...)
+ (let ((arg temp) ...)
+ body ...)))))))))
+
+;;; Bytecode consists of 32-bit units, often subdivided in some way.
+;;; These helpers create one 32-bit unit from multiple components.
+
+(define-inline (pack-u8-u24 x y)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (logior x (ash y 8)))
+
+(define-inline (pack-u8-s24 x y)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (logior x (ash (cond
+ ((< 0 (- y) #x800000)
+ (+ y #x1000000))
+ ((<= 0 y #xffffff)
+ y)
+ (else (error "out of range" y)))
+ 8)))
+
+(define-inline (pack-u1-u7-u24 x y z)
+ (unless (<= 0 x 1)
+ (error "out of range" x))
+ (unless (<= 0 y 127)
+ (error "out of range" y))
+ (logior x (ash y 1) (ash z 8)))
+
+(define-inline (pack-u8-u12-u12 x y z)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (unless (<= 0 y 4095)
+ (error "out of range" y))
+ (logior x (ash y 8) (ash z 20)))
+
+(define-inline (pack-u8-u8-u16 x y z)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (unless (<= 0 y 255)
+ (error "out of range" y))
+ (logior x (ash y 8) (ash z 16)))
+
+(define-inline (pack-u8-u8-u8-u8 x y z w)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (unless (<= 0 y 255)
+ (error "out of range" y))
+ (unless (<= 0 z 255)
+ (error "out of range" z))
+ (logior x (ash y 8) (ash z 16) (ash w 24)))
+
+(eval-when (expand)
+ (define-syntax pack-flags
+ (syntax-rules ()
+ ;; Add clauses as needed.
+ ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0)
+ (if f2 (ash 2 0) 0))))))
+
+;;; Helpers to read and write 32-bit units in a buffer.
+
+(define-inline (u32-ref buf n)
+ (bytevector-u32-native-ref buf (* n 4)))
+
+(define-inline (u32-set! buf n val)
+ (bytevector-u32-native-set! buf (* n 4) val))
+
+(define-inline (s32-ref buf n)
+ (bytevector-s32-native-ref buf (* n 4)))
+
+(define-inline (s32-set! buf n val)
+ (bytevector-s32-native-set! buf (* n 4) val))
+
+
+\f
+
+;;; A <meta> entry collects metadata for one procedure. Procedures are
+;;; written as contiguous ranges of bytecode.
+;;;
+(eval-when (expand)
+ (define-syntax-rule (assert-match arg pattern kind)
+ (let ((x arg))
+ (unless (match x (pattern #t) (_ #f))
+ (error (string-append "expected " kind) x)))))
+
+(define-record-type <meta>
+ (%make-meta label properties low-pc high-pc arities)
+ meta?
+ (label meta-label)
+ (properties meta-properties set-meta-properties!)
+ (low-pc meta-low-pc)
+ (high-pc meta-high-pc set-meta-high-pc!)
+ (arities meta-arities set-meta-arities!))
+
+(define (make-meta label properties low-pc)
+ (assert-match label (or (? exact-integer?) (? symbol?)) "symbol")
+ (assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
+ (%make-meta label properties low-pc #f '()))
+
+(define (meta-name meta)
+ (assq-ref (meta-properties meta) 'name))
+
+;; Metadata for one <lambda-case>.
+(define-record-type <arity>
+ (make-arity req opt rest kw-indices allow-other-keys?
+ low-pc high-pc definitions)
+ arity?
+ (req arity-req)
+ (opt arity-opt)
+ (rest arity-rest)
+ (kw-indices arity-kw-indices)
+ (allow-other-keys? arity-allow-other-keys?)
+ (low-pc arity-low-pc)
+ (high-pc arity-high-pc set-arity-high-pc!)
+ (definitions arity-definitions set-arity-definitions!))
+
+(eval-when (expand)
+ (define-syntax *block-size* (identifier-syntax 32)))
+
+;;; An assembler collects all of the words emitted during assembly, and
+;;; also maintains ancillary information such as the constant table, a
+;;; relocation list, and so on.
+;;;
+;;; Bytecode consists of 32-bit units. We emit bytecode using native
+;;; endianness. If we're targeting a foreign endianness, we byte-swap
+;;; the bytevector as a whole instead of conditionalizing each access.
+;;;
+(define-record-type <asm>
+ (make-asm cur idx start prev written
+ labels relocs
+ word-size endianness
+ constants inits
+ shstrtab next-section-number
+ meta sources
+ dead-slot-maps)
+ asm?
+
+ ;; We write bytecode into what is logically a growable vector,
+ ;; implemented as a list of blocks. asm-cur is the current block, and
+ ;; asm-idx is the current index into that block, in 32-bit units.
+ ;;
+ (cur asm-cur set-asm-cur!)
+ (idx asm-idx set-asm-idx!)
+
+ ;; asm-start is an absolute position, indicating the offset of the
+ ;; beginning of an instruction (in u32 units). It is updated after
+ ;; writing all the words for one primitive instruction. It models the
+ ;; position of the instruction pointer during execution, given that
+ ;; the VM updates the IP only at the end of executing the instruction,
+ ;; and is thus useful for computing offsets between two points in a
+ ;; program.
+ ;;
+ (start asm-start set-asm-start!)
+
+ ;; The list of previously written blocks.
+ ;;
+ (prev asm-prev set-asm-prev!)
+
+ ;; The number of u32 words written in asm-prev, which is the same as
+ ;; the offset of the current block.
+ ;;
+ (written asm-written set-asm-written!)
+
+ ;; An alist of symbol -> position pairs, indicating the labels defined
+ ;; in this compilation unit.
+ ;;
+ (labels asm-labels set-asm-labels!)
+
+ ;; A list of relocations needed by the program text. We use an
+ ;; internal representation for relocations, and handle textualn
+ ;; relative relocations in the assembler. Other kinds of relocations
+ ;; are later reified as linker relocations and resolved by the linker.
+ ;;
+ (relocs asm-relocs set-asm-relocs!)
+
+ ;; Target information.
+ ;;
+ (word-size asm-word-size)
+ (endianness asm-endianness)
+
+ ;; The constant table, as a vhash of object -> label. All constants
+ ;; get de-duplicated and written into separate sections -- either the
+ ;; .rodata section, for read-only data, or .data, for constants that
+ ;; need initialization at load-time (like symbols). Constants can
+ ;; depend on other constants (e.g. a symbol depending on a stringbuf),
+ ;; so order in this table is important.
+ ;;
+ (constants asm-constants set-asm-constants!)
+
+ ;; A list of instructions needed to initialize the constants. Will
+ ;; run in a thunk with 2 local variables.
+ ;;
+ (inits asm-inits set-asm-inits!)
+
+ ;; The shstrtab, for section names.
+ ;;
+ (shstrtab asm-shstrtab set-asm-shstrtab!)
+
+ ;; The section number for the next section to be written.
+ ;;
+ (next-section-number asm-next-section-number set-asm-next-section-number!)
+
+ ;; A list of <meta>, corresponding to procedure metadata.
+ ;;
+ (meta asm-meta set-asm-meta!)
+
+ ;; A list of (pos . source) pairs, indicating source information. POS
+ ;; is relative to the beginning of the text section, and SOURCE is in
+ ;; the same format that source-properties returns.
+ ;;
+ (sources asm-sources set-asm-sources!)
+
+ ;; A list of (pos . dead-slot-map) pairs, indicating dead slot maps.
+ ;; POS is relative to the beginning of the text section.
+ ;; DEAD-SLOT-MAP is a bitfield of slots that are dead at call sites,
+ ;; as an integer.
+ ;;
+ (dead-slot-maps asm-dead-slot-maps set-asm-dead-slot-maps!))
+
+(define-inline (fresh-block)
+ (make-u32vector *block-size*))
+
+(define* (make-assembler #:key (word-size (target-word-size))
+ (endianness (target-endianness)))
+ "Create an assembler for a given target @var{word-size} and
+@var{endianness}, falling back to appropriate values for the configured
+target."
+ (make-asm (fresh-block) 0 0 '() 0
+ (make-hash-table) '()
+ word-size endianness
+ vlist-null '()
+ (make-string-table) 1
+ '() '() '()))
+
+(define (intern-section-name! asm string)
+ "Add a string to the section name table (shstrtab)."
+ (string-table-intern! (asm-shstrtab asm) string))
+
+(define-inline (asm-pos asm)
+ "The offset of the next word to be written into the code buffer, in
+32-bit units."
+ (+ (asm-idx asm) (asm-written asm)))
+
+(define (allocate-new-block asm)
+ "Close off the current block, and arrange for the next word to be
+written to a fresh block."
+ (let ((new (fresh-block)))
+ (set-asm-prev! asm (cons (asm-cur asm) (asm-prev asm)))
+ (set-asm-written! asm (asm-pos asm))
+ (set-asm-cur! asm new)
+ (set-asm-idx! asm 0)))
+
+(define-inline (emit asm u32)
+ "Emit one 32-bit word into the instruction stream. Assumes that there
+is space for the word, and ensures that there is space for the next
+word."
+ (u32-set! (asm-cur asm) (asm-idx asm) u32)
+ (set-asm-idx! asm (1+ (asm-idx asm)))
+ (if (= (asm-idx asm) *block-size*)
+ (allocate-new-block asm)))
+
+(define-inline (make-reloc type label base word)
+ "Make an internal relocation of type @var{type} referencing symbol
+@var{label}, @var{word} words after position @var{start}. @var{type}
+may be x8-s24, indicating a 24-bit relative label reference that can be
+fixed up by the assembler, or s32, indicating a 32-bit relative
+reference that needs to be fixed up by the linker."
+ (list type label base word))
+
+(define-inline (reset-asm-start! asm)
+ "Reset the asm-start after writing the words for one instruction."
+ (set-asm-start! asm (asm-pos asm)))
+
+(define (record-label-reference asm label)
+ "Record an x8-s24 local label reference. This value will get patched
+up later by the assembler."
+ (let* ((start (asm-start asm))
+ (pos (asm-pos asm))
+ (reloc (make-reloc 'x8-s24 label start (- pos start))))
+ (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
+
+(define* (record-far-label-reference asm label #:optional (offset 0))
+ "Record an s32 far label reference. This value will get patched up
+later by the linker."
+ (let* ((start (- (asm-start asm) offset))
+ (pos (asm-pos asm))
+ (reloc (make-reloc 's32 label start (- pos start))))
+ (set-asm-relocs! asm (cons reloc (asm-relocs asm)))))
+
+
+\f
+
+;;;
+;;; Primitive assemblers are defined by expanding `assembler' for each
+;;; opcode in `(instruction-list)'.
+;;;
+
+(eval-when (expand)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
+
+ (define-syntax assembler
+ (lambda (x)
+ (define-syntax op-case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ asm name ((type arg ...) code ...) clause ...)
+ #`(if (eq? name 'type)
+ (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
+ #'((arg ...)
+ code ...))
+ (op-case asm name clause ...)))
+ ((_ asm name)
+ #'(error "unmatched name" name)))))
+
+ (define (pack-first-word asm opcode type)
+ (with-syntax ((opcode opcode))
+ (op-case
+ asm type
+ ((U8_X24)
+ (emit asm opcode))
+ ((U8_U24 arg)
+ (emit asm (pack-u8-u24 opcode arg)))
+ ((U8_L24 label)
+ (record-label-reference asm label)
+ (emit asm opcode))
+ ((U8_U8_I16 a imm)
+ (emit asm (pack-u8-u8-u16 opcode a (object-address imm))))
+ ((U8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 opcode a b)))
+ ((U8_U8_U8_U8 a b c)
+ (emit asm (pack-u8-u8-u8-u8 opcode a b c))))))
+
+ (define (pack-tail-word asm type)
+ (op-case
+ asm type
+ ((U8_U24 a b)
+ (emit asm (pack-u8-u24 a b)))
+ ((U8_L24 a label)
+ (record-label-reference asm label)
+ (emit asm a))
+ ((U32 a)
+ (emit asm a))
+ ((I32 imm)
+ (let ((val (object-address imm)))
+ (unless (zero? (ash val -32))
+ (error "FIXME: enable truncation of negative fixnums when cross-compiling"))
+ (emit asm val)))
+ ((A32 imm)
+ (unless (= (asm-word-size asm) 8)
+ (error "make-long-immediate unavailable for this target"))
+ (emit asm (ash (object-address imm) -32))
+ (emit asm (logand (object-address imm) (1- (ash 1 32)))))
+ ((B32))
+ ((N32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((S32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((L32 label)
+ (record-far-label-reference asm label)
+ (emit asm 0))
+ ((LO32 label offset)
+ (record-far-label-reference asm label
+ (* offset (/ (asm-word-size asm) 4)))
+ (emit asm 0))
+ ((X8_U24 a)
+ (emit asm (pack-u8-u24 0 a)))
+ ((X8_L24 label)
+ (record-label-reference asm label)
+ (emit asm 0))
+ ((B1_X7_L24 a label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
+ ((B1_U7_L24 a b label)
+ (record-label-reference asm label)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))
+ ((B1_X31 a)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
+ ((B1_X7_U24 a b)
+ (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))))
+
+ (syntax-case x ()
+ ((_ name opcode word0 word* ...)
+ (with-syntax ((((formal0 ...)
+ code0 ...)
+ (pack-first-word #'asm
+ (syntax->datum #'opcode)
+ (syntax->datum #'word0)))
+ ((((formal* ...)
+ code* ...) ...)
+ (map (lambda (word) (pack-tail-word #'asm word))
+ (syntax->datum #'(word* ...)))))
+ #'(lambda (asm formal0 ... formal* ... ...)
+ (unless (asm? asm) (error "not an asm"))
+ code0 ...
+ code* ... ...
+ (reset-asm-start! asm))))))))
+
+(define assemblers (make-hash-table))
+
+(eval-when (expand)
+ (define-syntax define-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind arg ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(define emit
+ (let ((emit (assembler name opcode arg ...)))
+ (hashq-set! assemblers 'name emit)
+ emit)))))))
+
+ (define-syntax visit-opcodes
+ (lambda (x)
+ (syntax-case x ()
+ ((visit-opcodes macro arg ...)
+ (with-syntax (((inst ...)
+ (map (lambda (x) (datum->syntax #'macro x))
+ (instruction-list))))
+ #'(begin
+ (macro arg ... . inst)
+ ...)))))))
+
+(visit-opcodes define-assembler)
+
+(eval-when (expand)
+
+ ;; Some operands are encoded using a restricted subset of the full
+ ;; 24-bit local address space, in order to make the bytecode more
+ ;; dense in the usual case that there are few live locals. Here we
+ ;; define wrapper emitters that shuffle out-of-range operands into and
+ ;; out of the reserved range of locals [233,255]. This range is
+ ;; sufficient because these restricted operands are only present in
+ ;; the first word of an instruction. Since 8 bits is the smallest
+ ;; slot-addressing operand size, that means we can fit 3 operands in
+ ;; the 24 bits of payload of the first word (the lower 8 bits being
+ ;; taken by the opcode).
+ ;;
+ ;; The result are wrapper emitters with the same arity,
+ ;; e.g. emit-cons* that wraps emit-cons. We expose these wrappers as
+ ;; the public interface for emitting `cons' instructions. That way we
+ ;; solve the problem fully and in just one place. The only manual
+ ;; care that need be taken is in the exports list at the top of the
+ ;; file -- to be sure that we export the wrapper and not the wrapped
+ ;; emitter.
+
+ (define (shuffling-assembler name kind word0 word*)
+ (define (analyze-first-word)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((_ type ((%type %kind arg ...) values) clause ...)
+ (if (and (eq? type '%type) (eq? kind '%kind))
+ (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
+ #'((arg ...) values))
+ (op-case type clause ...)))
+ ((_ type)
+ #f)))
+ (op-case
+ word0
+ ((U8_U8_I16 ! a imm)
+ (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253))
+ imm))
+ ((U8_U8_I16 <- a imm)
+ (values (if (< a (ash 1 8)) a 253)
+ imm))
+ ((U8_U12_U12 ! a b)
+ (values (if (< a (ash 1 12)) a (begin (emit-mov* asm 253 a) 253))
+ (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254))))
+ ((U8_U12_U12 <- a b)
+ (values (if (< a (ash 1 12)) a 253)
+ (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254))))
+ ((U8_U8_U8_U8 ! a b c)
+ (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253))
+ (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254))
+ (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255))))
+ ((U8_U8_U8_U8 <- a b c)
+ (values (if (< a (ash 1 8)) a 253)
+ (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254))
+ (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255))))))
+
+ (define (tail-formals type)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((op-case type (%type arg ...) clause ...)
+ (if (eq? type '%type)
+ (generate-temporaries #'(arg ...))
+ (op-case type clause ...)))
+ ((op-case type)
+ (error "unmatched type" type))))
+ (op-case type
+ (U8_U24 a b)
+ (U8_L24 a label)
+ (U32 a)
+ (I32 imm)
+ (A32 imm)
+ (B32)
+ (N32 label)
+ (S32 label)
+ (L32 label)
+ (LO32 label offset)
+ (X8_U24 a)
+ (X8_L24 label)
+ (B1_X7_L24 a label)
+ (B1_U7_L24 a b label)
+ (B1_X31 a)
+ (B1_X7_U24 a b)))
+
+ (define (shuffle-up dst)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((_ type ((%type ...) exp) clause ...)
+ (if (memq type '(%type ...))
+ #'exp
+ (op-case type clause ...)))
+ ((_ type)
+ (error "unexpected type" type))))
+ (with-syntax ((dst dst))
+ (op-case
+ word0
+ ((U8_U8_I16 U8_U8_U8_U8)
+ (unless (< dst (ash 1 8))
+ (emit-mov* asm dst 253)))
+ ((U8_U12_U12)
+ (unless (< dst (ash 1 12))
+ (emit-mov* asm dst 253))))))
+
+ (and=>
+ (analyze-first-word)
+ (lambda (formals+shuffle)
+ (with-syntax ((emit-name (id-append name #'emit- name))
+ (((formal0 ...) shuffle) formals+shuffle)
+ (((formal* ...) ...) (map tail-formals word*)))
+ (with-syntax (((shuffle-up-dst ...)
+ (if (eq? kind '<-)
+ (syntax-case #'(formal0 ...) ()
+ ((dst . _)
+ (list (shuffle-up #'dst))))
+ '())))
+ #'(lambda (asm formal0 ... formal* ... ...)
+ (call-with-values (lambda () shuffle)
+ (lambda (formal0 ...)
+ (emit-name asm formal0 ... formal* ... ...)))
+ shuffle-up-dst ...))))))
+
+ (define-syntax define-shuffling-assembler
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ #:except (except ...) name opcode kind word0 word* ...)
+ (cond
+ ((or-map (lambda (op) (eq? (syntax->datum #'name) op))
+ (map syntax->datum #'(except ...)))
+ #'(begin))
+ ((shuffling-assembler #'name (syntax->datum #'kind)
+ (syntax->datum #'word0)
+ (map syntax->datum #'(word* ...)))
+ => (lambda (proc)
+ (with-syntax ((emit (id-append #'name
+ (id-append #'name #'emit- #'name)
+ #'*))
+ (proc proc))
+ #'(define emit
+ (let ((emit proc))
+ (hashq-set! assemblers 'name emit)
+ emit)))))
+ (else #'(begin))))))))
+
+(visit-opcodes define-shuffling-assembler #:except (receive mov))
+
+;; Mov and receive are two special cases that can work without wrappers.
+;; Indeed it is important that they do so.
+
+(define (emit-mov* asm dst src)
+ (if (and (< dst (ash 1 12)) (< src (ash 1 12)))
+ (emit-mov asm dst src)
+ (emit-long-mov asm dst src)))
+
+(define (emit-receive* asm dst proc nlocals)
+ (if (and (< dst (ash 1 12)) (< proc (ash 1 12)))
+ (emit-receive asm dst proc nlocals)
+ (begin
+ (emit-receive-values asm proc #t 1)
+ (emit-mov* asm dst (1+ proc))
+ (emit-reset-frame asm nlocals))))
+
+(define (emit-text asm instructions)
+ "Assemble @var{instructions} using the assembler @var{asm}.
+@var{instructions} is a sequence of instructions, expressed as a list of
+lists. This procedure can be called many times before calling
+@code{link-assembly}."
+ (for-each (lambda (inst)
+ (apply (or (hashq-ref assemblers (car inst))
+ (error 'bad-instruction inst))
+ asm
+ (cdr inst)))
+ instructions))
+
+\f
+
+;;;
+;;; The constant table records a topologically sorted set of literal
+;;; constants used by a program. For example, a pair uses its car and
+;;; cdr, a string uses its stringbuf, etc.
+;;;
+;;; Some things we want to add to the constant table are not actually
+;;; Scheme objects: for example, stringbufs, cache cells for toplevel
+;;; references, or cache cells for non-closure procedures. For these we
+;;; define special record types and add instances of those record types
+;;; to the table.
+;;;
+
+(define-inline (immediate? x)
+ "Return @code{#t} if @var{x} is immediate, and @code{#f} otherwise."
+ (not (zero? (logand (object-address x) 6))))
+
+(define-record-type <stringbuf>
+ (make-stringbuf string)
+ stringbuf?
+ (string stringbuf-string))
+
+(define-record-type <static-procedure>
+ (make-static-procedure code)
+ static-procedure?
+ (code static-procedure-code))
+
+(define-record-type <uniform-vector-backing-store>
+ (make-uniform-vector-backing-store bytes element-size)
+ uniform-vector-backing-store?
+ (bytes uniform-vector-backing-store-bytes)
+ (element-size uniform-vector-backing-store-element-size))
+
+(define-record-type <cache-cell>
+ (make-cache-cell scope key)
+ cache-cell?
+ (scope cache-cell-scope)
+ (key cache-cell-key))
+
+(define (simple-vector? obj)
+ (and (vector? obj)
+ (equal? (array-shape obj) (list (list 0 (1- (vector-length obj)))))))
+
+(define (simple-uniform-vector? obj)
+ (and (array? obj)
+ (symbol? (array-type obj))
+ (equal? (array-shape obj) (list (list 0 (1- (array-length obj)))))))
+
+(define (statically-allocatable? x)
+ "Return @code{#t} if a non-immediate constant can be allocated
+statically, and @code{#f} if it would need some kind of runtime
+allocation."
+ (or (pair? x) (string? x) (stringbuf? x) (static-procedure? x) (array? x)))
+
+(define (intern-constant asm obj)
+ "Add an object to the constant table, and return a label that can be
+used to reference it. If the object is already present in the constant
+table, its existing label is used directly."
+ (define (recur obj)
+ (intern-constant asm obj))
+ (define (field dst n obj)
+ (let ((src (recur obj)))
+ (if src
+ (if (statically-allocatable? obj)
+ `((static-patch! ,dst ,n ,src))
+ `((static-ref 1 ,src)
+ (static-set! 1 ,dst ,n)))
+ '())))
+ (define (intern obj label)
+ (cond
+ ((pair? obj)
+ (append (field label 0 (car obj))
+ (field label 1 (cdr obj))))
+ ((simple-vector? obj)
+ (let lp ((i 0) (inits '()))
+ (if (< i (vector-length obj))
+ (lp (1+ i)
+ (append-reverse (field label (1+ i) (vector-ref obj i))
+ inits))
+ (reverse inits))))
+ ((stringbuf? obj) '())
+ ((static-procedure? obj)
+ `((static-patch! ,label 1 ,(static-procedure-code obj))))
+ ((cache-cell? obj) '())
+ ((symbol? obj)
+ `((make-non-immediate 1 ,(recur (symbol->string obj)))
+ (string->symbol 1 1)
+ (static-set! 1 ,label 0)))
+ ((string? obj)
+ `((static-patch! ,label 1 ,(recur (make-stringbuf obj)))))
+ ((keyword? obj)
+ `((static-ref 1 ,(recur (keyword->symbol obj)))
+ (symbol->keyword 1 1)
+ (static-set! 1 ,label 0)))
+ ((number? obj)
+ `((make-non-immediate 1 ,(recur (number->string obj)))
+ (string->number 1 1)
+ (static-set! 1 ,label 0)))
+ ((uniform-vector-backing-store? obj) '())
+ ((simple-uniform-vector? obj)
+ (let ((width (case (array-type obj)
+ ((vu8 u8 s8) 1)
+ ((u16 s16) 2)
+ ;; Bitvectors are addressed in 32-bit units.
+ ;; Although a complex number is 8 or 16 bytes wide,
+ ;; it should be byteswapped in 4 or 8 byte units.
+ ((u32 s32 f32 c32 b) 4)
+ ((u64 s64 f64 c64) 8)
+ (else
+ (error "unhandled array type" obj)))))
+ `((static-patch! ,label 2
+ ,(recur (make-uniform-vector-backing-store
+ (uniform-array->bytevector obj)
+ width))))))
+ ((array? obj)
+ `((static-patch! ,label 1 ,(recur (shared-array-root obj)))))
+ (else
+ (error "don't know how to intern" obj))))
+ (cond
+ ((immediate? obj) #f)
+ ((vhash-assoc obj (asm-constants asm)) => cdr)
+ (else
+ ;; Note that calling intern may mutate asm-constants and asm-inits.
+ (let* ((label (gensym "constant"))
+ (inits (intern obj label)))
+ (set-asm-constants! asm (vhash-cons obj label (asm-constants asm)))
+ (set-asm-inits! asm (append-reverse inits (asm-inits asm)))
+ label))))
+
+(define (intern-non-immediate asm obj)
+ "Intern a non-immediate into the constant table, and return its
+label."
+ (when (immediate? obj)
+ (error "expected a non-immediate" obj))
+ (intern-constant asm obj))
+
+(define (intern-cache-cell asm scope key)
+ "Intern a cache cell into the constant table, and return its label.
+If there is already a cache cell with the given scope and key, it is
+returned instead."
+ (intern-constant asm (make-cache-cell scope key)))
+
+;; Return the label of the cell that holds the module for a scope.
+(define (intern-module-cache-cell asm scope)
+ "Intern a cache cell for a module, and return its label."
+ (intern-cache-cell asm scope #t))
+
+
+\f
+
+;;;
+;;; Macro assemblers bridge the gap between primitive instructions and
+;;; some higher-level operations.
+;;;
+
+(eval-when (expand)
+ (define-syntax define-macro-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (name arg ...) body body* ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(begin
+ (define emit
+ (let ((emit (lambda (arg ...) body body* ...)))
+ (hashq-set! assemblers 'name emit)
+ emit))
+ (export emit))))))))
+
+(define-macro-assembler (load-constant asm dst obj)
+ (cond
+ ((immediate? obj)
+ (let ((bits (object-address obj)))
+ (cond
+ ((and (< dst 256) (zero? (ash bits -16)))
+ (emit-make-short-immediate asm dst obj))
+ ((zero? (ash bits -32))
+ (emit-make-long-immediate asm dst obj))
+ (else
+ (emit-make-long-long-immediate asm dst obj)))))
+ ((statically-allocatable? obj)
+ (emit-make-non-immediate asm dst (intern-non-immediate asm obj)))
+ (else
+ (emit-static-ref asm dst (intern-non-immediate asm obj)))))
+
+(define-macro-assembler (load-static-procedure asm dst label)
+ (let ((loc (intern-constant asm (make-static-procedure label))))
+ (emit-make-non-immediate asm dst loc)))
+
+(define-syntax-rule (define-tc7-macro-assembler name tc7)
+ (define-macro-assembler (name asm slot invert? label)
+ (emit-br-if-tc7 asm slot invert? tc7 label)))
+
+;; Keep in sync with tags.h. Part of Guile's ABI. Currently unused
+;; macro assemblers are commented out. See also
+;; *branching-primcall-arities* in (language cps primitives), the set of
+;; macro-instructions in assembly.scm, and
+;; disassembler.scm:code-annotation.
+;;
+;; FIXME: Define all tc7 values in Scheme in one place, derived from
+;; tags.h.
+(define-tc7-macro-assembler br-if-symbol 5)
+(define-tc7-macro-assembler br-if-variable 7)
+(define-tc7-macro-assembler br-if-vector 13)
+;(define-tc7-macro-assembler br-if-weak-vector 13)
+(define-tc7-macro-assembler br-if-string 21)
+;(define-tc7-macro-assembler br-if-heap-number 23)
+;(define-tc7-macro-assembler br-if-stringbuf 39)
+(define-tc7-macro-assembler br-if-bytevector 77)
+;(define-tc7-macro-assembler br-if-pointer 31)
+;(define-tc7-macro-assembler br-if-hashtable 29)
+;(define-tc7-macro-assembler br-if-fluid 37)
+;(define-tc7-macro-assembler br-if-dynamic-state 45)
+;(define-tc7-macro-assembler br-if-frame 47)
+(define-tc7-macro-assembler br-if-keyword 53)
+;(define-tc7-macro-assembler br-if-vm 55)
+;(define-tc7-macro-assembler br-if-vm-cont 71)
+;(define-tc7-macro-assembler br-if-rtl-program 69)
+;(define-tc7-macro-assembler br-if-weak-set 85)
+;(define-tc7-macro-assembler br-if-weak-table 87)
+;(define-tc7-macro-assembler br-if-array 93)
+(define-tc7-macro-assembler br-if-bitvector 95)
+;(define-tc7-macro-assembler br-if-port 125)
+;(define-tc7-macro-assembler br-if-smob 127)
+
+(define-macro-assembler (begin-program asm label properties)
+ (emit-label asm label)
+ (let ((meta (make-meta label properties (asm-start asm))))
+ (set-asm-meta! asm (cons meta (asm-meta asm)))))
+
+(define-macro-assembler (end-program asm)
+ (let ((meta (car (asm-meta asm))))
+ (set-meta-high-pc! meta (asm-start asm))
+ (set-meta-arities! meta (reverse (meta-arities meta)))))
+
+(define-macro-assembler (begin-standard-arity asm req nlocals alternate)
+ (emit-begin-opt-arity asm req '() #f nlocals alternate))
+
+(define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate)
+ (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate))
+
+(define-macro-assembler (begin-kw-arity asm req opt rest kw-indices
+ allow-other-keys? nlocals alternate)
+ (assert-match req ((? symbol?) ...) "list of symbols")
+ (assert-match opt ((? symbol?) ...) "list of symbols")
+ (assert-match rest (or #f (? symbol?)) "#f or symbol")
+ (assert-match kw-indices (((? keyword?) . (? integer?)) ...)
+ "alist of keyword -> integer")
+ (assert-match allow-other-keys? (? boolean?) "boolean")
+ (assert-match nlocals (? integer?) "integer")
+ (assert-match alternate (or #f (? exact-integer?) (? symbol?)) "#f or symbol")
+ (let* ((meta (car (asm-meta asm)))
+ (arity (make-arity req opt rest kw-indices allow-other-keys?
+ (asm-start asm) #f '()))
+ ;; The procedure itself is in slot 0, in the standard calling
+ ;; convention. For procedure prologues, nreq includes the
+ ;; procedure, so here we add 1.
+ (nreq (1+ (length req)))
+ (nopt (length opt))
+ (rest? (->bool rest)))
+ (set-meta-arities! meta (cons arity (meta-arities meta)))
+ (cond
+ ((or allow-other-keys? (pair? kw-indices))
+ (emit-kw-prelude asm nreq nopt rest? kw-indices allow-other-keys?
+ nlocals alternate))
+ ((or rest? (pair? opt))
+ (emit-opt-prelude asm nreq nopt rest? nlocals alternate))
+ (else
+ (emit-standard-prelude asm nreq nlocals alternate)))))
+
+(define-macro-assembler (end-arity asm)
+ (let ((arity (car (meta-arities (car (asm-meta asm))))))
+ (set-arity-definitions! arity (reverse (arity-definitions arity)))
+ (set-arity-high-pc! arity (asm-start asm))))
+
+;; As noted above, we reserve locals 253 through 255 for shuffling large
+;; operands. However the calling convention has all arguments passed in
+;; a contiguous block. This helper, called after the clause has been
+;; chosen and the keyword/optional/rest arguments have been processed,
+;; shuffles up arguments from slot 253 and higher into their final
+;; allocations.
+;;
+(define (shuffle-up-args asm nargs)
+ (when (> nargs 253)
+ (let ((slot (1- nargs)))
+ (emit-mov asm (+ slot 3) slot)
+ (shuffle-up-args asm (1- nargs)))))
+
+(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
+ (cond
+ (alternate
+ (emit-br-if-nargs-ne asm nreq alternate)
+ (emit-alloc-frame asm nlocals))
+ ((and (< nreq (ash 1 12)) (< (- nlocals nreq) (ash 1 12)))
+ (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
+ (else
+ (emit-assert-nargs-ee asm nreq)
+ (emit-alloc-frame asm nlocals)))
+ (shuffle-up-args asm nreq))
+
+(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
+ (if alternate
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (emit-assert-nargs-ge asm nreq))
+ (cond
+ (rest?
+ (emit-bind-rest asm (+ nreq nopt)))
+ (alternate
+ (emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
+ (else
+ (emit-assert-nargs-le asm (+ nreq nopt))))
+ (emit-alloc-frame asm nlocals)
+ (shuffle-up-args asm (+ nreq nopt (if rest? 1 0))))
+
+(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
+ allow-other-keys? nlocals alternate)
+ (if alternate
+ (begin
+ (emit-br-if-nargs-lt asm nreq alternate)
+ (unless rest?
+ (emit-br-if-npos-gt asm nreq (+ nreq nopt) alternate)))
+ (emit-assert-nargs-ge asm nreq))
+ (let ((ntotal (fold (lambda (kw ntotal)
+ (match kw
+ (((? keyword?) . idx)
+ (max (1+ idx) ntotal))))
+ (+ nreq nopt) kw-indices)))
+ ;; FIXME: port 581f410f
+ (emit-bind-kwargs asm nreq
+ (pack-flags allow-other-keys? rest?)
+ (+ nreq nopt)
+ ntotal
+ (intern-constant asm kw-indices))
+ (emit-alloc-frame asm nlocals)
+ (shuffle-up-args asm ntotal)))
+
+(define-macro-assembler (label asm sym)
+ (hashq-set! (asm-labels asm) sym (asm-start asm)))
+
+(define-macro-assembler (source asm source)
+ (set-asm-sources! asm (acons (asm-start asm) source (asm-sources asm))))
+
+(define-macro-assembler (definition asm name slot)
+ (let* ((arity (car (meta-arities (car (asm-meta asm)))))
+ (def (vector name
+ slot
+ (* (- (asm-start asm) (arity-low-pc arity)) 4))))
+ (set-arity-definitions! arity (cons def (arity-definitions arity)))))
+
+(define-macro-assembler (cache-current-module! asm module scope)
+ (let ((mod-label (intern-module-cache-cell asm scope)))
+ (emit-static-set! asm module mod-label 0)))
+
+(define-macro-assembler (cached-toplevel-box asm dst scope sym bound?)
+ (let ((sym-label (intern-non-immediate asm sym))
+ (mod-label (intern-module-cache-cell asm scope))
+ (cell-label (intern-cache-cell asm scope sym)))
+ (emit-toplevel-box asm dst cell-label mod-label sym-label bound?)))
+
+(define-macro-assembler (cached-module-box asm dst module-name sym public? bound?)
+ (let* ((sym-label (intern-non-immediate asm sym))
+ (key (cons public? module-name))
+ (mod-name-label (intern-constant asm key))
+ (cell-label (intern-cache-cell asm key sym)))
+ (emit-module-box asm dst cell-label mod-name-label sym-label bound?)))
+
+(define-macro-assembler (dead-slot-map asm proc-slot dead-slot-map)
+ (unless (zero? dead-slot-map)
+ (set-asm-dead-slot-maps! asm
+ (cons
+ (cons* (asm-start asm) proc-slot dead-slot-map)
+ (asm-dead-slot-maps asm)))))
+
+\f
+
+;;;
+;;; Helper for linking objects.
+;;;
+
+(define (make-object asm name bv relocs labels . kwargs)
+ "Make a linker object. This helper handles interning the name in the
+shstrtab, assigning the size, allocating a fresh index, and defining a
+corresponding linker symbol for the start of the section."
+ (let ((name-idx (intern-section-name! asm (symbol->string name)))
+ (index (asm-next-section-number asm)))
+ (set-asm-next-section-number! asm (1+ index))
+ (make-linker-object (apply make-elf-section
+ #:index index
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (cons (make-linker-symbol name 0) labels))))
+
+
+\f
+
+;;;
+;;; Linking the constant table. This code is somewhat intertwingled
+;;; with the intern-constant code above, as that procedure also
+;;; residualizes instructions to initialize constants at load time.
+;;;
+
+(define (write-immediate asm buf pos x)
+ (let ((val (object-address x))
+ (endianness (asm-endianness asm)))
+ (case (asm-word-size asm)
+ ((4) (bytevector-u32-set! buf pos val endianness))
+ ((8) (bytevector-u64-set! buf pos val endianness))
+ (else (error "bad word size" asm)))))
+
+(define (emit-init-constants asm)
+ "If there is writable data that needs initialization at runtime, emit
+a procedure to do that and return its label. Otherwise return
+@code{#f}."
+ (let ((inits (asm-inits asm)))
+ (and (not (null? inits))
+ (let ((label (gensym "init-constants")))
+ (emit-text asm
+ `((begin-program ,label ())
+ (assert-nargs-ee/locals 1 1)
+ ,@(reverse inits)
+ (load-constant 1 ,*unspecified*)
+ (return 1)
+ (end-program)))
+ label))))
+
+(define (link-data asm data name)
+ "Link the static data for a program into the @var{name} section (which
+should be .data or .rodata), and return the resulting linker object.
+@var{data} should be a vhash mapping objects to labels."
+ (define (align address alignment)
+ (+ address
+ (modulo (- alignment (modulo address alignment)) alignment)))
+
+ (define tc7-vector 13)
+ (define stringbuf-shared-flag #x100)
+ (define stringbuf-wide-flag #x400)
+ (define tc7-stringbuf 39)
+ (define tc7-narrow-stringbuf
+ (+ tc7-stringbuf stringbuf-shared-flag))
+ (define tc7-wide-stringbuf
+ (+ tc7-stringbuf stringbuf-shared-flag stringbuf-wide-flag))
+ (define tc7-ro-string (+ 21 #x200))
+ (define tc7-program 69)
+ (define tc7-bytevector 77)
+ (define tc7-bitvector 95)
+ (define tc7-array 93)
+
+ (let ((word-size (asm-word-size asm))
+ (endianness (asm-endianness asm)))
+ (define (byte-length x)
+ (cond
+ ((stringbuf? x)
+ (let ((x (stringbuf-string x)))
+ (+ (* 2 word-size)
+ (case (string-bytes-per-char x)
+ ((1) (1+ (string-length x)))
+ ((4) (* (1+ (string-length x)) 4))
+ (else (error "bad string bytes per char" x))))))
+ ((static-procedure? x)
+ (* 2 word-size))
+ ((string? x)
+ (* 4 word-size))
+ ((pair? x)
+ (* 2 word-size))
+ ((simple-vector? x)
+ (* (1+ (vector-length x)) word-size))
+ ((simple-uniform-vector? x)
+ (* 4 word-size))
+ ((uniform-vector-backing-store? x)
+ (bytevector-length (uniform-vector-backing-store-bytes x)))
+ ((array? x)
+ (* word-size (+ 3 (* 3 (array-rank x)))))
+ (else
+ word-size)))
+
+ (define (write-constant-reference buf pos x)
+ ;; The asm-inits will fix up any reference to a non-immediate.
+ (write-immediate asm buf pos (if (immediate? x) x #f)))
+
+ (define (write buf pos obj)
+ (cond
+ ((stringbuf? obj)
+ (let* ((x (stringbuf-string obj))
+ (len (string-length x))
+ (tag (if (= (string-bytes-per-char x) 1)
+ tc7-narrow-stringbuf
+ tc7-wide-stringbuf)))
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tag endianness)
+ (bytevector-u32-set! buf (+ pos 4) len endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tag endianness)
+ (bytevector-u64-set! buf (+ pos 8) len endianness))
+ (else
+ (error "bad word size" asm)))
+ (let ((pos (+ pos (* word-size 2))))
+ (case (string-bytes-per-char x)
+ ((1)
+ (let lp ((i 0))
+ (if (< i len)
+ (let ((u8 (char->integer (string-ref x i))))
+ (bytevector-u8-set! buf (+ pos i) u8)
+ (lp (1+ i)))
+ (bytevector-u8-set! buf (+ pos i) 0))))
+ ((4)
+ (let lp ((i 0))
+ (if (< i len)
+ (let ((u32 (char->integer (string-ref x i))))
+ (bytevector-u32-set! buf (+ pos (* i 4)) u32 endianness)
+ (lp (1+ i)))
+ (bytevector-u32-set! buf (+ pos (* i 4)) 0 endianness))))
+ (else (error "bad string bytes per char" x))))))
+
+ ((static-procedure? obj)
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tc7-program endianness)
+ (bytevector-u32-set! buf (+ pos 4) 0 endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tc7-program endianness)
+ (bytevector-u64-set! buf (+ pos 8) 0 endianness))
+ (else (error "bad word size"))))
+
+ ((cache-cell? obj)
+ (write-immediate asm buf pos #f))
+
+ ((string? obj)
+ (let ((tag (logior tc7-ro-string (ash (string-length obj) 8)))) ; FIXME: unused?
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tc7-ro-string endianness)
+ (write-immediate asm buf (+ pos 4) #f) ; stringbuf
+ (bytevector-u32-set! buf (+ pos 8) 0 endianness)
+ (bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness))
+ ((8)
+ (bytevector-u64-set! buf pos tc7-ro-string endianness)
+ (write-immediate asm buf (+ pos 8) #f) ; stringbuf
+ (bytevector-u64-set! buf (+ pos 16) 0 endianness)
+ (bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness))
+ (else (error "bad word size")))))
+
+ ((pair? obj)
+ (write-constant-reference buf pos (car obj))
+ (write-constant-reference buf (+ pos word-size) (cdr obj)))
+
+ ((simple-vector? obj)
+ (let* ((len (vector-length obj))
+ (tag (logior tc7-vector (ash len 8))))
+ (case word-size
+ ((4) (bytevector-u32-set! buf pos tag endianness))
+ ((8) (bytevector-u64-set! buf pos tag endianness))
+ (else (error "bad word size")))
+ (let lp ((i 0))
+ (when (< i (vector-length obj))
+ (let ((pos (+ pos word-size (* i word-size)))
+ (elt (vector-ref obj i)))
+ (write-constant-reference buf pos elt)
+ (lp (1+ i)))))))
+
+ ((symbol? obj)
+ (write-immediate asm buf pos #f))
+
+ ((keyword? obj)
+ (write-immediate asm buf pos #f))
+
+ ((number? obj)
+ (write-immediate asm buf pos #f))
+
+ ((simple-uniform-vector? obj)
+ (let ((tag (if (bitvector? obj)
+ tc7-bitvector
+ (let ((type-code (array-type-code obj)))
+ (logior tc7-bytevector (ash type-code 7))))))
+ (case word-size
+ ((4)
+ (bytevector-u32-set! buf pos tag endianness)
+ (bytevector-u32-set! buf (+ pos 4)
+ (if (bitvector? obj)
+ (bitvector-length obj)
+ (bytevector-length obj))
+ endianness) ; length
+ (bytevector-u32-set! buf (+ pos 8) 0 endianness) ; pointer
+ (write-immediate asm buf (+ pos 12) #f)) ; owner
+ ((8)
+ (bytevector-u64-set! buf pos tag endianness)
+ (bytevector-u64-set! buf (+ pos 8)
+ (if (bitvector? obj)
+ (bitvector-length obj)
+ (bytevector-length obj))
+ endianness) ; length
+ (bytevector-u64-set! buf (+ pos 16) 0 endianness) ; pointer
+ (write-immediate asm buf (+ pos 24) #f)) ; owner
+ (else (error "bad word size")))))
+
+ ((uniform-vector-backing-store? obj)
+ (let ((bv (uniform-vector-backing-store-bytes obj)))
+ (bytevector-copy! bv 0 buf pos (bytevector-length bv))
+ (unless (or (= 1 (uniform-vector-backing-store-element-size obj))
+ (eq? endianness (native-endianness)))
+ ;; Need to swap units of element-size bytes
+ (error "FIXME: Implement byte order swap"))))
+
+ ((array? obj)
+ (let-values
+ ;; array tag + rank + contp flag: see libguile/arrays.h .
+ (((tag) (logior tc7-array (ash (array-rank obj) 17) (ash 1 16)))
+ ((bv-set! bvs-set!)
+ (case word-size
+ ((4) (values bytevector-u32-set! bytevector-s32-set!))
+ ((8) (values bytevector-u64-set! bytevector-s64-set!))
+ (else (error "bad word size")))))
+ (bv-set! buf pos tag endianness)
+ (write-immediate asm buf (+ pos word-size) #f) ; root vector (fixed later)
+ (bv-set! buf (+ pos (* word-size 2)) 0 endianness) ; base
+ (let lp ((pos (+ pos (* word-size 3)))
+ (bounds (array-shape obj))
+ (incs (shared-array-increments obj)))
+ (when (pair? bounds)
+ (bvs-set! buf pos (first (first bounds)) endianness)
+ (bvs-set! buf (+ pos word-size) (second (first bounds)) endianness)
+ (bvs-set! buf (+ pos (* word-size 2)) (first incs) endianness)
+ (lp (+ pos (* 3 word-size)) (cdr bounds) (cdr incs))))))
+
+ (else
+ (error "unrecognized object" obj))))
+
+ (cond
+ ((vlist-null? data) #f)
+ (else
+ (let* ((byte-len (vhash-fold (lambda (k v len)
+ (+ (byte-length k) (align len 8)))
+ 0 data))
+ (buf (make-bytevector byte-len 0)))
+ (let lp ((i 0) (pos 0) (symbols '()))
+ (if (< i (vlist-length data))
+ (let* ((pair (vlist-ref data i))
+ (obj (car pair))
+ (obj-label (cdr pair)))
+ (write buf pos obj)
+ (lp (1+ i)
+ (align (+ (byte-length obj) pos) 8)
+ (cons (make-linker-symbol obj-label pos) symbols)))
+ (make-object asm name buf '() symbols
+ #:flags (match name
+ ('.data (logior SHF_ALLOC SHF_WRITE))
+ ('.rodata SHF_ALLOC))))))))))
+
+(define (link-constants asm)
+ "Link sections to hold constants needed by the program text emitted
+using @var{asm}.
+
+Returns three values: an object for the .rodata section, an object for
+the .data section, and a label for an initialization procedure. Any of
+these may be @code{#f}."
+ (define (shareable? x)
+ (cond
+ ((stringbuf? x) #t)
+ ((pair? x)
+ (and (immediate? (car x)) (immediate? (cdr x))))
+ ((simple-vector? x)
+ (let lp ((i 0))
+ (or (= i (vector-length x))
+ (and (immediate? (vector-ref x i))
+ (lp (1+ i))))))
+ ((uniform-vector-backing-store? x) #t)
+ (else #f)))
+ (let* ((constants (asm-constants asm))
+ (len (vlist-length constants)))
+ (let lp ((i 0)
+ (ro vlist-null)
+ (rw vlist-null))
+ (if (= i len)
+ (values (link-data asm ro '.rodata)
+ (link-data asm rw '.data)
+ (emit-init-constants asm))
+ (let ((pair (vlist-ref constants i)))
+ (if (shareable? (car pair))
+ (lp (1+ i) (vhash-consq (car pair) (cdr pair) ro) rw)
+ (lp (1+ i) ro (vhash-consq (car pair) (cdr pair) rw))))))))
+
+\f
+
+;;;
+;;; Linking program text.
+;;;
+
+(define (process-relocs buf relocs labels)
+ "Patch up internal x8-s24 relocations, and any s32 relocations that
+reference symbols in the text section. Return a list of linker
+relocations for references to symbols defined outside the text section."
+ (fold
+ (lambda (reloc tail)
+ (match reloc
+ ((type label base word)
+ (let ((abs (hashq-ref labels label))
+ (dst (+ base word)))
+ (case type
+ ((s32)
+ (if abs
+ (let ((rel (- abs base)))
+ (s32-set! buf dst rel)
+ tail)
+ (cons (make-linker-reloc 'rel32/4 (* dst 4) word label)
+ tail)))
+ ((x8-s24)
+ (unless abs
+ (error "unbound near relocation" reloc))
+ (let ((rel (- abs base))
+ (u32 (u32-ref buf dst)))
+ (u32-set! buf dst (pack-u8-s24 (logand u32 #xff) rel))
+ tail))
+ (else (error "bad relocation kind" reloc)))))))
+ '()
+ relocs))
+
+(define (process-labels labels)
+ "Define linker symbols for the label-offset map in @var{labels}.
+The offsets are expected to be expressed in words."
+ (hash-map->list (lambda (label loc)
+ (make-linker-symbol label (* loc 4)))
+ labels))
+
+(define (swap-bytes! buf)
+ "Patch up the text buffer @var{buf}, swapping the endianness of each
+32-bit unit."
+ (unless (zero? (modulo (bytevector-length buf) 4))
+ (error "unexpected length"))
+ (let ((byte-len (bytevector-length buf)))
+ (let lp ((pos 0))
+ (unless (= pos byte-len)
+ (bytevector-u32-set!
+ buf pos
+ (bytevector-u32-ref buf pos (endianness big))
+ (endianness little))
+ (lp (+ pos 4))))))
+
+(define (link-text-object asm)
+ "Link the .rtl-text section, swapping the endianness of the bytes if
+needed."
+ (let ((buf (make-u32vector (asm-pos asm))))
+ (let lp ((pos 0) (prev (reverse (asm-prev asm))))
+ (if (null? prev)
+ (let ((byte-size (* (asm-idx asm) 4)))
+ (bytevector-copy! (asm-cur asm) 0 buf pos byte-size)
+ (unless (eq? (asm-endianness asm) (native-endianness))
+ (swap-bytes! buf))
+ (make-object asm '.rtl-text
+ buf
+ (process-relocs buf (asm-relocs asm)
+ (asm-labels asm))
+ (process-labels (asm-labels asm))))
+ (let ((len (* *block-size* 4)))
+ (bytevector-copy! (car prev) 0 buf pos len)
+ (lp (+ pos len) (cdr prev)))))))
+
+
+\f
+
+;;;
+;;; Create the frame maps. These maps are used by GC to identify dead
+;;; slots in pending call frames, to avoid marking them. We only do
+;;; this when frame makes a non-tail call, as that is the common case.
+;;; Only the topmost frame will see a GC at any other point, but we mark
+;;; top frames conservatively as serializing live slot maps at every
+;;; instruction would take up too much space in the object file.
+;;;
+
+;; The .guile.frame-maps section starts with two packed u32 values: one
+;; indicating the offset of the first byte of the .rtl-text section, and
+;; another indicating the relative offset in bytes of the slots data.
+(define frame-maps-prefix-len 8)
+
+;; Each header is 8 bytes: 4 for the offset from .rtl_text, and 4 for
+;; the offset of the slot map from the beginning of the
+;; .guile.frame-maps section. The length of a frame map depends on the
+;; frame size at the call site, and is not encoded into this section as
+;; it is available at run-time.
+(define frame-map-header-len 8)
+
+(define (link-frame-maps asm)
+ (define (map-byte-length proc-slot)
+ (ceiling-quotient (- proc-slot 2) 8))
+ (define (make-frame-maps maps count map-len)
+ (let* ((endianness (asm-endianness asm))
+ (header-pos frame-maps-prefix-len)
+ (map-pos (+ header-pos (* count frame-map-header-len)))
+ (bv (make-bytevector (+ map-pos map-len) 0)))
+ (bytevector-u32-set! bv 4 map-pos endianness)
+ (let lp ((maps maps) (header-pos header-pos) (map-pos map-pos))
+ (match maps
+ (()
+ (make-object asm '.guile.frame-maps bv
+ (list (make-linker-reloc 'abs32/1 0 0 '.rtl-text))
+ '() #:type SHT_PROGBITS #:flags SHF_ALLOC))
+ (((pos proc-slot . map) . maps)
+ (bytevector-u32-set! bv header-pos (* pos 4) endianness)
+ (bytevector-u32-set! bv (+ header-pos 4) map-pos endianness)
+ (let write-bytes ((map-pos map-pos)
+ (map map)
+ (byte-length (map-byte-length proc-slot)))
+ (if (zero? byte-length)
+ (lp maps (+ header-pos frame-map-header-len) map-pos)
+ (begin
+ (bytevector-u8-set! bv map-pos (logand map #xff))
+ (write-bytes (1+ map-pos) (ash map -8)
+ (1- byte-length))))))))))
+ (match (asm-dead-slot-maps asm)
+ (() #f)
+ (in
+ (let lp ((in in) (out '()) (count 0) (map-len 0))
+ (match in
+ (() (make-frame-maps out count map-len))
+ (((and head (pos proc-slot . map)) . in)
+ (lp in (cons head out)
+ (1+ count)
+ (+ (map-byte-length proc-slot) map-len))))))))
+
+\f
+
+;;;
+;;; Linking other sections of the ELF file, like the dynamic segment,
+;;; the symbol table, etc.
+;;;
+
+;; FIXME: Define these somewhere central, shared with C.
+(define *bytecode-major-version* #x0202)
+(define *bytecode-minor-version* 6)
+
+(define (link-dynamic-section asm text rw rw-init frame-maps)
+ "Link the dynamic section for an ELF image with bytecode @var{text},
+given the writable data section @var{rw} needing fixup from the
+procedure with label @var{rw-init}. @var{rw-init} may be false. If
+@var{rw} is true, it will be added to the GC roots at runtime."
+ (define-syntax-rule (emit-dynamic-section word-size %set-uword! reloc-type)
+ (let* ((endianness (asm-endianness asm))
+ (words 6)
+ (words (if rw (+ words 4) words))
+ (words (if rw-init (+ words 2) words))
+ (words (if frame-maps (+ words 2) words))
+ (bv (make-bytevector (* word-size words) 0))
+ (set-uword!
+ (lambda (i uword)
+ (%set-uword! bv (* i word-size) uword endianness)))
+ (relocs '())
+ (set-label!
+ (lambda (i label)
+ (set! relocs (cons (make-linker-reloc 'reloc-type
+ (* i word-size) 0 label)
+ relocs))
+ (%set-uword! bv (* i word-size) 0 endianness))))
+ (set-uword! 0 DT_GUILE_VM_VERSION)
+ (set-uword! 1 (logior (ash *bytecode-major-version* 16)
+ *bytecode-minor-version*))
+ (set-uword! 2 DT_GUILE_ENTRY)
+ (set-label! 3 '.rtl-text)
+ (when rw
+ ;; Add roots to GC.
+ (set-uword! 4 DT_GUILE_GC_ROOT)
+ (set-label! 5 '.data)
+ (set-uword! 6 DT_GUILE_GC_ROOT_SZ)
+ (set-uword! 7 (bytevector-length (linker-object-bv rw)))
+ (when rw-init
+ (set-uword! 8 DT_INIT) ; constants
+ (set-label! 9 rw-init)))
+ (when frame-maps
+ (set-uword! (- words 4) DT_GUILE_FRAME_MAPS)
+ (set-label! (- words 3) '.guile.frame-maps))
+ (set-uword! (- words 2) DT_NULL)
+ (set-uword! (- words 1) 0)
+ (make-object asm '.dynamic bv relocs '()
+ #:type SHT_DYNAMIC #:flags SHF_ALLOC)))
+ (case (asm-word-size asm)
+ ((4) (emit-dynamic-section 4 bytevector-u32-set! abs32/1))
+ ((8) (emit-dynamic-section 8 bytevector-u64-set! abs64/1))
+ (else (error "bad word size" asm))))
+
+(define (link-shstrtab asm)
+ "Link the string table for the section headers."
+ (intern-section-name! asm ".shstrtab")
+ (make-object asm '.shstrtab
+ (link-string-table! (asm-shstrtab asm))
+ '() '()
+ #:type SHT_STRTAB #:flags 0))
+
+(define (link-symtab text-section asm)
+ (let* ((endianness (asm-endianness asm))
+ (word-size (asm-word-size asm))
+ (size (elf-symbol-len word-size))
+ (meta (reverse (asm-meta asm)))
+ (n (length meta))
+ (strtab (make-string-table))
+ (bv (make-bytevector (* n size) 0)))
+ (define (intern-string! name)
+ (string-table-intern! strtab (if name (symbol->string name) "")))
+ (for-each
+ (lambda (meta n)
+ (let ((name (intern-string! (meta-name meta))))
+ (write-elf-symbol bv (* n size) endianness word-size
+ (make-elf-symbol
+ #:name name
+ ;; Symbol value and size are measured in
+ ;; bytes, not u32s.
+ #:value (* 4 (meta-low-pc meta))
+ #:size (* 4 (- (meta-high-pc meta)
+ (meta-low-pc meta)))
+ #:type STT_FUNC
+ #:visibility STV_HIDDEN
+ #:shndx (elf-section-index text-section)))))
+ meta (iota n))
+ (let ((strtab (make-object asm '.strtab
+ (link-string-table! strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.symtab
+ bv
+ '() '()
+ #:type SHT_SYMTAB #:flags 0 #:entsize size
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab))))
+
+;;; The .guile.arities section describes the arities that a function can
+;;; have. It is in two parts: a sorted array of headers describing
+;;; basic arities, and an array of links out to a string table (and in
+;;; the case of keyword arguments, to the data section) for argument
+;;; names. The whole thing is prefixed by a uint32 indicating the
+;;; offset of the end of the headers array.
+;;;
+;;; The arity headers array is a packed array of structures of the form:
+;;;
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; uint32_t nlocals;
+;;; }
+;;;
+;;; All of the offsets and addresses are 32 bits. We can expand in the
+;;; future to use 64-bit offsets if appropriate, but there are other
+;;; aspects of bytecode that constrain us to a total image that fits in
+;;; 32 bits, so for the moment we'll simplify the problem space.
+;;;
+;;; The following flags values are defined:
+;;;
+;;; #x1: has-rest?
+;;; #x2: allow-other-keys?
+;;; #x4: has-keyword-args?
+;;; #x8: is-case-lambda?
+;;; #x10: is-in-case-lambda?
+;;;
+;;; Functions with a single arity specify their number of required and
+;;; optional arguments in nreq and nopt, and do not have the
+;;; is-case-lambda? flag set. Their "offset" member links to an array
+;;; of pointers into the associated .guile.arities.strtab string table,
+;;; identifying the argument names. This offset is relative to the
+;;; start of the .guile.arities section.
+;;;
+;;; If the arity has keyword arguments -- if has-keyword-args? is set in
+;;; the flags -- the first uint32 pointed to by offset encodes a link to
+;;; the "keyword indices" literal, in the data section. Then follow the
+;;; names for all locals, in order, as uleb128 values. The required
+;;; arguments will be the first locals, followed by the optionals,
+;;; followed by the rest argument if if has-rest? is set. The names
+;;; point into the associated string table section.
+;;;
+;;; Functions with no arities have no arities information present in the
+;;; .guile.arities section.
+;;;
+;;; Functions with multiple arities are preceded by a header with
+;;; is-case-lambda? set. All other fields are 0, except low-pc and
+;;; high-pc which should be the bounds of the whole function. Headers
+;;; for the individual arities follow, with the is-in-case-lambda? flag
+;;; set. In this way the whole headers array is sorted in increasing
+;;; low-pc order, and case-lambda clauses are contained within the
+;;; [low-pc, high-pc] of the case-lambda header.
+
+;; Length of the prefix to the arities section, in bytes.
+(define arities-prefix-len 4)
+
+;; Length of an arity header, in bytes.
+(define arity-header-len (* 7 4))
+
+;; Some helpers.
+(define (put-uleb128 port val)
+ (let lp ((val val))
+ (let ((next (ash val -7)))
+ (if (zero? next)
+ (put-u8 port val)
+ (begin
+ (put-u8 port (logior #x80 (logand val #x7f)))
+ (lp next))))))
+
+(define (put-sleb128 port val)
+ (let lp ((val val))
+ (if (<= 0 (+ val 64) 127)
+ (put-u8 port (logand val #x7f))
+ (begin
+ (put-u8 port (logior #x80 (logand val #x7f)))
+ (lp (ash val -7))))))
+
+(define (port-position port)
+ (seek port 0 SEEK_CUR))
+
+(define-inline (pack-arity-flags has-rest? allow-other-keys?
+ has-keyword-args? is-case-lambda?
+ is-in-case-lambda?)
+ (logior (if has-rest? (ash 1 0) 0)
+ (if allow-other-keys? (ash 1 1) 0)
+ (if has-keyword-args? (ash 1 2) 0)
+ (if is-case-lambda? (ash 1 3) 0)
+ (if is-in-case-lambda? (ash 1 4) 0)))
+
+(define (write-arities asm metas headers names-port strtab)
+ (define (write-header pos low-pc high-pc offset flags nreq nopt nlocals)
+ (unless (<= (+ nreq nopt) nlocals)
+ (error "forgot to emit definition instructions?"))
+ (bytevector-u32-set! headers pos (* low-pc 4) (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 4) (* high-pc 4) (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 8) offset (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 12) flags (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 16) nreq (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 20) nopt (asm-endianness asm))
+ (bytevector-u32-set! headers (+ pos 24) nlocals (asm-endianness asm)))
+ (define (write-kw-indices kw-indices relocs)
+ ;; FIXME: Assert that kw-indices is already interned.
+ (if (pair? kw-indices)
+ (let ((pos (+ (bytevector-length headers)
+ (port-position names-port)))
+ (label (intern-constant asm kw-indices)))
+ (put-bytevector names-port #vu8(0 0 0 0))
+ (cons (make-linker-reloc 'abs32/1 pos 0 label) relocs))
+ relocs))
+ (define (write-arity pos arity in-case-lambda? relocs)
+ (write-header pos (arity-low-pc arity)
+ (arity-high-pc arity)
+ ;; FIXME: Seems silly to add on bytevector-length of
+ ;; headers, given the arities-prefix.
+ (+ (bytevector-length headers) (port-position names-port))
+ (pack-arity-flags (arity-rest arity)
+ (arity-allow-other-keys? arity)
+ (pair? (arity-kw-indices arity))
+ #f
+ in-case-lambda?)
+ (length (arity-req arity))
+ (length (arity-opt arity))
+ (length (arity-definitions arity)))
+ (let ((relocs (write-kw-indices (arity-kw-indices arity) relocs)))
+ ;; Write local names.
+ (let lp ((definitions (arity-definitions arity)))
+ (match definitions
+ (() relocs)
+ ((#(name slot def) . definitions)
+ (let ((sym (if (symbol? name)
+ (string-table-intern! strtab (symbol->string name))
+ 0)))
+ (put-uleb128 names-port sym)
+ (lp definitions)))))
+ ;; Now write their definitions.
+ (let lp ((definitions (arity-definitions arity)))
+ (match definitions
+ (() relocs)
+ ((#(name slot def) . definitions)
+ (put-uleb128 names-port def)
+ (put-uleb128 names-port slot)
+ (lp definitions))))))
+ (let lp ((metas metas) (pos arities-prefix-len) (relocs '()))
+ (match metas
+ (()
+ (unless (= pos (bytevector-length headers))
+ (error "expected to fully fill the bytevector"
+ pos (bytevector-length headers)))
+ relocs)
+ ((meta . metas)
+ (match (meta-arities meta)
+ (() (lp metas pos relocs))
+ ((arity)
+ (lp metas
+ (+ pos arity-header-len)
+ (write-arity pos arity #f relocs)))
+ (arities
+ ;; Write a case-lambda header, then individual arities.
+ ;; The case-lambda header's offset link is 0.
+ (write-header pos (meta-low-pc meta) (meta-high-pc meta) 0
+ (pack-arity-flags #f #f #f #t #f) 0 0 0)
+ (let lp* ((arities arities) (pos (+ pos arity-header-len))
+ (relocs relocs))
+ (match arities
+ (() (lp metas pos relocs))
+ ((arity . arities)
+ (lp* arities
+ (+ pos arity-header-len)
+ (write-arity pos arity #t relocs)))))))))))
+
+(define (link-arities asm)
+ (define (meta-arities-header-size meta)
+ (define (lambda-size arity)
+ arity-header-len)
+ (define (case-lambda-size arities)
+ (fold +
+ arity-header-len ;; case-lambda header
+ (map lambda-size arities))) ;; the cases
+ (match (meta-arities meta)
+ (() 0)
+ ((arity) (lambda-size arity))
+ (arities (case-lambda-size arities))))
+
+ (define (bytevector-append a b)
+ (let ((out (make-bytevector (+ (bytevector-length a)
+ (bytevector-length b)))))
+ (bytevector-copy! a 0 out 0 (bytevector-length a))
+ (bytevector-copy! b 0 out (bytevector-length a) (bytevector-length b))
+ out))
+
+ (let* ((endianness (asm-endianness asm))
+ (metas (reverse (asm-meta asm)))
+ (header-size (fold (lambda (meta size)
+ (+ size (meta-arities-header-size meta)))
+ arities-prefix-len
+ metas))
+ (strtab (make-string-table))
+ (headers (make-bytevector header-size 0)))
+ (bytevector-u32-set! headers 0 (bytevector-length headers) endianness)
+ (let-values (((names-port get-name-bv) (open-bytevector-output-port)))
+ (let* ((relocs (write-arities asm metas headers names-port strtab))
+ (strtab (make-object asm '.guile.arities.strtab
+ (link-string-table! strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.guile.arities
+ (bytevector-append headers (get-name-bv))
+ relocs '()
+ #:type SHT_PROGBITS #:flags 0
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab)))))
+
+;;;
+;;; The .guile.docstrs section is a packed, sorted array of (pc, str)
+;;; values. Pc and str are both 32 bits wide. (Either could change to
+;;; 64 bits if appropriate in the future.) Pc is the address of the
+;;; entry to a program, relative to the start of the text section, in
+;;; bytes, and str is an index into the associated .guile.docstrs.strtab
+;;; string table section.
+;;;
+
+;; The size of a docstrs entry, in bytes.
+(define docstr-size 8)
+
+(define (link-docstrs asm)
+ (define (find-docstrings)
+ (filter-map (lambda (meta)
+ (define (is-documentation? pair)
+ (eq? (car pair) 'documentation))
+ (let* ((props (meta-properties meta))
+ (tail (find-tail is-documentation? props)))
+ (and tail
+ (not (find-tail is-documentation? (cdr tail)))
+ (string? (cdar tail))
+ (cons (* 4 (meta-low-pc meta)) (cdar tail)))))
+ (reverse (asm-meta asm))))
+ (let* ((endianness (asm-endianness asm))
+ (docstrings (find-docstrings))
+ (strtab (make-string-table))
+ (bv (make-bytevector (* (length docstrings) docstr-size) 0)))
+ (fold (lambda (pair pos)
+ (match pair
+ ((pc . string)
+ (bytevector-u32-set! bv pos pc endianness)
+ (bytevector-u32-set! bv (+ pos 4)
+ (string-table-intern! strtab string)
+ endianness)
+ (+ pos docstr-size))))
+ 0
+ docstrings)
+ (let ((strtab (make-object asm '.guile.docstrs.strtab
+ (link-string-table! strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.guile.docstrs
+ bv
+ '() '()
+ #:type SHT_PROGBITS #:flags 0
+ #:link (elf-section-index
+ (linker-object-section strtab)))
+ strtab))))
+
+;;;
+;;; The .guile.procprops section is a packed, sorted array of (pc, addr)
+;;; values. Pc and addr are both 32 bits wide. (Either could change to
+;;; 64 bits if appropriate in the future.) Pc is the address of the
+;;; entry to a program, relative to the start of the text section, and
+;;; addr is the address of the associated properties alist, relative to
+;;; the start of the ELF image.
+;;;
+;;; Since procedure properties are stored in the data sections, we need
+;;; to link the procedures property section first. (Note that this
+;;; constraint does not apply to the arities section, which may
+;;; reference the data sections via the kw-indices literal, because
+;;; assembling the text section already makes sure that the kw-indices
+;;; are interned.)
+;;;
+
+;; The size of a procprops entry, in bytes.
+(define procprops-size 8)
+
+(define (link-procprops asm)
+ (define (assoc-remove-one alist key value-pred)
+ (match alist
+ (() '())
+ ((((? (lambda (x) (eq? x key))) . value) . alist)
+ (if (value-pred value)
+ alist
+ (acons key value alist)))
+ (((k . v) . alist)
+ (acons k v (assoc-remove-one alist key value-pred)))))
+ (define (props-without-name-or-docstring meta)
+ (assoc-remove-one
+ (assoc-remove-one (meta-properties meta) 'name (lambda (x) #t))
+ 'documentation
+ string?))
+ (define (find-procprops)
+ (filter-map (lambda (meta)
+ (let ((props (props-without-name-or-docstring meta)))
+ (and (pair? props)
+ (cons (* 4 (meta-low-pc meta)) props))))
+ (reverse (asm-meta asm))))
+ (let* ((endianness (asm-endianness asm))
+ (procprops (find-procprops))
+ (bv (make-bytevector (* (length procprops) procprops-size) 0)))
+ (let lp ((procprops procprops) (pos 0) (relocs '()))
+ (match procprops
+ (()
+ (make-object asm '.guile.procprops
+ bv
+ relocs '()
+ #:type SHT_PROGBITS #:flags 0))
+ (((pc . props) . procprops)
+ (bytevector-u32-set! bv pos pc endianness)
+ (lp procprops
+ (+ pos procprops-size)
+ (cons (make-linker-reloc 'abs32/1 (+ pos 4) 0
+ (intern-constant asm props))
+ relocs)))))))
+
+;;;
+;;; The DWARF .debug_info, .debug_abbrev, .debug_str, and .debug_loc
+;;; sections provide line number and local variable liveness
+;;; information. Their format is defined by the DWARF
+;;; specifications.
+;;;
+
+(define (asm-language asm)
+ ;; FIXME: Plumb language through to the assembler.
+ 'scheme)
+
+;; -> 5 values: .debug_info, .debug_abbrev, .debug_str, .debug_loc, .debug_lines
+(define (link-debug asm)
+ (define (put-s8 port val)
+ (let ((bv (make-bytevector 1)))
+ (bytevector-s8-set! bv 0 val)
+ (put-bytevector port bv)))
+
+ (define (put-u16 port val)
+ (let ((bv (make-bytevector 2)))
+ (bytevector-u16-set! bv 0 val (asm-endianness asm))
+ (put-bytevector port bv)))
+
+ (define (put-u32 port val)
+ (let ((bv (make-bytevector 4)))
+ (bytevector-u32-set! bv 0 val (asm-endianness asm))
+ (put-bytevector port bv)))
+
+ (define (put-u64 port val)
+ (let ((bv (make-bytevector 8)))
+ (bytevector-u64-set! bv 0 val (asm-endianness asm))
+ (put-bytevector port bv)))
+
+ (define (meta->subprogram-die meta)
+ `(subprogram
+ (@ ,@(cond
+ ((meta-name meta)
+ => (lambda (name) `((name ,(symbol->string name)))))
+ (else
+ '()))
+ (low-pc ,(meta-label meta))
+ (high-pc ,(* 4 (- (meta-high-pc meta) (meta-low-pc meta)))))))
+
+ (define (make-compile-unit-die asm)
+ `(compile-unit
+ (@ (producer ,(string-append "Guile " (version)))
+ (language ,(asm-language asm))
+ (low-pc .rtl-text)
+ (high-pc ,(* 4 (asm-pos asm)))
+ (stmt-list 0))
+ ,@(map meta->subprogram-die (reverse (asm-meta asm)))))
+
+ (let-values (((die-port get-die-bv) (open-bytevector-output-port))
+ ((die-relocs) '())
+ ((abbrev-port get-abbrev-bv) (open-bytevector-output-port))
+ ;; (tag has-kids? attrs forms) -> code
+ ((abbrevs) vlist-null)
+ ((strtab) (make-string-table))
+ ((line-port get-line-bv) (open-bytevector-output-port))
+ ((line-relocs) '())
+ ;; file -> code
+ ((files) vlist-null))
+
+ (define (write-abbrev code tag has-children? attrs forms)
+ (put-uleb128 abbrev-port code)
+ (put-uleb128 abbrev-port (tag-name->code tag))
+ (put-u8 abbrev-port (children-name->code (if has-children? 'yes 'no)))
+ (for-each (lambda (attr form)
+ (put-uleb128 abbrev-port (attribute-name->code attr))
+ (put-uleb128 abbrev-port (form-name->code form)))
+ attrs forms)
+ (put-uleb128 abbrev-port 0)
+ (put-uleb128 abbrev-port 0))
+
+ (define (intern-abbrev tag has-children? attrs forms)
+ (let ((key (list tag has-children? attrs forms)))
+ (match (vhash-assoc key abbrevs)
+ ((_ . code) code)
+ (#f (let ((code (1+ (vlist-length abbrevs))))
+ (set! abbrevs (vhash-cons key code abbrevs))
+ (write-abbrev code tag has-children? attrs forms)
+ code)))))
+
+ (define (intern-file file)
+ (match (vhash-assoc file files)
+ ((_ . code) code)
+ (#f (let ((code (1+ (vlist-length files))))
+ (set! files (vhash-cons file code files))
+ code))))
+
+ (define (write-sources)
+ ;; Choose line base and line range values that will allow for an
+ ;; address advance range of 16 words. The special opcode range is
+ ;; from 10 to 255, so 246 values.
+ (define base -4)
+ (define range 15)
+
+ (let lp ((sources (asm-sources asm)) (out '()))
+ (match sources
+ (((pc . s) . sources)
+ (let ((file (assq-ref s 'filename))
+ (line (assq-ref s 'line))
+ (col (assq-ref s 'column)))
+ (lp sources
+ ;; Guile line and column numbers are 0-indexed, but
+ ;; they are 1-indexed for DWARF.
+ (cons (list pc
+ (if (string? file) (intern-file file) 0)
+ (if line (1+ line))
+ (if col (1+ col)))
+ out))))
+ (()
+ ;; Compilation unit header for .debug_line. We write in
+ ;; DWARF 2 format because more tools understand it than DWARF
+ ;; 4, which incompatibly adds another field to this header.
+
+ (put-u32 line-port 0) ; Length; will patch later.
+ (put-u16 line-port 2) ; DWARF 2 format.
+ (put-u32 line-port 0) ; Prologue length; will patch later.
+ (put-u8 line-port 4) ; Minimum instruction length: 4 bytes.
+ (put-u8 line-port 1) ; Default is-stmt: true.
+
+ (put-s8 line-port base) ; Line base. See the DWARF standard.
+ (put-u8 line-port range) ; Line range. See the DWARF standard.
+ (put-u8 line-port 10) ; Opcode base: the first "special" opcode.
+
+ ;; A table of the number of uleb128 arguments taken by each
+ ;; of the standard opcodes.
+ (put-u8 line-port 0) ; 1: copy
+ (put-u8 line-port 1) ; 2: advance-pc
+ (put-u8 line-port 1) ; 3: advance-line
+ (put-u8 line-port 1) ; 4: set-file
+ (put-u8 line-port 1) ; 5: set-column
+ (put-u8 line-port 0) ; 6: negate-stmt
+ (put-u8 line-port 0) ; 7: set-basic-block
+ (put-u8 line-port 0) ; 8: const-add-pc
+ (put-u8 line-port 1) ; 9: fixed-advance-pc
+
+ ;; Include directories, as a zero-terminated sequence of
+ ;; nul-terminated strings. Nothing, for the moment.
+ (put-u8 line-port 0)
+
+ ;; File table. For each file that contributes to this
+ ;; compilation unit, a nul-terminated file name string, and a
+ ;; uleb128 for each of directory the file was found in, the
+ ;; modification time, and the file's size in bytes. We pass
+ ;; zero for the latter three fields.
+ (vlist-fold-right
+ (lambda (pair seed)
+ (match pair
+ ((file . code)
+ (put-bytevector line-port (string->utf8 file))
+ (put-u8 line-port 0)
+ (put-uleb128 line-port 0) ; directory
+ (put-uleb128 line-port 0) ; mtime
+ (put-uleb128 line-port 0))) ; size
+ seed)
+ #f
+ files)
+ (put-u8 line-port 0) ; 0 byte terminating file list.
+
+ ;; Patch prologue length.
+ (let ((offset (port-position line-port)))
+ (seek line-port 6 SEEK_SET)
+ (put-u32 line-port (- offset 10))
+ (seek line-port offset SEEK_SET))
+
+ ;; Now write the statement program.
+ (let ()
+ (define (extended-op opcode payload-len)
+ (put-u8 line-port 0) ; extended op
+ (put-uleb128 line-port (1+ payload-len)) ; payload-len + opcode
+ (put-uleb128 line-port opcode))
+ (define (set-address sym)
+ (define (add-reloc! kind)
+ (set! line-relocs
+ (cons (make-linker-reloc kind
+ (port-position line-port)
+ 0
+ sym)
+ line-relocs)))
+ (match (asm-word-size asm)
+ (4
+ (extended-op 2 4)
+ (add-reloc! 'abs32/1)
+ (put-u32 line-port 0))
+ (8
+ (extended-op 2 8)
+ (add-reloc! 'abs64/1)
+ (put-u64 line-port 0))))
+ (define (end-sequence pc)
+ (let ((pc-inc (- (asm-pos asm) pc)))
+ (put-u8 line-port 2) ; advance-pc
+ (put-uleb128 line-port pc-inc))
+ (extended-op 1 0))
+ (define (advance-pc pc-inc line-inc)
+ (let ((spec (+ (- line-inc base) (* pc-inc range) 10)))
+ (cond
+ ((or (< line-inc base) (>= line-inc (+ base range)))
+ (advance-line line-inc)
+ (advance-pc pc-inc 0))
+ ((<= spec 255)
+ (put-u8 line-port spec))
+ ((< spec 500)
+ (put-u8 line-port 8) ; const-advance-pc
+ (advance-pc (- pc-inc (floor/ (- 255 10) range))
+ line-inc))
+ (else
+ (put-u8 line-port 2) ; advance-pc
+ (put-uleb128 line-port pc-inc)
+ (advance-pc 0 line-inc)))))
+ (define (advance-line inc)
+ (put-u8 line-port 3)
+ (put-sleb128 line-port inc))
+ (define (set-file file)
+ (put-u8 line-port 4)
+ (put-uleb128 line-port file))
+ (define (set-column col)
+ (put-u8 line-port 5)
+ (put-uleb128 line-port col))
+
+ (set-address '.rtl-text)
+
+ (let lp ((in out) (pc 0) (file 1) (line 1) (col 0))
+ (match in
+ (()
+ (when (null? out)
+ ;; There was no source info in the first place. Set
+ ;; file register to 0 before adding final row.
+ (set-file 0))
+ (end-sequence pc))
+ (((pc* file* line* col*) . in*)
+ (cond
+ ((and (eqv? file file*) (eqv? line line*) (eqv? col col*))
+ (lp in* pc file line col))
+ (else
+ (unless (eqv? col col*)
+ (set-column col*))
+ (unless (eqv? file file*)
+ (set-file file*))
+ (advance-pc (- pc* pc) (- line* line))
+ (lp in* pc* file* line* col*)))))))))))
+
+ (define (compute-code attr val)
+ (match attr
+ ('name (string-table-intern! strtab val))
+ ('low-pc val)
+ ('high-pc val)
+ ('producer (string-table-intern! strtab val))
+ ('language (language-name->code val))
+ ('stmt-list val)))
+
+ (define (choose-form attr val code)
+ (cond
+ ((string? val) 'strp)
+ ((eq? attr 'stmt-list) 'sec-offset)
+ ((eq? attr 'low-pc) 'addr)
+ ((exact-integer? code)
+ (cond
+ ((< code 0) 'sleb128)
+ ((<= code #xff) 'data1)
+ ((<= code #xffff) 'data2)
+ ((<= code #xffffffff) 'data4)
+ ((<= code #xffffffffffffffff) 'data8)
+ (else 'uleb128)))
+ (else (error "unhandled case" attr val code))))
+
+ (define (add-die-relocation! kind sym)
+ (set! die-relocs
+ (cons (make-linker-reloc kind (port-position die-port) 0 sym)
+ die-relocs)))
+
+ (define (write-value code form)
+ (match form
+ ('data1 (put-u8 die-port code))
+ ('data2 (put-u16 die-port code))
+ ('data4 (put-u32 die-port code))
+ ('data8 (put-u64 die-port code))
+ ('uleb128 (put-uleb128 die-port code))
+ ('sleb128 (put-sleb128 die-port code))
+ ('addr
+ (match (asm-word-size asm)
+ (4
+ (add-die-relocation! 'abs32/1 code)
+ (put-u32 die-port 0))
+ (8
+ (add-die-relocation! 'abs64/1 code)
+ (put-u64 die-port 0))))
+ ('sec-offset (put-u32 die-port code))
+ ('strp (put-u32 die-port code))))
+
+ (define (write-die die)
+ (match die
+ ((tag ('@ (attrs vals) ...) children ...)
+ (let* ((codes (map compute-code attrs vals))
+ (forms (map choose-form attrs vals codes))
+ (has-children? (not (null? children)))
+ (abbrev-code (intern-abbrev tag has-children? attrs forms)))
+ (put-uleb128 die-port abbrev-code)
+ (for-each write-value codes forms)
+ (when has-children?
+ (for-each write-die children)
+ (put-uleb128 die-port 0))))))
+
+ ;; Compilation unit header.
+ (put-u32 die-port 0) ; Length; will patch later.
+ (put-u16 die-port 4) ; DWARF 4.
+ (put-u32 die-port 0) ; Abbrevs offset.
+ (put-u8 die-port (asm-word-size asm)) ; Address size.
+
+ (write-die (make-compile-unit-die asm))
+
+ ;; Terminate the abbrevs list.
+ (put-uleb128 abbrev-port 0)
+
+ (write-sources)
+
+ (values (let ((bv (get-die-bv)))
+ ;; Patch DWARF32 length.
+ (bytevector-u32-set! bv 0 (- (bytevector-length bv) 4)
+ (asm-endianness asm))
+ (make-object asm '.debug_info bv die-relocs '()
+ #:type SHT_PROGBITS #:flags 0))
+ (make-object asm '.debug_abbrev (get-abbrev-bv) '() '()
+ #:type SHT_PROGBITS #:flags 0)
+ (make-object asm '.debug_str (link-string-table! strtab) '() '()
+ #:type SHT_PROGBITS #:flags 0)
+ (make-object asm '.debug_loc #vu8() '() '()
+ #:type SHT_PROGBITS #:flags 0)
+ (let ((bv (get-line-bv)))
+ ;; Patch DWARF32 length.
+ (bytevector-u32-set! bv 0 (- (bytevector-length bv) 4)
+ (asm-endianness asm))
+ (make-object asm '.debug_line bv line-relocs '()
+ #:type SHT_PROGBITS #:flags 0)))))
+
+(define (link-objects asm)
+ (let*-values (;; Link procprops before constants, because it probably
+ ;; interns more constants.
+ ((procprops) (link-procprops asm))
+ ((ro rw rw-init) (link-constants asm))
+ ;; Link text object after constants, so that the
+ ;; constants initializer gets included.
+ ((text) (link-text-object asm))
+ ((frame-maps) (link-frame-maps asm))
+ ((dt) (link-dynamic-section asm text rw rw-init frame-maps))
+ ((symtab strtab) (link-symtab (linker-object-section text) asm))
+ ((arities arities-strtab) (link-arities asm))
+ ((docstrs docstrs-strtab) (link-docstrs asm))
+ ((dinfo dabbrev dstrtab dloc dline) (link-debug asm))
+ ;; This needs to be linked last, because linking other
+ ;; sections adds entries to the string table.
+ ((shstrtab) (link-shstrtab asm)))
+ (filter identity
+ (list text ro frame-maps rw dt symtab strtab
+ arities arities-strtab
+ docstrs docstrs-strtab procprops
+ dinfo dabbrev dstrtab dloc dline
+ shstrtab))))
+
+
+\f
+
+;;;
+;;; High-level public interfaces.
+;;;
+
+(define* (link-assembly asm #:key (page-aligned? #t))
+ "Produce an ELF image from the code and data emitted into @var{asm}.
+The result is a bytevector, by default linked so that read-only and
+writable data are on separate pages. Pass @code{#:page-aligned? #f} to
+disable this behavior."
+ (link-elf (link-objects asm) #:page-aligned? page-aligned?))
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2013 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 (system vm vm)
#:use-module (system vm frame)
#:use-module (system vm program)
+ #:use-module (system vm debug)
+ #:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
#:export (with-code-coverage
coverage-data?
instrumented-source-files
;;; Gathering coverage data.
;;;
-(define (hashq-proc proc n)
- ;; Return the hash of PROC's objcode.
- (hashq (program-objcode proc) n))
-
-(define (assq-proc proc alist)
- ;; Instead of really looking for PROC in ALIST, look for the objcode of PROC.
- ;; IOW the alist is indexed by procedures, not objcodes, but those procedures
- ;; are taken as an arbitrary representative of all the procedures (closures)
- ;; sharing that objcode. This can significantly reduce memory consumption.
- (let ((code (program-objcode proc)))
- (find (lambda (pair)
- (eq? code (program-objcode (car pair))))
- alist)))
-
-(define (with-code-coverage vm thunk)
- "Run THUNK, a zero-argument procedure, using VM; instrument VM to collect code
-coverage data. Return code coverage data and the values returned by THUNK."
-
- (define procedure->ip-counts
- ;; Mapping from procedures to hash tables; said hash tables map instruction
- ;; pointers to the number of times they were executed.
- (make-hash-table 500))
+(define (with-code-coverage thunk)
+ "Run THUNK, a zero-argument procedure, while instrumenting Guile's VM to
+collect code coverage data. Return code coverage data and the values returned
+by THUNK."
+
+ (define ip-counts
+ ;; A table mapping instruction pointers to the number of times they were
+ ;; executed.
+ (make-hash-table 5000))
(define (collect! frame)
- ;; Update PROCEDURE->IP-COUNTS with info from FRAME.
- (let* ((proc (frame-procedure frame))
- (ip (frame-instruction-pointer frame))
- (proc-entry (hashx-create-handle! hashq-proc assq-proc
- procedure->ip-counts proc #f)))
- (let loop ()
- (define ip-counts (cdr proc-entry))
- (if ip-counts
- (let ((ip-entry (hashv-create-handle! ip-counts ip 0)))
- (set-cdr! ip-entry (+ (cdr ip-entry) 1)))
- (begin
- (set-cdr! proc-entry (make-hash-table))
- (loop))))))
+ ;; Update IP-COUNTS with info from FRAME.
+ (let* ((ip (frame-instruction-pointer frame))
+ (ip-entry (hashv-create-handle! ip-counts ip 0)))
+ (set-cdr! ip-entry (+ (cdr ip-entry) 1))))
;; FIXME: It's unclear what the dynamic-wind is for, given that if the
;; VM is different from the current one, continuations will not be
;; resumable.
(call-with-values (lambda ()
- (let ((level (vm-trace-level vm))
- (hook (vm-next-hook vm)))
+ (let ((level (vm-trace-level))
+ (hook (vm-next-hook)))
(dynamic-wind
(lambda ()
- (set-vm-trace-level! vm (+ level 1))
+ (set-vm-trace-level! (+ level 1))
(add-hook! hook collect!))
(lambda ()
- (call-with-vm vm thunk))
+ (call-with-vm thunk))
(lambda ()
- (set-vm-trace-level! vm level)
+ (set-vm-trace-level! level)
(remove-hook! hook collect!)))))
(lambda args
- (apply values (make-coverage-data procedure->ip-counts) args))))
+ (apply values (make-coverage-data ip-counts) args))))
+
+
+\f
+
+;;;
+;;; Source chunks.
+;;;
+
+(define-record-type <source-chunk>
+ (make-source-chunk base length sources)
+ source-chunk?
+ (base source-chunk-base)
+ (length source-chunk-length)
+ (sources source-chunk-sources))
+
+(set-record-type-printer!
+ <source-chunk>
+ (lambda (obj port)
+ (format port "<source-chunk #x~x-#x~x>"
+ (source-chunk-base obj)
+ (+ (source-chunk-base obj) (source-chunk-length obj)))))
+
+(define (compute-source-chunk ctx)
+ "Build a sorted vector of source information for a given debugging
+context (ELF image). The return value is a @code{<source-chunk>}, which also
+records the address range to which the source information applies."
+ (make-source-chunk
+ (debug-context-base ctx)
+ (debug-context-length ctx)
+ ;; The source locations are sorted already, but collected in reverse order.
+ (list->vector (reverse! (fold-source-locations cons '() ctx)))))
+
+(define (all-source-information)
+ "Build and return a vector of source information corresponding to all
+loaded code. The vector will be sorted by ascending address order."
+ (sort! (list->vector (fold-all-debug-contexts
+ (lambda (ctx seed)
+ (cons (compute-source-chunk ctx) seed))
+ '()))
+ (lambda (x y)
+ (< (source-chunk-base x) (source-chunk-base y)))))
\f
;;;
;;;
(define-record-type <coverage-data>
- (%make-coverage-data procedure->ip-counts
- procedure->sources
+ (%make-coverage-data ip-counts
+ sources
file->procedures
file->line-counts)
coverage-data?
- ;; Mapping from procedures to hash tables; said hash tables map instruction
- ;; pointers to the number of times they were executed.
- (procedure->ip-counts data-procedure->ip-counts)
+ ;; Mapping from instruction pointers to the number of times they were
+ ;; executed, as a sorted vector of IP-count pairs.
+ (ip-counts data-ip-counts)
- ;; Mapping from procedures to the result of `program-sources'.
- (procedure->sources data-procedure->sources)
+ ;; Complete source census at the time the coverage analysis was run, as a
+ ;; sorted vector of <source-chunk> values.
+ (sources data-sources)
;; Mapping from source file names to lists of procedures defined in the file.
+ ;; FIXME.
(file->procedures data-file->procedures)
;; Mapping from file names to hash tables, which in turn map from line numbers
;; to execution counts.
(file->line-counts data-file->line-counts))
+(set-record-type-printer!
+ <coverage-data>
+ (lambda (obj port)
+ (format port "<coverage-data ~x>" (object-address obj))))
-(define (make-coverage-data procedure->ip-counts)
+(define (make-coverage-data ip-counts)
;; Return a `coverage-data' object based on the coverage data available in
- ;; PROCEDURE->IP-COUNTS. Precompute the other hash tables that make up
- ;; `coverage-data' objects.
- (let* ((procedure->sources (make-hash-table 500))
+ ;; IP-COUNTS. Precompute the other hash tables that make up `coverage-data'
+ ;; objects.
+ (let* ((all-sources (all-source-information))
+ (all-counts (sort! (list->vector (hash-fold acons '() ip-counts))
+ (lambda (x y)
+ (< (car x) (car y)))))
(file->procedures (make-hash-table 100))
(file->line-counts (make-hash-table 100))
- (data (%make-coverage-data procedure->ip-counts
- procedure->sources
+ (data (%make-coverage-data all-counts
+ all-sources
file->procedures
file->line-counts)))
- (define (increment-execution-count! file line count)
+
+ (define (observe-execution-count! file line count)
;; Make the execution count of FILE:LINE the maximum of its current value
;; and COUNT. This is so that LINE's execution count is correct when
;; several instruction pointers map to LINE.
- (let ((file-entry (hash-create-handle! file->line-counts file #f)))
- (if (not (cdr file-entry))
- (set-cdr! file-entry (make-hash-table 500)))
- (let ((line-entry (hashv-create-handle! (cdr file-entry) line 0)))
- (set-cdr! line-entry (max (cdr line-entry) count)))))
-
- ;; Update execution counts for procs that were executed.
- (hash-for-each (lambda (proc ip-counts)
- (let* ((sources (program-sources* data proc))
- (file (and (pair? sources)
- (source:file (car sources)))))
- (and file
- (begin
- ;; Add a zero count for all IPs in SOURCES and in
- ;; the sources of procedures closed over by PROC.
- (for-each
- (lambda (source)
- (let ((file (source:file source))
- (line (source:line source)))
- (increment-execution-count! file line 0)))
- (append-map (cut program-sources* data <>)
- (closed-over-procedures proc)))
-
- ;; Add the actual execution count collected.
- (hash-for-each
- (lambda (ip count)
- (let ((line (closest-source-line sources ip)))
- (increment-execution-count! file line count)))
- ip-counts)))))
- procedure->ip-counts)
-
- ;; Set the execution count to zero for procedures loaded and not executed.
- ;; FIXME: Traversing thousands of procedures here is inefficient.
- (for-each (lambda (proc)
- (and (not (hashq-ref procedure->sources proc))
- (for-each (lambda (proc)
- (let* ((sources (program-sources* data proc))
- (file (and (pair? sources)
- (source:file (car sources)))))
- (and file
- (for-each
- (lambda (ip)
- (let ((line (closest-source-line sources ip)))
- (increment-execution-count! file line 0)))
- (map source:addr sources)))))
- (closed-over-procedures proc))))
- (append-map module-procedures (loaded-modules)))
+ (when file
+ (let ((file-entry (hash-create-handle! file->line-counts file #f)))
+ (if (not (cdr file-entry))
+ (set-cdr! file-entry (make-hash-table 500)))
+ (let ((line-entry (hashv-create-handle! (cdr file-entry) line 0)))
+ (set-cdr! line-entry (max (cdr line-entry) count))))))
+
+ ;; First, visit every known source location and mark it as instrumented but
+ ;; unvisited.
+ ;;
+ ;; FIXME: This is not always necessary. It's important to have the ability
+ ;; to know when a source location is not reached, but sometimes all we need
+ ;; to know is that a particular site *was* reached. In that case we
+ ;; wouldn't need to load up all the DWARF sections. As it is, though, we
+ ;; use the complete source census as part of the later phase.
+ (let visit-chunk ((chunk-idx 0))
+ (when (< chunk-idx (vector-length all-sources))
+ (match (vector-ref all-sources chunk-idx)
+ (($ <source-chunk> base chunk-length chunk-sources)
+ (let visit-source ((source-idx 0))
+ (when (< source-idx (vector-length chunk-sources))
+ (let ((s (vector-ref chunk-sources source-idx)))
+ (observe-execution-count! (source-file s) (source-line s) 0)
+ (visit-source (1+ source-idx)))))))
+ (visit-chunk (1+ chunk-idx))))
+
+ ;; Then, visit the measured execution counts, walking the complete source
+ ;; census at the same time. This allows us to map observed addresses to
+ ;; source locations. Record observed execution counts.
+ (let visit-chunk ((chunk-idx 0) (count-idx 0))
+ (when (< chunk-idx (vector-length all-sources))
+ (match (vector-ref all-sources chunk-idx)
+ (($ <source-chunk> base chunk-length chunk-sources)
+ (let visit-count ((count-idx count-idx) (source-idx 0) (source #f))
+ (when (< count-idx (vector-length all-counts))
+ (match (vector-ref all-counts count-idx)
+ ((ip . count)
+ (cond
+ ((< ip base)
+ ;; Address before chunk base; no corresponding source.
+ (visit-count (1+ count-idx) source-idx source))
+ ((< ip (+ base chunk-length))
+ ;; Address in chunk; count it.
+ (let visit-source ((source-idx source-idx) (source source))
+ (define (finish)
+ (when source
+ (observe-execution-count! (source-file source)
+ (source-line source)
+ count))
+ (visit-count (1+ count-idx) source-idx source))
+ (cond
+ ((< source-idx (vector-length chunk-sources))
+ (let ((source* (vector-ref chunk-sources source-idx)))
+ (if (<= (source-pre-pc source*) ip)
+ (visit-source (1+ source-idx) source*)
+ (finish))))
+ (else
+ (finish)))))
+ (else
+ ;; Address past chunk; fetch the next chunk.
+ (visit-chunk (1+ chunk-idx) count-idx)))))))))))
data))
(define (procedure-execution-count data proc)
- "Return the number of times PROC's code was executed, according to DATA, or #f
-if PROC was not executed. When PROC is a closure, the number of times its code
-was executed is returned, not the number of times this code associated with this
-particular closure was executed."
- (let ((sources (program-sources* data proc)))
- (and (pair? sources)
- (and=> (hashx-ref hashq-proc assq-proc
- (data-procedure->ip-counts data) proc)
- (lambda (ip-counts)
- ;; FIXME: broken with lambda*
- (let ((entry-ip (source:addr (car sources))))
- (hashv-ref ip-counts entry-ip 0)))))))
-
-(define (program-sources* data proc)
- ;; A memoizing version of `program-sources'.
- (or (hashq-ref (data-procedure->sources data) proc)
- (and (program? proc)
- (let ((sources (program-sources proc))
- (p->s (data-procedure->sources data))
- (f->p (data-file->procedures data)))
- (if (pair? sources)
- (let* ((file (source:file (car sources)))
- (entry (hash-create-handle! f->p file '())))
- (hashq-set! p->s proc sources)
- (set-cdr! entry (cons proc (cdr entry)))
- sources)
- sources)))))
-
-(define (file-procedures data file)
- ;; Return the list of globally bound procedures defined in FILE.
- (hash-ref (data-file->procedures data) file '()))
+ "Return the number of times PROC's code was executed, according to DATA. When
+PROC is a closure, the number of times its code was executed is returned, not
+the number of times this code associated with this particular closure was
+executed."
+ (define (binary-search v key val)
+ (let lp ((start 0) (end (vector-length v)))
+ (and (not (eqv? start end))
+ (let* ((idx (floor/ (+ start end) 2))
+ (elt (vector-ref v idx))
+ (val* (key elt)))
+ (cond
+ ((< val val*)
+ (lp start idx))
+ ((< val* val)
+ (lp (1+ idx) end))
+ (else elt))))))
+ (and (program? proc)
+ (match (binary-search (data-ip-counts data) car (program-code proc))
+ (#f 0)
+ ((ip . code) code))))
(define (instrumented/executed-lines data file)
"Return the number of instrumented and the number of executed source lines in
(data-file->line-counts data)))
\f
-;;;
-;;; Helpers.
-;;;
-
-(define (loaded-modules)
- ;; Return the list of all the modules currently loaded.
- (define seen (make-hash-table))
-
- (let loop ((modules (module-submodules (resolve-module '() #f)))
- (result '()))
- (hash-fold (lambda (name module result)
- (if (hashq-ref seen module)
- result
- (begin
- (hashq-set! seen module #t)
- (loop (module-submodules module)
- (cons module result)))))
- result
- modules)))
-
-(define (module-procedures module)
- ;; Return the list of procedures bound globally in MODULE.
- (hash-fold (lambda (binding var result)
- (if (variable-bound? var)
- (let ((value (variable-ref var)))
- (if (procedure? value)
- (cons value result)
- result))
- result))
- '()
- (module-obarray module)))
-
-(define (closest-source-line sources ip)
- ;; Given SOURCES, as returned by `program-sources' for a given procedure,
- ;; return the source line of code that is the closest to IP. This is similar
- ;; to what `program-source' does.
- (let loop ((sources sources)
- (line (and (pair? sources) (source:line (car sources)))))
- (if (null? sources)
- line
- (let ((source (car sources)))
- (if (> (source:addr source) ip)
- line
- (loop (cdr sources) (source:line source)))))))
-
-(define (closed-over-procedures proc)
- ;; Return the list of procedures PROC closes over, PROC included.
- (let loop ((proc proc)
- (result '()))
- (if (and (program? proc) (not (memq proc result)))
- (fold loop (cons proc result)
- (append (vector->list (or (program-objects proc) #()))
- (program-free-variables proc)))
- result)))
-
-\f
;;;
;;; LCOV output.
;;;
The report will include all the modules loaded at the time coverage data was
gathered, even if their code was not executed."
+ ;; FIXME: Re-enable this code, but using for-each-elf-symbol on each source
+ ;; chunk. Use that to build a map of file -> proc-addr + line + name. Then
+ ;; use something like procedure-execution-count to get the execution count.
+ #;
(define (dump-function proc)
;; Dump source location and basic coverage data for PROC.
- (and (program? proc)
+ (and (or (program? proc))
(let ((sources (program-sources* data proc)))
(and (pair? sources)
(let* ((line (source:line-for-user (car sources)))
;; Output per-file coverage data.
(format port "TN:~%")
(for-each (lambda (file)
- (let ((procs (file-procedures data file))
- (path (search-path %load-path file)))
+ (let ((path (search-path %load-path file)))
(if (string? path)
(begin
(format port "SF:~A~%" path)
+ #;
(for-each dump-function procs)
(for-each (lambda (line+count)
(let ((line (car line+count))
--- /dev/null
+;;; Guile runtime debug information
+
+;;; Copyright (C) 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; Guile's bytecode compiler and linker serialize debugging information
+;;; into separate sections of the ELF image. This module reads those
+;;; sections.
+;;;
+;;; Code:
+
+(define-module (system vm debug)
+ #:use-module (system vm elf)
+ #:use-module (system vm dwarf)
+ #:use-module (system vm loader)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold split-at))
+ #:use-module (srfi srfi-9)
+ #:export (debug-context-image
+ debug-context-base
+ debug-context-length
+ debug-context-text-base
+
+ program-debug-info-name
+ program-debug-info-context
+ program-debug-info-image
+ program-debug-info-offset
+ program-debug-info-size
+ program-debug-info-addr
+ program-debug-info-u32-offset
+ program-debug-info-u32-offset-end
+
+ arity?
+ arity-low-pc
+ arity-high-pc
+ arity-nreq
+ arity-nopt
+ arity-nlocals
+ arity-has-rest?
+ arity-allow-other-keys?
+ arity-has-keyword-args?
+ arity-keyword-args
+ arity-is-case-lambda?
+ arity-definitions
+ arity-code
+
+ debug-context-from-image
+ fold-all-debug-contexts
+ for-each-elf-symbol
+ find-debug-context
+ find-program-debug-info
+ arity-arguments-alist
+ find-program-arities
+ find-program-arity
+ find-program-minimum-arity
+
+ find-program-docstring
+
+ find-program-properties
+
+ source?
+ source-pre-pc
+ source-post-pc
+ source-file
+ source-line
+ source-line-for-user
+ source-column
+ find-source-for-addr
+ find-program-sources
+ fold-source-locations))
+
+;;; A compiled procedure comes from a specific loaded ELF image. A
+;;; debug context identifies that image.
+;;;
+(define-record-type <debug-context>
+ (make-debug-context elf base text-base)
+ debug-context?
+ (elf debug-context-elf)
+ ;; Address at which this image is loaded in memory, in bytes.
+ (base debug-context-base)
+ ;; Offset of the text section relative to the image start, in bytes.
+ (text-base debug-context-text-base))
+
+(define (debug-context-image context)
+ "Return the bytevector aliasing the mapped ELF image corresponding to
+@var{context}."
+ (elf-bytes (debug-context-elf context)))
+
+(define (debug-context-length context)
+ "Return the size of the mapped ELF image corresponding to
+@var{context}, in bytes."
+ (bytevector-length (debug-context-image context)))
+
+(define (for-each-elf-symbol context proc)
+ "Call @var{proc} on each symbol in the symbol table of @var{context}."
+ (let ((elf (debug-context-elf context)))
+ (cond
+ ((elf-section-by-name elf ".symtab")
+ => (lambda (symtab)
+ (let ((len (elf-symbol-table-len symtab))
+ (strtab (elf-section elf (elf-section-link symtab))))
+ (let lp ((n 0))
+ (when (< n len)
+ (proc (elf-symbol-table-ref elf symtab n strtab))
+ (lp (1+ n))))))))))
+
+;;; A program debug info (PDI) is a handle on debugging meta-data for a
+;;; particular program.
+;;;
+(define-record-type <program-debug-info>
+ (make-program-debug-info context name offset size)
+ program-debug-info?
+ (context program-debug-info-context)
+ (name program-debug-info-name)
+ ;; Offset of the procedure in the text section, in bytes.
+ (offset program-debug-info-offset)
+ (size program-debug-info-size))
+
+(define (program-debug-info-addr pdi)
+ "Return the address in memory of the entry of the program represented
+by the debugging info @var{pdi}."
+ (+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi))
+ (debug-context-base (program-debug-info-context pdi))))
+
+(define (program-debug-info-image pdi)
+ "Return the ELF image containing @var{pdi}, as a bytevector."
+ (debug-context-image (program-debug-info-context pdi)))
+
+(define (program-debug-info-u32-offset pdi)
+ "Return the start address of the program represented by @var{pdi}, as
+an offset from the beginning of the ELF image in 32-bit units."
+ (/ (+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi)))
+ 4))
+
+(define (program-debug-info-u32-offset-end pdi)
+ "Return the end address of the program represented by @var{pdi}, as an
+offset from the beginning of the ELF image in 32-bit units."
+ (/ (+ (program-debug-info-size pdi)
+ (program-debug-info-offset pdi)
+ (debug-context-text-base (program-debug-info-context pdi)))
+ 4))
+
+(define (debug-context-from-image bv)
+ "Build a debugging context corresponding to a given ELF image."
+ (let* ((elf (parse-elf bv))
+ (base (pointer-address (bytevector->pointer (elf-bytes elf))))
+ (text-base (elf-section-offset
+ (or (elf-section-by-name elf ".rtl-text")
+ (error "ELF object has no text section")))))
+ (make-debug-context elf base text-base)))
+
+(define (fold-all-debug-contexts proc seed)
+ "Fold @var{proc} over debug contexts corresponding to all images that
+are mapped at the time this procedure is called. Any images mapped
+during the fold are omitted."
+ (fold (lambda (image seed)
+ (proc (debug-context-from-image image) seed))
+ seed
+ (all-mapped-elf-images)))
+
+(define (find-debug-context addr)
+ "Find and return the debugging context corresponding to the ELF image
+containing the address @var{addr}. @var{addr} is an integer. If no ELF
+image is found, return @code{#f}. It's possible for an bytecode program
+not to have an ELF image if the program was defined in as a stub in C."
+ (and=> (find-mapped-elf-image addr)
+ debug-context-from-image))
+
+(define-inlinable (binary-search start end inc try failure)
+ (let lp ((start start) (end end))
+ (if (eqv? start end)
+ (failure)
+ (let ((mid (+ start (* inc (floor/ (- end start) (* 2 inc))))))
+ (try mid
+ (lambda ()
+ (lp start mid))
+ (lambda ()
+ (lp (+ mid inc) end)))))))
+
+(define (find-elf-symbol elf text-offset)
+ "Search the symbol table of @var{elf} for the ELF symbol containing
+@var{text-offset}. @var{text-offset} is a byte offset in the text
+section of the ELF image. Returns an ELF symbol, or @code{#f}."
+ (and=>
+ (elf-section-by-name elf ".symtab")
+ (lambda (symtab)
+ (let ((strtab (elf-section elf (elf-section-link symtab))))
+ (binary-search
+ 0 (elf-symbol-table-len symtab) 1
+ (lambda (n continue-before continue-after)
+ (let* ((sym (elf-symbol-table-ref elf symtab n strtab))
+ (val (elf-symbol-value sym))
+ (size (elf-symbol-size sym)))
+ (cond
+ ((< text-offset val) (continue-before))
+ ((<= (+ val size) text-offset) (continue-after))
+ (else sym))))
+ (lambda ()
+ #f))))))
+
+(define* (find-program-debug-info addr #:optional
+ (context (find-debug-context addr)))
+ "Find and return the @code{<program-debug-info>} containing
+@var{addr}, or @code{#f}."
+ (cond
+ ((and context
+ (find-elf-symbol (debug-context-elf context)
+ (- addr
+ (debug-context-base context)
+ (debug-context-text-base context))))
+ => (lambda (sym)
+ (make-program-debug-info context
+ (and=> (elf-symbol-name sym)
+ ;; The name might be #f if
+ ;; the string table was
+ ;; stripped somehow.
+ (lambda (x)
+ (and (string? x)
+ (not (string-null? x))
+ (string->symbol x))))
+ (elf-symbol-value sym)
+ (elf-symbol-size sym))))
+ (else #f)))
+
+(define-record-type <arity>
+ (make-arity context base header-offset)
+ arity?
+ (context arity-context)
+ (base arity-base)
+ (header-offset arity-header-offset))
+
+(define arities-prefix-len 4)
+(define arity-header-len (* 7 4))
+
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; uint32_t nlocals;
+;;; }
+
+(define (arity-low-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 0 4))))
+(define (arity-high-pc* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 1 4))))
+(define (arity-offset* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 2 4))))
+(define (arity-flags* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 3 4))))
+(define (arity-nreq* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 4 4))))
+(define (arity-nopt* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 5 4))))
+(define (arity-nlocals* bv header-pos)
+ (bytevector-u32-native-ref bv (+ header-pos (* 6 4))))
+
+;;; #x1: has-rest?
+;;; #x2: allow-other-keys?
+;;; #x4: has-keyword-args?
+;;; #x8: is-case-lambda?
+;;; #x10: is-in-case-lambda?
+
+(define (has-rest? flags) (not (zero? (logand flags (ash 1 0)))))
+(define (allow-other-keys? flags) (not (zero? (logand flags (ash 1 1)))))
+(define (has-keyword-args? flags) (not (zero? (logand flags (ash 1 2)))))
+(define (is-case-lambda? flags) (not (zero? (logand flags (ash 1 3)))))
+(define (is-in-case-lambda? flags) (not (zero? (logand flags (ash 1 4)))))
+
+(define (arity-low-pc arity)
+ (let ((ctx (arity-context arity)))
+ (+ (debug-context-base ctx)
+ (debug-context-text-base ctx)
+ (arity-low-pc* (elf-bytes (debug-context-elf ctx))
+ (arity-header-offset arity)))))
+
+(define (arity-high-pc arity)
+ (let ((ctx (arity-context arity)))
+ (+ (debug-context-base ctx)
+ (debug-context-text-base ctx)
+ (arity-high-pc* (elf-bytes (debug-context-elf ctx))
+ (arity-header-offset arity)))))
+
+(define (arity-nreq arity)
+ (arity-nreq* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-nopt arity)
+ (arity-nopt* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-nlocals arity)
+ (arity-nlocals* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-flags arity)
+ (arity-flags* (elf-bytes (debug-context-elf (arity-context arity)))
+ (arity-header-offset arity)))
+
+(define (arity-has-rest? arity) (has-rest? (arity-flags arity)))
+(define (arity-allow-other-keys? arity) (allow-other-keys? (arity-flags arity)))
+(define (arity-has-keyword-args? arity) (has-keyword-args? (arity-flags arity)))
+(define (arity-is-case-lambda? arity) (is-case-lambda? (arity-flags arity)))
+(define (arity-is-in-case-lambda? arity) (is-in-case-lambda? (arity-flags arity)))
+
+(define (arity-keyword-args arity)
+ (define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+ (if (arity-has-keyword-args? arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (header (arity-header-offset arity))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity) link-offset))
+ (offset (bytevector-u32-native-ref bv link)))
+ (unpack-scm (+ (debug-context-base (arity-context arity)) offset)))
+ '()))
+
+(define (arity-load-symbol arity)
+ (let ((elf (debug-context-elf (arity-context arity))))
+ (cond
+ ((elf-section-by-name elf ".guile.arities")
+ =>
+ (lambda (sec)
+ (let* ((strtab (elf-section elf (elf-section-link sec)))
+ (bv (elf-bytes elf))
+ (strtab-offset (elf-section-offset strtab)))
+ (lambda (n)
+ (string->symbol (string-table-ref bv (+ strtab-offset n)))))))
+ (else (error "couldn't find arities section")))))
+
+(define* (arity-definitions arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (load-symbol (arity-load-symbol arity))
+ (header (arity-header-offset arity))
+ (nlocals (arity-nlocals* bv header))
+ (flags (arity-flags* bv header))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity)
+ link-offset
+ (if (has-keyword-args? flags) 4 0))))
+ (define (read-uleb128 bv pos)
+ ;; Unrolled by one.
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values b
+ (1+ pos))
+ (let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7))
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values (logior (ash b shift) n)
+ (1+ pos))
+ (lp (logior (ash (logxor #x80 b) shift) n)
+ (1+ pos)
+ (+ shift 7))))))))
+ (define (load-definitions pos names)
+ (let lp ((pos pos) (names names))
+ (match names
+ (() '())
+ ((name . names)
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (def-offset pos)
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (slot pos)
+ (cons (vector name def-offset slot)
+ (lp pos names))))))))))
+ (define (load-symbols pos)
+ (let lp ((pos pos) (n nlocals) (out '()))
+ (if (zero? n)
+ (load-definitions pos (reverse out))
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (strtab-offset pos)
+ strtab-offset
+ (lp pos
+ (1- n)
+ (cons (if (zero? strtab-offset)
+ #f
+ (load-symbol strtab-offset))
+ out)))))))
+ (when (is-case-lambda? flags)
+ (error "invalid request for definitions of case-lambda wrapper arity"))
+ (load-symbols link)))
+
+(define (arity-code arity)
+ (let* ((ctx (arity-context arity))
+ (bv (elf-bytes (debug-context-elf ctx)))
+ (header (arity-header-offset arity))
+ (base-addr (+ (debug-context-base ctx) (debug-context-text-base ctx)))
+ (low-pc (+ base-addr (arity-low-pc* bv header)))
+ (high-pc (+ base-addr (arity-high-pc* bv header))))
+ ;; FIXME: We should be able to use a sub-bytevector operation here;
+ ;; it would be safer.
+ (pointer->bytevector (make-pointer low-pc) (- high-pc low-pc))))
+
+(define* (arity-locals arity #:optional nlocals)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (load-symbol (arity-load-symbol arity))
+ (header (arity-header-offset arity))
+ (nlocals (if nlocals
+ (if (<= 0 nlocals (arity-nlocals* bv header))
+ nlocals
+ (error "request for too many locals"))
+ (arity-nlocals* bv header)))
+ (flags (arity-flags* bv header))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity)
+ link-offset
+ (if (has-keyword-args? flags) 4 0))))
+ (define (read-uleb128 bv pos)
+ ;; Unrolled by one.
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values b
+ (1+ pos))
+ (let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7))
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values (logior (ash b shift) n)
+ (1+ pos))
+ (lp (logior (ash (logxor #x80 b) shift) n)
+ (1+ pos)
+ (+ shift 7))))))))
+ (define (load-symbols pos n)
+ (let lp ((pos pos) (n n) (out '()))
+ (if (zero? n)
+ (reverse out)
+ (call-with-values (lambda () (read-uleb128 bv pos))
+ (lambda (strtab-offset pos)
+ strtab-offset
+ (lp pos
+ (1- n)
+ (cons (if (zero? strtab-offset)
+ #f
+ (load-symbol strtab-offset))
+ out)))))))
+ (when (is-case-lambda? flags)
+ (error "invalid request for locals of case-lambda wrapper arity"))
+ (load-symbols link nlocals)))
+
+(define (arity-arguments-alist arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (header (arity-header-offset arity))
+ (flags (arity-flags* bv header))
+ (nreq (arity-nreq* bv header))
+ (nopt (arity-nopt* bv header))
+ (nargs (+ nreq nopt (if (has-rest? flags) 1 0))))
+ (when (is-case-lambda? flags)
+ (error "invalid request for locals of case-lambda wrapper arity"))
+ (let ((args (arity-locals arity nargs)))
+ (call-with-values (lambda () (split-at args nreq))
+ (lambda (req args)
+ (call-with-values (lambda () (split-at args nopt))
+ (lambda (opt args)
+ `((required . ,req)
+ (optional . ,opt)
+ (keyword . ,(arity-keyword-args arity))
+ (allow-other-keys? . ,(allow-other-keys? flags))
+ (rest . ,(and (has-rest? flags) (car args)))))))))))
+
+(define (find-first-arity context base addr)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ (binary-search
+ (+ base arities-prefix-len)
+ (+ base (bytevector-u32-native-ref bv base))
+ arity-header-len
+ (lambda (pos continue-before continue-after)
+ (let lp ((pos pos))
+ (cond
+ ((is-in-case-lambda? (arity-flags* bv pos))
+ (lp (- pos arity-header-len)))
+ ((< text-offset (arity-low-pc* bv pos))
+ (continue-before))
+ ((<= (arity-high-pc* bv pos) text-offset)
+ (continue-after))
+ (else
+ (make-arity context base pos)))))
+ (lambda ()
+ #f))))
+
+(define (read-sub-arities context base outer-header-offset)
+ (let* ((bv (elf-bytes (debug-context-elf context)))
+ (headers-end (+ base (bytevector-u32-native-ref bv base)))
+ (low-pc (arity-low-pc* bv outer-header-offset))
+ (high-pc (arity-high-pc* bv outer-header-offset)))
+ (let lp ((pos (+ outer-header-offset arity-header-len)) (out '()))
+ (if (and (< pos headers-end) (<= (arity-high-pc* bv pos) high-pc))
+ (lp (+ pos arity-header-len)
+ (cons (make-arity context base pos) out))
+ (reverse out)))))
+
+(define* (find-program-arities addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (and context
+ (elf-section-by-name (debug-context-elf context) ".guile.arities"))
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ (cond
+ ((not first) '())
+ ((arity-is-case-lambda? first)
+ (read-sub-arities context base (arity-header-offset first)))
+ (else (list first)))))))
+
+(define* (find-program-arity addr #:optional
+ (context (find-debug-context addr)))
+ (let lp ((arities (or (find-program-arities addr context) '())))
+ (match arities
+ (() #f)
+ ((arity . arities)
+ (if (and (<= (arity-low-pc arity) addr)
+ (< addr (arity-high-pc arity)))
+ arity
+ (lp arities))))))
+
+(define* (find-program-minimum-arity addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (and context
+ (elf-section-by-name (debug-context-elf context) ".guile.arities"))
+ (lambda (sec)
+ (let* ((base (elf-section-offset sec))
+ (first (find-first-arity context base addr)))
+ (if (arity-is-case-lambda? first)
+ (let ((arities (read-sub-arities context base
+ (arity-header-offset first))))
+ (and (pair? arities)
+ (list (apply min (map arity-nreq arities))
+ 0
+ (or-map (lambda (arity)
+ (or (positive? (arity-nopt arity))
+ (arity-has-rest? arity)
+ (arity-has-keyword-args? arity)
+ (arity-allow-other-keys? arity)))
+ arities))))
+ (list (arity-nreq first)
+ (arity-nopt first)
+ (arity-has-rest? first)))))))
+
+(define* (find-program-docstring addr #:optional
+ (context (find-debug-context addr)))
+ (and=>
+ (and context
+ (elf-section-by-name (debug-context-elf context) ".guile.docstrs"))
+ (lambda (sec)
+ ;; struct docstr {
+ ;; uint32_t pc;
+ ;; uint32_t str;
+ ;; }
+ (let ((start (elf-section-offset sec))
+ (bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ (binary-search
+ start
+ (+ start (elf-section-size sec))
+ 8
+ (lambda (pos continue-before continue-after)
+ (let ((pc (bytevector-u32-native-ref bv pos)))
+ (cond
+ ((< text-offset pc) (continue-before))
+ ((< pc text-offset) (continue-after))
+ (else
+ (let ((strtab (elf-section (debug-context-elf context)
+ (elf-section-link sec)))
+ (idx (bytevector-u32-native-ref bv (+ pos 4))))
+ (string-table-ref bv (+ (elf-section-offset strtab) idx)))))))
+ (lambda ()
+ #f))))))
+
+(define* (find-program-properties addr #:optional
+ (context (find-debug-context addr)))
+ (define (add-name-and-docstring props)
+ (define (maybe-acons k v tail)
+ (if v (acons k v tail) tail))
+ (let ((name (and=> (find-program-debug-info addr context)
+ program-debug-info-name))
+ (docstring (find-program-docstring addr context)))
+ (maybe-acons 'name name
+ (maybe-acons 'documentation docstring props))))
+ (add-name-and-docstring
+ (cond
+ ((and context
+ (elf-section-by-name (debug-context-elf context) ".guile.procprops"))
+ => (lambda (sec)
+ ;; struct procprop {
+ ;; uint32_t pc;
+ ;; uint32_t offset;
+ ;; }
+ (define procprop-len 8)
+ (let* ((start (elf-section-offset sec))
+ (bv (elf-bytes (debug-context-elf context)))
+ (text-offset (- addr
+ (debug-context-text-base context)
+ (debug-context-base context))))
+ (define (unpack-scm addr)
+ (pointer->scm (make-pointer addr)))
+ (define (load-non-immediate offset)
+ (unpack-scm (+ (debug-context-base context) offset)))
+ (binary-search
+ start (+ start (elf-section-size sec)) 8
+ (lambda (pos continue-before continue-after)
+ (let ((pc (bytevector-u32-native-ref bv pos)))
+ (cond
+ ((< text-offset pc) (continue-before))
+ ((< pc text-offset) (continue-after))
+ (else
+ (load-non-immediate
+ (bytevector-u32-native-ref bv (+ pos 4)))))))
+ (lambda ()
+ '())))))
+ (else '()))))
+
+(define-record-type <source>
+ (make-source pre-pc file line column)
+ source?
+ (pre-pc source-pre-pc)
+ (file source-file)
+ (line source-line)
+ (column source-column))
+
+(define (make-source/dwarf pc file line column)
+ (make-source pc file
+ ;; Convert DWARF-numbered (1-based) lines and
+ ;; columns to Guile conventions (0-based).
+ (and line (1- line)) (and column (1- column))))
+
+;; FIXME
+(define (source-post-pc source)
+ (source-pre-pc source))
+
+;; Lines are zero-indexed inside Guile, but users expect them to be
+;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go
+;; figure.
+(define (source-line-for-user source)
+ (and (source-line source) (1+ (source-line source))))
+
+(define* (find-source-for-addr addr #:optional
+ (context (find-debug-context addr))
+ #:key exact?)
+ (and=>
+ (and context
+ (false-if-exception
+ (elf->dwarf-context (debug-context-elf context))))
+ (lambda (dwarf-ctx)
+ (let* ((base (debug-context-base context))
+ (pc (- addr base)))
+ (or-map (lambda (die)
+ (and=>
+ (die-line-prog die)
+ (lambda (prog)
+ (call-with-values
+ (lambda () (line-prog-scan-to-pc prog pc))
+ (lambda (pc* file line col)
+ (and pc* (or (= pc pc*) (not exact?))
+ (make-source/dwarf (+ pc* base)
+ file line col)))))))
+ (read-die-roots dwarf-ctx))))))
+
+(define* (find-program-die addr #:optional
+ (context (find-debug-context addr)))
+ (and=> (and context
+ (false-if-exception
+ (elf->dwarf-context (debug-context-elf context))))
+ (lambda (dwarf-ctx)
+ (find-die-by-pc (read-die-roots dwarf-ctx)
+ (- addr (debug-context-base context))))))
+
+(define* (find-program-sources addr #:optional
+ (context (find-debug-context addr)))
+ (cond
+ ((find-program-die addr context)
+ => (lambda (die)
+ (let* ((base (debug-context-base context))
+ (low-pc (die-ref die 'low-pc))
+ (high-pc (die-high-pc die))
+ (prog (let line-prog ((die die))
+ (and die
+ (or (die-line-prog die)
+ (line-prog (ctx-die (die-ctx die))))))))
+ (cond
+ ((and low-pc high-pc prog)
+ (let lp ((sources '()))
+ (call-with-values (lambda ()
+ (if (null? sources)
+ (line-prog-scan-to-pc prog low-pc)
+ (line-prog-advance prog)))
+ (lambda (pc file line col)
+ (if (and pc (< pc high-pc))
+ ;; For the first source, it's probable that the
+ ;; address of the line program is before the
+ ;; low-pc, since the line program is for the
+ ;; entire compilation unit, and there are no
+ ;; redundant "rows" in the line program.
+ ;; Therefore in that case use the addr of low-pc
+ ;; instead of the one we got back.
+ (let ((addr (+ (if (null? sources) low-pc pc) base)))
+ (lp (cons (make-source/dwarf addr file line col)
+ sources)))
+ (reverse sources))))))
+ (else '())))))
+ (else '())))
+
+(define* (fold-source-locations proc seed context)
+ "Fold @var{proc} over all source locations in @var{context}.
+@var{proc} will be called with two arguments: the source object and the
+seed."
+ (cond
+ ((and context
+ (false-if-exception
+ (elf->dwarf-context (debug-context-elf context))))
+ =>
+ (lambda (dwarf-ctx)
+ (let ((base (debug-context-base context)))
+ (fold
+ (lambda (die seed)
+ (cond
+ ((die-line-prog die)
+ =>
+ (lambda (prog)
+ (let lp ((seed seed))
+ (call-with-values
+ (lambda () (line-prog-advance prog))
+ (lambda (pc* file line col)
+ (if pc*
+ (lp
+ (proc (make-source/dwarf (+ pc* base) file line col)
+ seed))
+ seed))))))
+ (else seed)))
+ seed
+ (read-die-roots dwarf-ctx)))))
+ (else seed)))
--- /dev/null
+;;; Guile bytecode disassembler
+
+;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015 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 (system vm disassembler)
+ #:use-module (language bytecode)
+ #:use-module (system vm elf)
+ #:use-module (system vm debug)
+ #:use-module (system vm program)
+ #:use-module (system vm loader)
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-4)
+ #:export (disassemble-program
+ fold-program-code
+ disassemble-image
+ disassemble-file
+
+ instruction-length
+ instruction-has-fallthrough?
+ instruction-relative-jump-targets
+ instruction-slot-clobbers))
+
+(define-syntax-rule (u32-ref buf n)
+ (bytevector-u32-native-ref buf (* n 4)))
+
+(define-syntax-rule (s32-ref buf n)
+ (bytevector-s32-native-ref buf (* n 4)))
+
+(define-syntax visit-opcodes
+ (lambda (x)
+ (syntax-case x ()
+ ((visit-opcodes macro arg ...)
+ (with-syntax (((inst ...)
+ (map (lambda (x) (datum->syntax #'macro x))
+ (instruction-list))))
+ #'(begin
+ (macro arg ... . inst)
+ ...))))))
+
+(eval-when (expand compile load eval)
+ (define (id-append ctx a b)
+ (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))))
+
+(define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+
+(define (unpack-s24 s)
+ (if (zero? (logand s (ash 1 23)))
+ s
+ (- s (ash 1 24))))
+
+(define (unpack-s32 s)
+ (if (zero? (logand s (ash 1 31)))
+ s
+ (- s (ash 1 32))))
+
+(define-syntax disassembler
+ (lambda (x)
+ (define (parse-first-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((U8_X24)
+ #'())
+ ((U8_U24)
+ #'((ash word -8)))
+ ((U8_L24)
+ #'((unpack-s24 (ash word -8))))
+ ((U8_U8_I16)
+ #'((logand (ash word -8) #xff)
+ (ash word -16)))
+ ((U8_U12_U12)
+ #'((logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((U8_U8_U8_U8)
+ #'((logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24)))
+ (else
+ (error "bad kind" type)))))
+
+ (define (parse-tail-word word type)
+ (with-syntax ((word word))
+ (case type
+ ((U8_X24)
+ #'((logand word #ff)))
+ ((U8_U24)
+ #'((logand word #xff)
+ (ash word -8)))
+ ((U8_L24)
+ #'((logand word #xff)
+ (unpack-s24 (ash word -8))))
+ ((U32)
+ #'(word))
+ ((I32)
+ #'(word))
+ ((A32)
+ #'(word))
+ ((B32)
+ #'(word))
+ ((N32)
+ #'((unpack-s32 word)))
+ ((S32)
+ #'((unpack-s32 word)))
+ ((L32)
+ #'((unpack-s32 word)))
+ ((LO32)
+ #'((unpack-s32 word)))
+ ((X8_U24)
+ #'((ash word -8)))
+ ((X8_L24)
+ #'((unpack-s24 (ash word -8))))
+ ((B1_X7_L24)
+ #'((not (zero? (logand word #x1)))
+ (unpack-s24 (ash word -8))))
+ ((B1_U7_L24)
+ #'((not (zero? (logand word #x1)))
+ (logand (ash word -1) #x7f)
+ (unpack-s24 (ash word -8))))
+ ((B1_X31)
+ #'((not (zero? (logand word #x1)))))
+ ((B1_X7_U24)
+ #'((not (zero? (logand word #x1)))
+ (ash word -8)))
+ (else
+ (error "bad kind" type)))))
+
+ (syntax-case x ()
+ ((_ name opcode word0 word* ...)
+ (let ((vars (generate-temporaries #'(word* ...))))
+ (with-syntax (((word* ...) vars)
+ ((n ...) (map 1+ (iota (length #'(word* ...)))))
+ ((asm ...)
+ (parse-first-word #'first (syntax->datum #'word0)))
+ (((asm* ...) ...)
+ (map (lambda (word type)
+ (parse-tail-word word type))
+ vars
+ (syntax->datum #'(word* ...)))))
+ #'(lambda (buf offset first)
+ (let ((word* (u32-ref buf (+ offset n)))
+ ...)
+ (values (+ 1 (length '(word* ...)))
+ (list 'name asm ... asm* ... ...))))))))))
+
+(define (disasm-invalid buf offset first)
+ (error "bad instruction" (logand first #xff) first buf offset))
+
+(define disassemblers (make-vector 256 disasm-invalid))
+
+(define-syntax define-disassembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind arg ...)
+ (with-syntax ((parse (id-append #'name #'parse- #'name)))
+ #'(let ((parse (disassembler name opcode arg ...)))
+ (vector-set! disassemblers opcode parse)))))))
+
+(visit-opcodes define-disassembler)
+
+;; -> len list
+(define (disassemble-one buf offset)
+ (let ((first (u32-ref buf offset)))
+ ((vector-ref disassemblers (logand first #xff)) buf offset first)))
+
+(define (u32-offset->addr offset context)
+ "Given an offset into an image in 32-bit units, return the absolute
+address of that offset."
+ (+ (debug-context-base context) (* offset 4)))
+
+(define (code-annotation code len offset start labels context push-addr!)
+ ;; FIXME: Print names for register loads and stores that correspond to
+ ;; access to named locals.
+ (define (reference-scm target)
+ (unpack-scm (u32-offset->addr (+ offset target) context)))
+
+ (define (dereference-scm target)
+ (let ((addr (u32-offset->addr (+ offset target)
+ context)))
+ (pointer->scm
+ (dereference-pointer (make-pointer addr)))))
+
+ (match code
+ (((or 'br
+ 'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
+ 'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
+ 'br-if-char 'br-if-eq 'br-if-eqv 'br-if-equal
+ 'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=
+ 'br-if-logtest) _ ... target)
+ (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
+ (('br-if-tc7 slot invert? tc7 target)
+ (list "~A -> ~A"
+ (let ((tag (case tc7
+ ((5) "symbol?")
+ ((7) "variable?")
+ ((13) "vector?")
+ ((15) "string?")
+ ((53) "keyword?")
+ ((77) "bytevector?")
+ ((95) "bitvector?")
+ (else (number->string tc7)))))
+ (if invert? (string-append "not " tag) tag))
+ (vector-ref labels (- (+ offset target) start))))
+ (('prompt tag escape-only? proc-slot handler)
+ ;; The H is for handler.
+ (list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
+ (((or 'make-short-immediate 'make-long-immediate) _ imm)
+ (list "~S" (unpack-scm imm)))
+ (('make-long-long-immediate _ high low)
+ (list "~S" (unpack-scm (logior (ash high 32) low))))
+ (('assert-nargs-ee/locals nargs locals)
+ ;; The nargs includes the procedure.
+ (list "~a arg~:p, ~a local~:p" (1- nargs) locals))
+ (('tail-call nargs proc)
+ (list "~a arg~:p" nargs))
+ (('make-closure dst target nfree)
+ (let* ((addr (u32-offset->addr (+ offset target) context))
+ (pdi (find-program-debug-info addr context))
+ (name (or (and pdi (program-debug-info-name pdi))
+ "anonymous procedure")))
+ (push-addr! addr name)
+ (list "~A at #x~X (~A free var~:p)" name addr nfree)))
+ (('call-label closure nlocals target)
+ (let* ((addr (u32-offset->addr (+ offset target) context))
+ (pdi (find-program-debug-info addr context))
+ (name (or (and pdi (program-debug-info-name pdi))
+ "anonymous procedure")))
+ (push-addr! addr name)
+ (list "~A at #x~X" name addr)))
+ (('tail-call-label nlocals target)
+ (let* ((addr (u32-offset->addr (+ offset target) context))
+ (pdi (find-program-debug-info addr context))
+ (name (or (and pdi (program-debug-info-name pdi))
+ "anonymous procedure")))
+ (push-addr! addr name)
+ (list "~A at #x~X" name addr)))
+ (('make-non-immediate dst target)
+ (let ((val (reference-scm target)))
+ (when (program? val)
+ (push-addr! (program-code val) val))
+ (list "~@Y" val)))
+ (('builtin-ref dst idx)
+ (list "~A" (builtin-index->name idx)))
+ (((or 'static-ref 'static-set!) _ target)
+ (list "~@Y" (dereference-scm target)))
+ (((or 'free-ref 'free-set!) _ _ index)
+ (list "free var ~a" index))
+ (('resolve-module dst name public)
+ (list "~a" (if (zero? public) "private" "public")))
+ (('toplevel-box _ var-offset mod-offset sym-offset bound?)
+ (list "`~A'~A" (dereference-scm sym-offset)
+ (if bound? "" " (maybe unbound)")))
+ (('module-box _ var-offset mod-name-offset sym-offset bound?)
+ (let ((mod-name (reference-scm mod-name-offset)))
+ (list "`(~A ~A ~A)'~A" (if (car mod-name) '@ '@@) (cdr mod-name)
+ (dereference-scm sym-offset)
+ (if bound? "" " (maybe unbound)"))))
+ (('load-typed-array dst type shape target len)
+ (let ((addr (u32-offset->addr (+ offset target) context)))
+ (list "~a bytes from #x~X" len addr)))
+ (_ #f)))
+
+(define (compute-labels bv start end)
+ (let ((labels (make-vector (- end start) #f)))
+ (define (add-label! pos header)
+ (unless (vector-ref labels (- pos start))
+ (vector-set! labels (- pos start) header)))
+
+ (let lp ((offset start))
+ (when (< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (match elt
+ ((inst arg ...)
+ (case inst
+ ((br
+ br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
+ br-if-true br-if-null br-if-nil br-if-pair br-if-struct
+ br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-equal
+ br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest)
+ (match arg
+ ((_ ... target)
+ (add-label! (+ offset target) "L"))))
+ ((prompt)
+ (match arg
+ ((_ ... target)
+ (add-label! (+ offset target) "H")))))))
+ (lp (+ offset len))))))
+ (let lp ((offset start) (n 1))
+ (when (< offset end)
+ (let* ((pos (- offset start))
+ (label (vector-ref labels pos)))
+ (if label
+ (begin
+ (vector-set! labels
+ pos
+ (string->symbol
+ (string-append label (number->string n))))
+ (lp (1+ offset) (1+ n)))
+ (lp (1+ offset) n)))))
+ labels))
+
+(define (print-info port addr label info extra src)
+ (when label
+ (format port "~A:\n" label))
+ (format port "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
+ addr info extra src))
+
+(define (disassemble-buffer port bv start end context push-addr!)
+ (let ((labels (compute-labels bv start end))
+ (sources (find-program-sources (u32-offset->addr start context)
+ context)))
+ (define (lookup-source addr)
+ (let lp ((sources sources))
+ (match sources
+ (() #f)
+ ((source . sources)
+ (let ((pc (source-pre-pc source)))
+ (cond
+ ((< pc addr) (lp sources))
+ ((= pc addr)
+ (format #f "~a:~a:~a"
+ (or (source-file source) "(unknown file)")
+ (source-line-for-user source)
+ (source-column source)))
+ (else #f)))))))
+ (let lp ((offset start))
+ (when (< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (let ((pos (- offset start))
+ (addr (u32-offset->addr offset context))
+ (annotation (code-annotation elt len offset start labels
+ context push-addr!)))
+ (print-info port pos (vector-ref labels pos) elt annotation
+ (lookup-source addr))
+ (lp (+ offset len)))))))))
+
+(define* (disassemble-addr addr label port #:optional (seen (make-hash-table)))
+ (format port "Disassembly of ~A at #x~X:\n\n" label addr)
+ (cond
+ ((find-program-debug-info addr)
+ => (lambda (pdi)
+ (let ((worklist '()))
+ (define (push-addr! addr label)
+ (unless (hashv-ref seen addr)
+ (hashv-set! seen addr #t)
+ (set! worklist (acons addr label worklist))))
+ (disassemble-buffer port
+ (program-debug-info-image pdi)
+ (program-debug-info-u32-offset pdi)
+ (program-debug-info-u32-offset-end pdi)
+ (program-debug-info-context pdi)
+ push-addr!)
+ (for-each (match-lambda
+ ((addr . label)
+ (display "\n----------------------------------------\n"
+ port)
+ (disassemble-addr addr label port seen)))
+ worklist))))
+ (else
+ (format port "Debugging information unavailable.~%")))
+ (values))
+
+(define* (disassemble-program program #:optional (port (current-output-port)))
+ (disassemble-addr (program-code program) program port))
+
+(define (fold-code-range proc seed bv start end context raw?)
+ (define (cook code offset)
+ (define (reference-scm target)
+ (unpack-scm (u32-offset->addr (+ offset target) context)))
+
+ (define (dereference-scm target)
+ (let ((addr (u32-offset->addr (+ offset target)
+ context)))
+ (pointer->scm
+ (dereference-pointer (make-pointer addr)))))
+ (match code
+ (((or 'make-short-immediate 'make-long-immediate) dst imm)
+ `(,(car code) ,dst ,(unpack-scm imm)))
+ (('make-long-long-immediate dst high low)
+ `(make-long-long-immediate ,dst
+ ,(unpack-scm (logior (ash high 32) low))))
+ (('make-closure dst target nfree)
+ `(make-closure ,dst
+ ,(u32-offset->addr (+ offset target) context)
+ ,nfree))
+ (('make-non-immediate dst target)
+ `(make-non-immediate ,dst ,(reference-scm target)))
+ (('builtin-ref dst idx)
+ `(builtin-ref ,dst ,(builtin-index->name idx)))
+ (((or 'static-ref 'static-set!) dst target)
+ `(,(car code) ,dst ,(dereference-scm target)))
+ (('toplevel-box dst var-offset mod-offset sym-offset bound?)
+ `(toplevel-box ,dst
+ ,(dereference-scm var-offset)
+ ,(dereference-scm mod-offset)
+ ,(dereference-scm sym-offset)
+ ,bound?))
+ (('module-box dst var-offset mod-name-offset sym-offset bound?)
+ (let ((mod-name (reference-scm mod-name-offset)))
+ `(module-box ,dst
+ ,(dereference-scm var-offset)
+ ,(car mod-name)
+ ,(cdr mod-name)
+ ,(dereference-scm sym-offset)
+ ,bound?)))
+ (_ code)))
+ (let lp ((offset start) (seed seed))
+ (cond
+ ((< offset end)
+ (call-with-values (lambda () (disassemble-one bv offset))
+ (lambda (len elt)
+ (lp (+ offset len)
+ (proc (if raw? elt (cook elt offset))
+ seed)))))
+ (else seed))))
+
+(define* (fold-program-code proc seed program-or-addr #:key raw?)
+ (cond
+ ((find-program-debug-info (if (program? program-or-addr)
+ (program-code program-or-addr)
+ program-or-addr))
+ => (lambda (pdi)
+ (fold-code-range proc seed
+ (program-debug-info-image pdi)
+ (program-debug-info-u32-offset pdi)
+ (program-debug-info-u32-offset-end pdi)
+ (program-debug-info-context pdi)
+ raw?)))
+ (else seed)))
+
+(define* (disassemble-image bv #:optional (port (current-output-port)))
+ (let* ((ctx (debug-context-from-image bv))
+ (base (debug-context-text-base ctx)))
+ (for-each-elf-symbol
+ ctx
+ (lambda (sym)
+ (let ((name (elf-symbol-name sym))
+ (value (elf-symbol-value sym))
+ (size (elf-symbol-size sym)))
+ (format port "Disassembly of ~A at #x~X:\n\n"
+ (if (and (string? name) (not (string-null? name)))
+ name
+ "<unnamed function>")
+ (+ base value))
+ (disassemble-buffer port
+ bv
+ (/ (+ base value) 4)
+ (/ (+ base value size) 4)
+ ctx
+ (lambda (addr name) #t))
+ (display "\n\n" port)))))
+ (values))
+
+(define (disassemble-file file)
+ (let* ((thunk (load-thunk-from-file file))
+ (elf (find-mapped-elf-image (program-code thunk))))
+ (disassemble-image elf)))
+
+(define-syntax instruction-lengths-vector
+ (lambda (x)
+ (syntax-case x ()
+ ((_)
+ (let ((lengths (make-vector 256 #f)))
+ (for-each (match-lambda
+ ((name opcode kind words ...)
+ (vector-set! lengths opcode (* 4 (length words)))))
+ (instruction-list))
+ (datum->syntax x lengths))))))
+
+(define (instruction-length code pos)
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ (or (vector-ref (instruction-lengths-vector) opcode)
+ (error "Unknown opcode" opcode))))
+
+(define-syntax static-opcode-set
+ (lambda (x)
+ (define (instruction-opcode inst)
+ (cond
+ ((assq inst (instruction-list))
+ => (match-lambda ((name opcode . _) opcode)))
+ (else
+ (error "unknown instruction" inst))))
+
+ (syntax-case x ()
+ ((static-opcode-set inst ...)
+ (let ((bv (make-bitvector 256 #f)))
+ (for-each (lambda (inst)
+ (bitvector-set! bv (instruction-opcode inst) #t))
+ (syntax->datum #'(inst ...)))
+ (datum->syntax #'static-opcode-set bv))))))
+
+(define (instruction-has-fallthrough? code pos)
+ (define non-fallthrough-set
+ (static-opcode-set halt
+ tail-call tail-call-label tail-call/shuffle
+ return return-values
+ subr-call foreign-call continuation-call
+ tail-apply
+ br))
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ (not (bitvector-ref non-fallthrough-set opcode))))
+
+(define-syntax define-jump-parser
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind word0 word* ...)
+ (let ((symname (syntax->datum #'name)))
+ (if (or (memq symname '(br prompt))
+ (string-prefix? "br-" (symbol->string symname)))
+ (let ((offset (* 4 (length #'(word* ...)))))
+ #`(vector-set!
+ jump-parsers
+ opcode
+ (lambda (code pos)
+ (let ((target
+ (bytevector-s32-native-ref code (+ pos #,offset))))
+ ;; Assume that the target is in the last word, as
+ ;; an L24 in the high bits.
+ (list (* 4 (ash target -8)))))))
+ #'(begin)))))))
+
+(define jump-parsers (make-vector 256 (lambda (code pos) '())))
+(visit-opcodes define-jump-parser)
+
+(define (instruction-relative-jump-targets code pos)
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ ((vector-ref jump-parsers opcode) code pos)))
+
+(define-syntax define-clobber-parser
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind arg ...)
+ (case (syntax->datum #'kind)
+ ((!)
+ (case (syntax->datum #'name)
+ ((call call-label)
+ #'(let ((parse (lambda (code pos nslots)
+ (call-with-values
+ (lambda ()
+ (disassemble-one code (/ pos 4)))
+ (lambda (len elt)
+ (match elt
+ ((_ proc . _)
+ (let lp ((slot (- proc 2)))
+ (if (< slot nslots)
+ (cons slot (lp (1+ slot)))
+ '())))))))))
+ (vector-set! clobber-parsers opcode parse)))
+ (else
+ #'(begin))))
+ ((<-)
+ #'(let ((parse (lambda (code pos nslots)
+ (call-with-values
+ (lambda ()
+ (disassemble-one code (/ pos 4)))
+ (lambda (len elt)
+ (match elt
+ ((_ dst . _) (list dst))))))))
+ (vector-set! clobber-parsers opcode parse)))
+ (else (error "unexpected instruction kind" #'kind)))))))
+
+(define clobber-parsers (make-vector 256 (lambda (code pos nslots) '())))
+(visit-opcodes define-clobber-parser)
+
+(define (instruction-slot-clobbers code pos nslots)
+ (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
+ ((vector-ref clobber-parsers opcode) code pos nslots)))
--- /dev/null
+;;; Guile DWARF reader and writer
+
+;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+
+;; Parts of this file were derived from sysdeps/generic/dwarf2.h, from
+;; the GNU C Library. That file is available under the LGPL version 2
+;; or later, and is copyright:
+;;
+;; Copyright (C) 1992, 1993, 1995, 1996, 1997, 2000, 2011
+;; Free Software Foundation, Inc.
+;; Contributed by Gary Funck (gary@intrepid.com). Derived from the
+;; DWARF 1 implementation written by Ron Guilmette (rfg@monkeys.com).
+
+;;;; 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
+
+;;; Commentary:
+;;
+;; DWARF is a flexible format for describing compiled programs. It is
+;; used by Guile to record source positions, describe local variables,
+;; function arities, and other function metadata.
+;;
+;; Structurally, DWARF describes a tree of data. Each node in the tree
+;; is a debugging information entry ("DIE"). Each DIE has a "tag",
+;; possible a set of attributes, and possibly some child DIE nodes.
+;; That's basically it!
+;;
+;; The DIE nodes are contained in the .debug_info section of an ELF
+;; file. Attributes within the DIE nodes link them to mapped ranges of
+;; the ELF file (.rtl-text, .data, etc.).
+;;
+;; A .debug_info section logically contains a series of debugging
+;; "contributions", one for each compilation unit. Each contribution is
+;; prefixed by a header and contains a single DIE element whose tag is
+;; "compilation-unit". That node usually contains child nodes, for
+;; example of type "subprogram".
+;;
+;; Since usually one will end up producing many DIE nodes with the same
+;; tag and attribute types, DIE nodes are defined by referencing a known
+;; shape, and then filling in the values. The shapes are defined in the
+;; form of "abbrev" entries, which specify a specific combination of a
+;; tag and an ordered set of attributes, with corresponding attribute
+;; representations ("forms"). Abbrevs are written out to a separate
+;; section, .debug_abbrev. Abbrev nodes also specify whether the
+;; corresponding DIE node has children or not. When a DIE is written
+;; into the .debug_info section, it references one of the abbrevs in
+;; .debug_abbrev. You need the abbrev in order to parse the DIE.
+;;
+;; For completeness, the other sections that DWARF uses are .debug_str,
+;; .debug_loc, .debug_pubnames, .debug_aranges, .debug_frame, and
+;; .debug_line. These are described in section 6 of the DWARF 3.0
+;; specification, at http://dwarfstd.org/.
+;;
+;; This DWARF module is currently capable of parsing all of DWARF 2.0
+;; and parts of DWARF 3.0. For Guile's purposes, we also use DWARF as
+;; the format for our own debugging information. The DWARF generator is
+;; fairly minimal, and is not intended to be complete.
+;;
+;;; Code:
+
+(define-module (system vm dwarf)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system foreign)
+ #:use-module (system base target)
+ #:use-module (system vm elf)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
+ #:export (elf->dwarf-context
+ read-die-roots
+ fold-pubnames fold-aranges
+
+ access-name->code
+ address-name->code
+ attribute-name->code
+ call-frame-address-name->code
+ children-name->code
+ convention-name->code
+ discriminant-name->code
+ form-name->code
+ inline-name->code
+ language-name->code
+ macro-name->code
+ ordering-name->code
+ sensitivity-name->code
+ tag-name->code
+ virtuality-name->code
+ visibility-name->code
+
+ abbrev? abbrev-code
+ abbrev-tag abbrev-has-children? abbrev-attrs abbrev-forms
+
+ die? die-ctx die-offset die-abbrev die-vals die-children
+ die-tag die-attrs die-forms die-ref
+ die-name die-specification die-qname die-low-pc die-high-pc
+
+ ctx-parent ctx-die ctx-start ctx-end ctx-children ctx-language
+
+ die-line-prog line-prog-advance line-prog-scan-to-pc
+
+ find-die-context find-die-by-offset find-die find-die-by-pc
+ read-die fold-die-list
+
+ fold-die-children die->tree))
+
+;;;
+;;; First, define a number of constants. The figures numbers refer to
+;;; the DWARF 2.0 draft specification available on http://dwarfstd.org/.
+;;; Extra codes not defined in that document are taken from the dwarf2
+;;; header in glibc.
+;;;
+
+(define-syntax-rule (define-enumeration code->name name->code
+ (tag value) ...)
+ (begin
+ (define code->name
+ (let ((table (make-hash-table)))
+ (hashv-set! table value 'tag)
+ ...
+ (lambda (v)
+ (hashv-ref table v v))))
+ (define name->code
+ (let ((table (make-hash-table)))
+ (hashv-set! table 'tag value)
+ ...
+ (lambda (v)
+ (hashv-ref table v v))))))
+
+;; Figures 14 and 15: Tag names and codes.
+;;
+(define-enumeration tag-code->name tag-name->code
+ (padding #x00)
+ (array-type #x01)
+ (class-type #x02)
+ (entry-point #x03)
+ (enumeration-type #x04)
+ (formal-parameter #x05)
+ (imported-declaration #x08)
+ (label #x0a)
+ (lexical-block #x0b)
+ (member #x0d)
+ (pointer-type #x0f)
+ (reference-type #x10)
+ (compile-unit #x11)
+ (string-type #x12)
+ (structure-type #x13)
+ (subroutine-type #x15)
+ (typedef #x16)
+ (union-type #x17)
+ (unspecified-parameters #x18)
+ (variant #x19)
+ (common-block #x1a)
+ (common-inclusion #x1b)
+ (inheritance #x1c)
+ (inlined-subroutine #x1d)
+ (module #x1e)
+ (ptr-to-member-type #x1f)
+ (set-type #x20)
+ (subrange-type #x21)
+ (with-stmt #x22)
+ (access-declaration #x23)
+ (base-type #x24)
+ (catch-block #x25)
+ (const-type #x26)
+ (constant #x27)
+ (enumerator #x28)
+ (file-type #x29)
+ (friend #x2a)
+ (namelist #x2b)
+ (namelist-item #x2c)
+ (packed-type #x2d)
+ (subprogram #x2e)
+ (template-type-param #x2f)
+ (template-value-param #x30)
+ (thrown-type #x31)
+ (try-block #x32)
+ (variant-part #x33)
+ (variable #x34)
+ (volatile-type #x35)
+ ;; DWARF 3.
+ (dwarf-procedure #x36)
+ (restrict-type #x37)
+ (interface-type #x38)
+ (namespace #x39)
+ (imported-module #x3a)
+ (unspecified-type #x3b)
+ (partial-unit #x3c)
+ (imported-unit #x3d)
+ (condition #x3f)
+ (shared-type #x40)
+ ;; Extensions.
+ (format-label #x4101)
+ (function-template #x4102)
+ (class-template #x4103)
+ (GNU-BINCL #x4104)
+ (GNU-EINCL #x4105)
+ (lo-user #x4080)
+ (hi-user #xffff))
+
+;; Figure 16: Flag that tells whether entry has a child or not.
+;;
+(define-enumeration children-code->name children-name->code
+ (no 0)
+ (yes 1))
+
+;; Figures 17 and 18: Attribute names and codes.
+;;
+(define-enumeration attribute-code->name attribute-name->code
+ (sibling #x01)
+ (location #x02)
+ (name #x03)
+ (ordering #x09)
+ (subscr-data #x0a)
+ (byte-size #x0b)
+ (bit-offset #x0c)
+ (bit-size #x0d)
+ (element-list #x0f)
+ (stmt-list #x10)
+ (low-pc #x11)
+ (high-pc #x12)
+ (language #x13)
+ (member #x14)
+ (discr #x15)
+ (discr-value #x16)
+ (visibility #x17)
+ (import #x18)
+ (string-length #x19)
+ (common-reference #x1a)
+ (comp-dir #x1b)
+ (const-value #x1c)
+ (containing-type #x1d)
+ (default-value #x1e)
+ (inline #x20)
+ (is-optional #x21)
+ (lower-bound #x22)
+ (producer #x25)
+ (prototyped #x27)
+ (return-addr #x2a)
+ (start-scope #x2c)
+ (stride-size #x2e)
+ (upper-bound #x2f)
+ (abstract-origin #x31)
+ (accessibility #x32)
+ (address-class #x33)
+ (artificial #x34)
+ (base-types #x35)
+ (calling-convention #x36)
+ (count #x37)
+ (data-member-location #x38)
+ (decl-column #x39)
+ (decl-file #x3a)
+ (decl-line #x3b)
+ (declaration #x3c)
+ (discr-list #x3d)
+ (encoding #x3e)
+ (external #x3f)
+ (frame-base #x40)
+ (friend #x41)
+ (identifier-case #x42)
+ (macro-info #x43)
+ (namelist-items #x44)
+ (priority #x45)
+ (segment #x46)
+ (specification #x47)
+ (static-link #x48)
+ (type #x49)
+ (use-location #x4a)
+ (variable-parameter #x4b)
+ (virtuality #x4c)
+ (vtable-elem-location #x4d)
+ ;; DWARF 3.
+ (associated #x4f)
+ (data-location #x50)
+ (byte-stride #x51)
+ (entry-pc #x52)
+ (use-UTF8 #x53)
+ (extension #x54)
+ (ranges #x55)
+ (trampoline #x56)
+ (call-column #x57)
+ (call-file #x58)
+ (call-line #x59)
+ (description #x5a)
+ (binary-scale #x5b)
+ (decimal-scale #x5c)
+ (small #x5d)
+ (decimal-sign #x5e)
+ (digit-count #x5f)
+ (picture-string #x60)
+ (mutable #x61)
+ (threads-scaled #x62)
+ (explicit #x63)
+ (object-pointer #x64)
+ (endianity #x65)
+ (elemental #x66)
+ (pure #x67)
+ (recursive #x68)
+ ;; Extensions.
+ (linkage-name #x2007)
+ (sf-names #x2101)
+ (src-info #x2102)
+ (mac-info #x2103)
+ (src-coords #x2104)
+ (body-begin #x2105)
+ (body-end #x2106)
+ (lo-user #x2000)
+ (hi-user #x3fff))
+
+;; Figure 19: Form names and codes.
+;;
+(define-enumeration form-code->name form-name->code
+ (addr #x01)
+ (block2 #x03)
+ (block4 #x04)
+ (data2 #x05)
+ (data4 #x06)
+ (data8 #x07)
+ (string #x08)
+ (block #x09)
+ (block1 #x0a)
+ (data1 #x0b)
+ (flag #x0c)
+ (sdata #x0d)
+ (strp #x0e)
+ (udata #x0f)
+ (ref-addr #x10)
+ (ref1 #x11)
+ (ref2 #x12)
+ (ref4 #x13)
+ (ref8 #x14)
+ (ref-udata #x15)
+ (indirect #x16)
+ (sec-offset #x17)
+ (exprloc #x18)
+ (flag-present #x19)
+ (ref-sig8 #x20))
+
+;; Figures 22 and 23: Location atom names and codes.
+;;
+(define-enumeration location-op->name location-name->op
+ (addr #x03)
+ (deref #x06)
+ (const1u #x08)
+ (const1s #x09)
+ (const2u #x0a)
+ (const2s #x0b)
+ (const4u #x0c)
+ (const4s #x0d)
+ (const8u #x0e)
+ (const8s #x0f)
+ (constu #x10)
+ (consts #x11)
+ (dup #x12)
+ (drop #x13)
+ (over #x14)
+ (pick #x15)
+ (swap #x16)
+ (rot #x17)
+ (xderef #x18)
+ (abs #x19)
+ (and #x1a)
+ (div #x1b)
+ (minus #x1c)
+ (mod #x1d)
+ (mul #x1e)
+ (neg #x1f)
+ (not #x20)
+ (or #x21)
+ (plus #x22)
+ (plus-uconst #x23)
+ (shl #x24)
+ (shr #x25)
+ (shra #x26)
+ (xor #x27)
+ (bra #x28)
+ (eq #x29)
+ (ge #x2a)
+ (gt #x2b)
+ (le #x2c)
+ (lt #x2d)
+ (ne #x2e)
+ (skip #x2f)
+ (lit0 #x30)
+ (lit1 #x31)
+ (lit2 #x32)
+ (lit3 #x33)
+ (lit4 #x34)
+ (lit5 #x35)
+ (lit6 #x36)
+ (lit7 #x37)
+ (lit8 #x38)
+ (lit9 #x39)
+ (lit10 #x3a)
+ (lit11 #x3b)
+ (lit12 #x3c)
+ (lit13 #x3d)
+ (lit14 #x3e)
+ (lit15 #x3f)
+ (lit16 #x40)
+ (lit17 #x41)
+ (lit18 #x42)
+ (lit19 #x43)
+ (lit20 #x44)
+ (lit21 #x45)
+ (lit22 #x46)
+ (lit23 #x47)
+ (lit24 #x48)
+ (lit25 #x49)
+ (lit26 #x4a)
+ (lit27 #x4b)
+ (lit28 #x4c)
+ (lit29 #x4d)
+ (lit30 #x4e)
+ (lit31 #x4f)
+ (reg0 #x50)
+ (reg1 #x51)
+ (reg2 #x52)
+ (reg3 #x53)
+ (reg4 #x54)
+ (reg5 #x55)
+ (reg6 #x56)
+ (reg7 #x57)
+ (reg8 #x58)
+ (reg9 #x59)
+ (reg10 #x5a)
+ (reg11 #x5b)
+ (reg12 #x5c)
+ (reg13 #x5d)
+ (reg14 #x5e)
+ (reg15 #x5f)
+ (reg16 #x60)
+ (reg17 #x61)
+ (reg18 #x62)
+ (reg19 #x63)
+ (reg20 #x64)
+ (reg21 #x65)
+ (reg22 #x66)
+ (reg23 #x67)
+ (reg24 #x68)
+ (reg25 #x69)
+ (reg26 #x6a)
+ (reg27 #x6b)
+ (reg28 #x6c)
+ (reg29 #x6d)
+ (reg30 #x6e)
+ (reg31 #x6f)
+ (breg0 #x70)
+ (breg1 #x71)
+ (breg2 #x72)
+ (breg3 #x73)
+ (breg4 #x74)
+ (breg5 #x75)
+ (breg6 #x76)
+ (breg7 #x77)
+ (breg8 #x78)
+ (breg9 #x79)
+ (breg10 #x7a)
+ (breg11 #x7b)
+ (breg12 #x7c)
+ (breg13 #x7d)
+ (breg14 #x7e)
+ (breg15 #x7f)
+ (breg16 #x80)
+ (breg17 #x81)
+ (breg18 #x82)
+ (breg19 #x83)
+ (breg20 #x84)
+ (breg21 #x85)
+ (breg22 #x86)
+ (breg23 #x87)
+ (breg24 #x88)
+ (breg25 #x89)
+ (breg26 #x8a)
+ (breg27 #x8b)
+ (breg28 #x8c)
+ (breg29 #x8d)
+ (breg30 #x8e)
+ (breg31 #x8f)
+ (regx #x90)
+ (fbreg #x91)
+ (bregx #x92)
+ (piece #x93)
+ (deref-size #x94)
+ (xderef-size #x95)
+ (nop #x96)
+ ;; DWARF 3.
+ (push-object-address #x97)
+ (call2 #x98)
+ (call4 #x99)
+ (call-ref #x9a)
+ (form-tls-address #x9b)
+ (call-frame-cfa #x9c)
+ (bit-piece #x9d)
+ (lo-user #x80)
+ (hi-user #xff))
+
+;; Figure 24: Type encodings.
+;;
+(define-enumeration type-encoding->name type-name->encoding
+ (void #x0)
+ (address #x1)
+ (boolean #x2)
+ (complex-float #x3)
+ (float #x4)
+ (signed #x5)
+ (signed-char #x6)
+ (unsigned #x7)
+ (unsigned-char #x8)
+ ;; DWARF 3.
+ (imaginary-float #x09)
+ (packed-decimal #x0a)
+ (numeric-string #x0b)
+ (edited #x0c)
+ (signed-fixed #x0d)
+ (unsigned-fixed #x0e)
+ (decimal-float #x0f)
+ (lo-user #x80)
+ (hi-user #xff))
+
+;; Figure 25: Access attribute.
+;;
+(define-enumeration access-code->name access-name->code
+ (public 1)
+ (protected 2)
+ (private 3))
+
+;; Figure 26: Visibility.
+;;
+(define-enumeration visibility-code->name visibility-name->code
+ (local 1)
+ (exported 2)
+ (qualified 3))
+
+;; Figure 27: Virtuality.
+;;
+(define-enumeration virtuality-code->name virtuality-name->code
+ (none 0)
+ (virtual 1)
+ (pure-virtual 2))
+
+;; Figure 28: Source language names and codes.
+;;
+(define-enumeration language-code->name language-name->code
+ (c89 #x0001)
+ (c #x0002)
+ (ada83 #x0003)
+ (c++ #x0004)
+ (cobol74 #x0005)
+ (cobol85 #x0006)
+ (fortran77 #x0007)
+ (fortran90 #x0008)
+ (pascal83 #x0009)
+ (modula2 #x000a)
+ (java #x000b)
+ (c99 #x000c)
+ (ada95 #x000d)
+ (fortran95 #x000e)
+ (pli #x000f)
+ (objc #x0010)
+ (objc++ #x0011)
+ (upc #x0012)
+ (d #x0013)
+ (python #x0014)
+ (mips-assembler #x8001)
+
+ (lo-user #x8000)
+
+ ;; FIXME: Ask for proper codes for these.
+ (scheme #xaf33)
+ (emacs-lisp #xaf34)
+ (ecmascript #xaf35)
+ (lua #xaf36)
+ (brainfuck #xaf37)
+
+ (hi-user #xffff))
+
+;; Figure 29: Case sensitivity.
+;;
+(define-enumeration case-sensitivity-code->name case-sensitivity-name->code
+ (case-sensitive 0)
+ (up-case 1)
+ (down-case 2)
+ (case-insensitive 3))
+
+;; Figure 30: Calling convention.
+;;
+(define-enumeration calling-convention-code->name calling-convention-name->code
+ (normal #x1)
+ (program #x2)
+ (nocall #x3)
+ (lo-user #x40)
+ (hi-user #xff))
+
+;; Figure 31: Inline attribute.
+;;
+(define-enumeration inline-code->name inline-name->code
+ (not-inlined 0)
+ (inlined 1)
+ (declared-not-inlined 2)
+ (declared-inlined 3))
+
+;; Figure 32: Array ordering names and codes.
+(define-enumeration ordering-code->name ordering-name->code
+ (row-major 0)
+ (col-major 1))
+
+;; Figure 33: Discriminant lists.
+;;
+(define-enumeration discriminant-code->name discriminant-name->code
+ (label 0)
+ (range 1))
+
+;; Figure 34: "Standard" line number opcodes.
+;;
+(define-enumeration standard-line-opcode->name standard-line-name->opcode
+ (extended-op 0)
+ (copy 1)
+ (advance-pc 2)
+ (advance-line 3)
+ (set-file 4)
+ (set-column 5)
+ (negate-stmt 6)
+ (set-basic-block 7)
+ (const-add-pc 8)
+ (fixed-advance-pc 9)
+ ;; DWARF 3.
+ (set-prologue-end #x0a)
+ (set-epilogue-begin #x0b)
+ (set-isa #x0c))
+
+;; Figure 35: "Extended" line number opcodes.
+;;
+(define-enumeration extended-line-opcode->name extended-line-name->opcode
+ (end-sequence 1)
+ (set-address 2)
+ (define-file 3)
+ ;; DWARF 3.
+ (lo-user #x80)
+ (hi-user #xff))
+
+;; Figure 36: Names and codes for macro information.
+;;
+(define-enumeration macro-code->name macro-name->code
+ (define 1)
+ (undef 2)
+ (start-file 3)
+ (end-file 4)
+ (vendor-ext 255))
+
+;; Figure 37: Call frame information.
+;;
+(define-enumeration call-frame-address-code->name call-frame-address-code->name
+ (advance-loc #x40)
+ (offset #x80)
+ (restore #xc0)
+ (nop #x00)
+ (set-loc #x01)
+ (advance-loc1 #x02)
+ (advance-loc2 #x03)
+ (advance-loc4 #x04)
+ (offset-extended #x05)
+ (restore-extended #x06)
+ (undefined #x07)
+ (same-value #x08)
+ (register #x09)
+ (remember-state #x0a)
+ (restore-state #x0b)
+ (def-cfa #x0c)
+ (def-cfa-register #x0d)
+ (def-cfa-offset #x0e)
+ ;; DWARF 3.
+ (def-cfa-expression #x0f)
+ (expression #x10)
+ (offset-extended-sf #x11)
+ (def-cfa-sf #x12)
+ (def-cfa-offset-sf #x13)
+ (val-offset #x14)
+ (val-offset-sf #x15)
+ (val-expression #x16)
+ (GNU-window-save #x2d)
+ (GNU-args-size #x2e)
+ (GNU-negative-offset-extended #x2f)
+
+ (extended 0)
+ (low-user #x1c)
+ (high-user #x3f))
+
+;(define CIE-ID #xffffffff)
+;(define CIE-VERSION 1)
+;(define ADDR-none 0)
+
+
+;;;
+;;; A general configuration object.
+;;;
+
+(define-record-type <dwarf-meta>
+ (make-dwarf-meta addr-size
+ vaddr memsz
+ path lib-path
+ info-start info-end
+ abbrevs-start abbrevs-end
+ strtab-start strtab-end
+ loc-start loc-end
+ line-start line-end
+ pubnames-start pubnames-end
+ aranges-start aranges-end)
+ dwarf-meta?
+ (addr-size meta-addr-size)
+ (vaddr meta-vaddr)
+ (memsz meta-memsz)
+ (path meta-path)
+ (lib-path meta-lib-path)
+ (info-start meta-info-start)
+ (info-end meta-info-end)
+ (abbrevs-start meta-abbrevs-start)
+ (abbrevs-end meta-abbrevs-end)
+ (strtab-start meta-strtab-start)
+ (strtab-end meta-strtab-end)
+ (loc-start meta-loc-start)
+ (loc-end meta-loc-end)
+ (line-start meta-line-start)
+ (line-end meta-line-end)
+ (pubnames-start meta-pubnames-start)
+ (pubnames-end meta-pubnames-end)
+ (aranges-start meta-aranges-start)
+ (aranges-end meta-aranges-end))
+
+;; A context represents a namespace. The root context is the
+;; compilation unit. DIE nodes of type class-type, structure-type, or
+;; namespace may form child contexts.
+;;
+(define-record-type <dwarf-context>
+ (make-dwarf-context bv offset-size endianness meta
+ abbrevs
+ parent die start end children)
+ dwarf-context?
+ (bv ctx-bv)
+ (offset-size ctx-offset-size)
+ (endianness ctx-endianness)
+ (meta ctx-meta)
+ (abbrevs ctx-abbrevs)
+ (parent ctx-parent)
+ (die ctx-die)
+ (start ctx-start)
+ (end ctx-end)
+ (children ctx-children set-children!))
+
+
+(set-record-type-printer! <dwarf-context>
+ (lambda (x port)
+ (format port "<dwarf-context ~a>"
+ (number->string (object-address x) 16))))
+
+(define-inlinable (ctx-addr-size ctx)
+ (meta-addr-size (ctx-meta ctx)))
+
+;;;
+;;; Procedures for reading DWARF data.
+;;;
+
+(define (read-u8 ctx pos)
+ (values (bytevector-u8-ref (ctx-bv ctx) pos)
+ (1+ pos)))
+(define (read-s8 ctx pos)
+ (values (bytevector-s8-ref (ctx-bv ctx) pos)
+ (1+ pos)))
+(define (skip-8 ctx pos)
+ (+ pos 1))
+
+(define (read-u16 ctx pos)
+ (values (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx))
+ (+ pos 2)))
+(define (skip-16 ctx pos)
+ (+ pos 2))
+
+(define (read-u32 ctx pos)
+ (values (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx))
+ (+ pos 4)))
+(define (skip-32 ctx pos)
+ (+ pos 4))
+
+(define (read-u64 ctx pos)
+ (values (bytevector-u64-ref (ctx-bv ctx) pos (ctx-endianness ctx))
+ (+ pos 8)))
+(define (skip-64 ctx pos)
+ (+ pos 8))
+
+(define (read-addr ctx pos)
+ (case (ctx-addr-size ctx)
+ ((4) (read-u32 ctx pos))
+ ((8) (read-u64 ctx pos))
+ (else (error "unsupported word size" ctx))))
+(define (skip-addr ctx pos)
+ (+ pos (ctx-addr-size ctx)))
+
+(define (%read-uleb128 bv pos)
+ ;; Unrolled by one.
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values b
+ (1+ pos))
+ (let lp ((n (logxor #x80 b)) (pos (1+ pos)) (shift 7))
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values (logior (ash b shift) n)
+ (1+ pos))
+ (lp (logior (ash (logxor #x80 b) shift) n)
+ (1+ pos)
+ (+ shift 7))))))))
+
+(define (%read-sleb128 bv pos)
+ (let lp ((n 0) (pos pos) (shift 0))
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (values (logior (ash b shift) n
+ (if (zero? (logand #x40 b))
+ 0
+ (- (ash 1 (+ shift 7)))))
+ (1+ pos))
+ (lp (logior (ash (logxor #x80 b) shift) n)
+ (1+ pos)
+ (+ shift 7))))))
+
+(define (read-uleb128 ctx pos)
+ (%read-uleb128 (ctx-bv ctx) pos))
+
+(define (read-sleb128 ctx pos)
+ (%read-sleb128 (ctx-bv ctx) pos))
+
+(define (skip-leb128 ctx pos)
+ (let ((bv (ctx-bv ctx)))
+ (let lp ((pos pos))
+ (let ((b (bytevector-u8-ref bv pos)))
+ (if (zero? (logand b #x80))
+ (1+ pos)
+ (lp (1+ pos)))))))
+
+(define (read-initial-length ctx pos)
+ (let ((len (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx))))
+ (cond
+ ((= len #xffffffff)
+ (values (bytevector-u32-ref (ctx-bv ctx) (+ pos 4) (ctx-endianness ctx))
+ (+ pos 12)
+ 8))
+ ((>= len #xfffffff0)
+ (error "bad initial length value" len))
+ (else
+ (values len
+ (+ pos 4)
+ 4)))))
+
+(define* (read-offset ctx pos #:optional (offset-size (ctx-offset-size ctx)))
+ (case offset-size
+ ((4) (values (read-u32 ctx pos) (+ pos 4)))
+ ((8) (values (read-u64 ctx pos) (+ pos 8)))
+ (else (error "bad word size" offset-size))))
+
+(define* (skip-offset ctx pos #:optional (offset-size (ctx-offset-size ctx)))
+ (+ pos offset-size))
+
+(define (read-block ctx pos len)
+ (let ((bv (make-bytevector len)))
+ (bytevector-copy! (ctx-bv ctx) pos bv 0 len)
+ (values bv
+ (+ pos len))))
+
+(define (read-string ctx pos)
+ (let ((bv (ctx-bv ctx)))
+ (let lp ((end pos))
+ (if (zero? (bytevector-u8-ref bv end))
+ (let ((out (make-bytevector (- end pos))))
+ (bytevector-copy! bv pos out 0 (- end pos))
+ (values (utf8->string out)
+ (1+ end)))
+ (lp (1+ end))))))
+
+(define (skip-string ctx pos)
+ (let ((bv (ctx-bv ctx)))
+ (let lp ((end pos))
+ (if (zero? (bytevector-u8-ref bv end))
+ (1+ end)
+ (lp (1+ end))))))
+
+(define (read-string-seq ctx pos)
+ (let ((bv (ctx-bv ctx)))
+ (let lp ((pos pos) (strs '()))
+ (if (zero? (bytevector-u8-ref bv pos))
+ (values (list->vector (reverse strs)) (1+ pos))
+ (let-values (((str pos) (read-string ctx pos)))
+ (lp pos (cons str strs)))))))
+
+(define-record-type <abbrev>
+ (make-abbrev code tag has-children? attrs forms)
+ abbrev?
+ (code abbrev-code)
+ (tag abbrev-tag)
+ (has-children? abbrev-has-children?)
+ (attrs abbrev-attrs)
+ (forms abbrev-forms))
+
+(define (read-abbrev ctx pos)
+ (let*-values (((code pos) (read-uleb128 ctx pos))
+ ((tag pos) (read-uleb128 ctx pos))
+ ((children pos) (read-u8 ctx pos)))
+ (let lp ((attrs '()) (forms '()) (pos pos))
+ (let*-values (((attr pos) (read-uleb128 ctx pos))
+ ((form pos) (read-uleb128 ctx pos)))
+ (if (and (zero? attr) (zero? form))
+ (values (make-abbrev code
+ (tag-code->name tag)
+ (eq? (children-code->name children) 'yes)
+ (reverse attrs)
+ (reverse forms))
+ pos)
+ (lp (cons (attribute-code->name attr) attrs)
+ (cons (form-code->name form) forms)
+ pos))))))
+
+(define* (read-abbrevs ctx pos
+ #:optional (start (meta-abbrevs-start
+ (ctx-meta ctx)))
+ (end (meta-abbrevs-end
+ (ctx-meta ctx))))
+ (let lp ((abbrevs '()) (pos (+ start pos)) (max-code -1))
+ (if (zero? (read-u8 ctx pos))
+ (if (< pos end)
+ (let ((av (make-vector (1+ max-code) #f)))
+ (for-each (lambda (a)
+ (vector-set! av (abbrev-code a) a))
+ abbrevs)
+ av)
+ (error "Unexpected length" abbrevs pos start end))
+ (let-values (((abbrev pos) (read-abbrev ctx pos)))
+ (lp (cons abbrev abbrevs)
+ pos
+ (max (abbrev-code abbrev) max-code))))))
+
+(define (ctx-compile-unit-start ctx)
+ (if (ctx-die ctx)
+ (ctx-compile-unit-start (ctx-parent ctx))
+ (ctx-start ctx)))
+
+;; Values.
+;;
+(define *readers* (make-hash-table))
+(define *scanners* (make-hash-table))
+(define-syntax define-value-reader
+ (syntax-rules ()
+ ((_ form reader scanner)
+ (begin
+ (hashq-set! *readers* 'form reader)
+ (hashq-set! *scanners* 'form scanner)))))
+
+(define-value-reader addr read-addr skip-addr)
+
+(define-value-reader block
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-uleb128 ctx pos)))
+ (read-block ctx pos len)))
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-uleb128 ctx pos)))
+ (+ pos len))))
+
+(define-value-reader block1
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-u8 ctx pos)))
+ (read-block ctx pos len)))
+ (lambda (ctx pos)
+ (+ pos 1 (bytevector-u8-ref (ctx-bv ctx) pos))))
+
+(define-value-reader block2
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-u16 ctx pos)))
+ (read-block ctx pos len)))
+ (lambda (ctx pos)
+ (+ pos 2 (bytevector-u16-ref (ctx-bv ctx) pos (ctx-endianness ctx)))))
+
+(define-value-reader block4
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-u32 ctx pos)))
+ (read-block ctx pos len)))
+ (lambda (ctx pos)
+ (+ pos 4 (bytevector-u32-ref (ctx-bv ctx) pos (ctx-endianness ctx)))))
+
+(define-value-reader data1 read-u8 skip-8)
+(define-value-reader data2 read-u16 skip-16)
+(define-value-reader data4 read-u32 skip-32)
+(define-value-reader data8 read-u64 skip-64)
+(define-value-reader udata read-uleb128 skip-leb128)
+(define-value-reader sdata read-sleb128 skip-leb128)
+
+(define-value-reader flag
+ (lambda (ctx pos)
+ (values (not (zero? (bytevector-u8-ref (ctx-bv ctx) pos)))
+ (1+ pos)))
+ skip-8)
+
+(define-value-reader string
+ read-string
+ skip-string)
+
+(define-value-reader strp
+ (lambda (ctx pos)
+ (let ((strtab (meta-strtab-start (ctx-meta ctx))))
+ (unless strtab
+ (error "expected a string table" ctx))
+ (let-values (((offset pos) (read-offset ctx pos)))
+ (values (read-string ctx (+ strtab offset))
+ pos))))
+ skip-32)
+
+(define-value-reader ref-addr
+ (lambda (ctx pos)
+ (let-values (((addr pos) (read-addr ctx pos)))
+ (values (+ addr (meta-info-start (ctx-meta ctx)))
+ pos)))
+ skip-addr)
+
+(define-value-reader ref1
+ (lambda (ctx pos)
+ (let-values (((addr pos) (read-u8 ctx pos)))
+ (values (+ addr (ctx-compile-unit-start ctx))
+ pos)))
+ skip-8)
+
+(define-value-reader ref2
+ (lambda (ctx pos)
+ (let-values (((addr pos) (read-u16 ctx pos)))
+ (values (+ addr (ctx-compile-unit-start ctx))
+ pos)))
+ skip-16)
+
+(define-value-reader ref4
+ (lambda (ctx pos)
+ (let-values (((addr pos) (read-u32 ctx pos)))
+ (values (+ addr (ctx-compile-unit-start ctx))
+ pos)))
+ skip-32)
+
+(define-value-reader ref8
+ (lambda (ctx pos)
+ (let-values (((addr pos) (read-u64 ctx pos)))
+ (values (+ addr (ctx-compile-unit-start ctx))
+ pos)))
+ skip-64)
+
+(define-value-reader ref
+ (lambda (udata ctx pos)
+ (let-values (((addr pos) (read-uleb128 ctx pos)))
+ (values (+ addr (ctx-compile-unit-start ctx))
+ pos)))
+ skip-leb128)
+
+(define-value-reader indirect
+ (lambda (ctx pos)
+ (let*-values (((form pos) (read-uleb128 ctx pos))
+ ((val pos) (read-value ctx pos (form-code->name form))))
+ (values (cons form val)
+ pos)))
+ (lambda (ctx pos)
+ (let*-values (((form pos) (read-uleb128 ctx pos)))
+ (skip-value ctx pos (form-code->name form)))))
+
+(define-value-reader sec-offset
+ read-offset
+ skip-offset)
+
+(define-value-reader exprloc
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-uleb128 ctx pos)))
+ (read-block ctx pos len)))
+ (lambda (ctx pos)
+ (let-values (((len pos) (read-uleb128 ctx pos)))
+ (+ pos len))))
+
+(define-value-reader flag-present
+ (lambda (ctx pos)
+ (values #t pos))
+ (lambda (ctx pos)
+ pos))
+
+(define-value-reader ref-sig8
+ read-u64
+ skip-64)
+
+(define (read-value ctx pos form)
+ ((or (hashq-ref *readers* form)
+ (error "unrecognized form" form))
+ ctx pos))
+
+(define (skip-value ctx pos form)
+ ((or (hashq-ref *scanners* form)
+ (error "unrecognized form" form))
+ ctx pos))
+
+;; Parsers for particular attributes.
+;;
+(define (parse-location-list ctx offset)
+ (let lp ((pos (+ (meta-loc-start (ctx-meta ctx)) offset))
+ (out '()))
+ (let*-values (((start pos) (read-addr ctx pos))
+ ((end pos) (read-addr ctx pos)))
+ (if (and (zero? start) (zero? end))
+ (reverse out)
+ (let*-values (((len pos) (read-u16 ctx pos))
+ ((block pos) (read-block ctx pos len)))
+ (lp pos
+ (cons (list start end (parse-location ctx block)) out)))))))
+
+(define (parse-location ctx loc)
+ (cond
+ ((bytevector? loc)
+ (let ((len (bytevector-length loc))
+ (addr-size (ctx-addr-size ctx))
+ (endianness (ctx-endianness ctx)))
+ (define (u8-ref pos) (bytevector-u8-ref loc pos))
+ (define (s8-ref pos) (bytevector-s8-ref loc pos))
+ (define (u16-ref pos) (bytevector-u16-ref loc pos endianness))
+ (define (s16-ref pos) (bytevector-s16-ref loc pos endianness))
+ (define (u32-ref pos) (bytevector-u32-ref loc pos endianness))
+ (define (s32-ref pos) (bytevector-s32-ref loc pos endianness))
+ (define (u64-ref pos) (bytevector-u64-ref loc pos endianness))
+ (define (s64-ref pos) (bytevector-s64-ref loc pos endianness))
+ (let lp ((pos 0) (out '()))
+ (if (= pos len)
+ (reverse out)
+ (let ((op (location-op->name (u8-ref pos))))
+ (case op
+ ((addr)
+ (case addr-size
+ ((4) (lp (+ pos 5) (cons (list op (u32-ref (1+ pos))) out)))
+ ((8) (lp (+ pos 9) (cons (list op (u64-ref (1+ pos))) out)))
+ (else (error "what!"))))
+ ((call-ref)
+ (case addr-size
+ ((4) (lp (+ pos 5)
+ (cons (list op (+ (meta-info-start (ctx-meta ctx))
+ (u32-ref (1+ pos))))
+ out)))
+ ((8) (lp (+ pos 9)
+ (cons (list op (+ (meta-info-start (ctx-meta ctx))
+ (u64-ref (1+ pos))))
+ out)))
+ (else (error "what!"))))
+ ((const1u pick deref-size xderef-size)
+ (lp (+ pos 2) (cons (list op (u8-ref (1+ pos))) out)))
+ ((const1s)
+ (lp (+ pos 2) (cons (list op (s8-ref (1+ pos))) out)))
+ ((const2u)
+ (lp (+ pos 3) (cons (list op (u16-ref (1+ pos))) out)))
+ ((call2)
+ (lp (+ pos 3) (cons (list op (+ (ctx-compile-unit-start ctx)
+ (u16-ref (1+ pos))))
+ out)))
+ ((const2s skip bra)
+ (lp (+ pos 3) (cons (list op (s16-ref (1+ pos))) out)))
+ ((const4u)
+ (lp (+ pos 5) (cons (list op (u32-ref (1+ pos))) out)))
+ ((call4)
+ (lp (+ pos 5) (cons (list op (+ (ctx-compile-unit-start ctx)
+ (u32-ref (1+ pos))))
+ out)))
+ ((const4s)
+ (lp (+ pos 5) (cons (list op (s32-ref (1+ pos))) out)))
+ ((const8u)
+ (lp (+ pos 9) (cons (list op (u64-ref (1+ pos))) out)))
+ ((const8s)
+ (lp (+ pos 9) (cons (list op (s64-ref (1+ pos))) out)))
+ ((plus-uconst regx piece)
+ (let-values (((val pos) (%read-uleb128 loc (1+ pos))))
+ (lp pos (cons (list op val) out))))
+ ((bit-piece)
+ (let*-values (((bit-len pos) (%read-uleb128 loc (1+ pos)))
+ ((bit-offset pos) (%read-uleb128 loc pos)))
+ (lp pos (cons (list op bit-len bit-offset) out))))
+ ((breg0 breg1 breg2 breg3 breg4 breg5 breg6 breg7 breg8 breg9
+ breg10 breg11 breg12 breg13 breg14 breg15 breg16 breg17
+ breg18 breg19 breg20 breg21 breg22 breg23 breg24 breg25
+ breg26 breg27 breg28 breg29 breg30 breg31 fbreg)
+ (let-values (((val pos) (%read-sleb128 loc (1+ pos))))
+ (lp pos (cons (list op val) out))))
+ (else
+ (if (number? op)
+ ;; We failed to parse this opcode; we have to give
+ ;; up
+ loc
+ (lp (1+ pos) (cons (list op) out))))))))))
+ (else
+ (parse-location-list ctx loc))))
+
+;; Statement programs.
+(define-record-type <lregs>
+ (make-lregs pos pc file line column)
+ lregs?
+ (pos lregs-pos set-lregs-pos!)
+ (pc lregs-pc set-lregs-pc!)
+ (file lregs-file set-lregs-file!)
+ (line lregs-line set-lregs-line!)
+ (column lregs-column set-lregs-column!))
+
+(define-record-type <line-prog>
+ (%make-line-prog ctx version
+ header-offset program-offset end
+ min-insn-length max-insn-ops default-stmt?
+ line-base line-range opcode-base
+ standard-opcode-lengths
+ include-directories file-names
+ regs)
+ line-prog?
+ (ctx line-prog-ctx)
+ (version line-prog-version)
+ (header-offset line-prog-header-offset)
+ (program-offset line-prog-program-offset)
+ (end line-prog-end)
+ (min-insn-length line-prog-min-insn-length)
+ (max-insn-ops line-prog-max-insn-ops)
+ (default-stmt? line-prog-default-stmt?)
+ (line-base line-prog-line-base)
+ (line-range line-prog-line-range)
+ (opcode-base line-prog-opcode-base)
+ (standard-opcode-lengths line-prog-standard-opcode-lengths)
+ (include-directories line-prog-include-directories)
+ (file-names line-prog-file-names)
+ (regs line-prog-regs))
+
+(define (make-line-prog ctx header-pos end)
+ (unless (> end (+ header-pos 12))
+ (error "statement program header too short"))
+ (let-values (((len pos offset-size) (read-initial-length ctx header-pos)))
+ (unless (<= (+ pos len) end)
+ (error (".debug_line too short")))
+ (let*-values (((version pos) (read-u16 ctx pos))
+ ((prologue-len prologue-pos) (read-u32 ctx pos))
+ ((min-insn-len pos) (read-u8 ctx prologue-pos))
+ ;; The maximum_operations_per_instruction field is
+ ;; only present in DWARFv4.
+ ((max-insn-ops pos) (if (< version 4)
+ (values 1 pos)
+ (read-u8 ctx pos)))
+ ((default-stmt pos) (read-u8 ctx pos))
+ ((line-base pos) (read-s8 ctx pos))
+ ((line-range pos) (read-u8 ctx pos))
+ ((opcode-base pos) (read-u8 ctx pos))
+ ((opcode-lens pos) (read-block ctx pos (1- opcode-base)))
+ ((include-directories pos) (read-string-seq ctx pos))
+ ((file-names pos)
+ (let lp ((pos pos) (strs '()))
+ (if (zero? (bytevector-u8-ref (ctx-bv ctx) pos))
+ (values (reverse strs) (1+ pos))
+ (let-values (((str pos) (read-string ctx pos)))
+ (let* ((pos (skip-leb128 ctx pos)) ; skip dir
+ (pos (skip-leb128 ctx pos)) ; skip mtime
+ (pos (skip-leb128 ctx pos))) ; skip len
+ (lp pos (cons str strs))))))))
+ (unless (= pos (+ prologue-pos prologue-len))
+ (error "unexpected prologue length"))
+ (%make-line-prog ctx version header-pos pos end
+ min-insn-len max-insn-ops (not (zero? default-stmt))
+ line-base line-range opcode-base opcode-lens
+ include-directories file-names
+ ;; Initial state: file=1, line=1, col=0
+ (make-lregs pos 0 1 1 0)))))
+
+(define (line-prog-next-row prog pos pc file line col)
+ (let ((ctx (line-prog-ctx prog))
+ (end (line-prog-end prog))
+ (min-insn-len (line-prog-min-insn-length prog))
+ (line-base (line-prog-line-base prog))
+ (line-range (line-prog-line-range prog))
+ (opcode-base (line-prog-opcode-base prog))
+ (opcode-lens (line-prog-standard-opcode-lengths prog)))
+
+ (let lp ((pos pos) (pc pc) (file file) (line line) (col col))
+ (cond
+ ((>= pos end)
+ (values #f #f #f #f #f))
+ (else
+ (let-values (((op pos) (read-u8 ctx pos)))
+ (cond
+ ((zero? op) ; extended opcodes
+ (let*-values (((len pos*) (read-uleb128 ctx pos))
+ ((op pos) (read-u8 ctx pos*)))
+ (case op
+ ((1) ; end-sequence
+ (values pos pc file line col))
+ ((2) ; set-address
+ (let-values (((addr pos) (read-addr ctx pos)))
+ (unless (>= addr pc)
+ (error "pc not advancing"))
+ (lp pos addr file line col)))
+ ((3) ; define-file
+ (warn "define-file unimplemented")
+ (lp (+ pos* len) pc file line col))
+ ((4) ; set-discriminator; ignore.
+ (lp (+ pos* len) pc file line col))
+ (else
+ (warn "unknown extended op" op)
+ (lp (+ pos* len) pc file line col)))))
+
+ ((< op opcode-base) ; standard opcodes
+ (case op
+ ((1) ; copy
+ (values pos pc file line col))
+ ((2) ; advance-pc
+ (let-values (((advance pos) (read-uleb128 ctx pos)))
+ (lp pos (+ pc (* advance min-insn-len)) file line col)))
+ ((3) ; advance-line
+ (let-values (((diff pos) (read-sleb128 ctx pos)))
+ (lp pos pc file (+ line diff) col)))
+ ((4) ; set-file
+ (let-values (((file pos) (read-uleb128 ctx pos)))
+ (lp pos pc file line col)))
+ ((5) ; set-column
+ (let-values (((col pos) (read-uleb128 ctx pos)))
+ (lp pos pc file line col)))
+ ((6) ; negate-line
+ (lp pos pc file line col))
+ ((7) ; set-basic-block
+ (lp pos pc file line col))
+ ((8) ; const-add-pc
+ (let ((advance (floor/ (- 255 opcode-base) line-range)))
+ (lp pos (+ pc (* advance min-insn-len)) file line col)))
+ ((9) ; fixed-advance-pc
+ (let-values (((advance pos) (read-u16 ctx pos)))
+ (lp pos (+ pc (* advance min-insn-len)) file line col)))
+ (else
+ ;; fixme: read args and move on
+ (error "unknown extended op" op))))
+ (else ; special opcodes
+ (let-values (((quo rem) (floor/ (- op opcode-base) line-range)))
+ (values pos (+ pc (* quo min-insn-len))
+ file (+ line (+ rem line-base)) col))))))))))
+
+(define (line-prog-advance prog)
+ (let ((regs (line-prog-regs prog)))
+ (call-with-values (lambda ()
+ (line-prog-next-row prog
+ (lregs-pos regs)
+ (lregs-pc regs)
+ (lregs-file regs)
+ (lregs-line regs)
+ (lregs-column regs)))
+ (lambda (pos pc file line col)
+ (cond
+ ((not pos)
+ (values #f #f #f #f))
+ (else
+ (set-lregs-pos! regs pos)
+ (set-lregs-pc! regs pc)
+ (set-lregs-file! regs file)
+ (set-lregs-line! regs line)
+ (set-lregs-column! regs col)
+ ;; Return DWARF-numbered lines and columns (1-based).
+ (values pc
+ (if (zero? file)
+ #f
+ (list-ref (line-prog-file-names prog) (1- file)))
+ (if (zero? line) #f line)
+ (if (zero? col) #f col))))))))
+
+(define (line-prog-scan-to-pc prog target-pc)
+ (let ((regs (line-prog-regs prog)))
+ (define (finish pos pc file line col)
+ (set-lregs-pos! regs pos)
+ (set-lregs-pc! regs pc)
+ (set-lregs-file! regs file)
+ (set-lregs-line! regs line)
+ (set-lregs-column! regs col)
+ ;; Return DWARF-numbered lines and columns (1-based).
+ (values pc
+ (if (zero? file)
+ #f
+ (list-ref (line-prog-file-names prog) (1- file)))
+ (if (zero? line) #f line)
+ (if (zero? col) #f col)))
+ (define (scan pos pc file line col)
+ (call-with-values (lambda ()
+ (line-prog-next-row prog pos pc file line col))
+ (lambda (pos* pc* file* line* col*)
+ (cond
+ ((not pos*)
+ (values #f #f #f #f))
+ ((< pc* target-pc)
+ (scan pos* pc* file* line* col*))
+ ((= pc* target-pc)
+ (finish pos* pc* file* line* col*))
+ ((zero? pc)
+ ;; We scanned from the beginning didn't find any info.
+ (values #f #f #f #f))
+ (else
+ (finish pos pc file line col))))))
+ (let ((pos (lregs-pos regs))
+ (pc (lregs-pc regs))
+ (file (lregs-file regs))
+ (line (lregs-line regs))
+ (col (lregs-column regs)))
+ (if (< pc target-pc)
+ (scan pos pc file line col)
+ (scan (line-prog-program-offset prog) 0 1 1 0)))))
+
+(define-syntax-rule (define-attribute-parsers parse (name parser) ...)
+ (define parse
+ (let ((parsers (make-hash-table)))
+ (hashq-set! parsers 'name parser)
+ ...
+ (lambda (ctx attr val)
+ (cond
+ ((hashq-ref parsers attr) => (lambda (p) (p ctx val)))
+ (else val))))))
+
+(define-attribute-parsers parse-attribute
+ (encoding (lambda (ctx val) (type-encoding->name val)))
+ (accessibility (lambda (ctx val) (access-code->name val)))
+ (visibility (lambda (ctx val) (visibility-code->name val)))
+ (virtuality (lambda (ctx val) (virtuality-code->name val)))
+ (language (lambda (ctx val) (language-code->name val)))
+ (location parse-location)
+ (data-member-location parse-location)
+ (case-sensitive (lambda (ctx val) (case-sensitivity-code->name val)))
+ (calling-convention (lambda (ctx val) (calling-convention-code->name val)))
+ (inline (lambda (ctx val) (inline-code->name val)))
+ (ordering (lambda (ctx val) (ordering-code->name val)))
+ (discr-value (lambda (ctx val) (discriminant-code->name val))))
+
+;; "Debugging Information Entries": DIEs.
+;;
+(define-record-type <die>
+ (make-die ctx offset abbrev vals)
+ die?
+ (ctx die-ctx)
+ (offset die-offset)
+ (abbrev die-abbrev)
+ (vals %die-vals %set-die-vals!))
+
+(define (die-tag die)
+ (abbrev-tag (die-abbrev die)))
+
+(define (die-attrs die)
+ (abbrev-attrs (die-abbrev die)))
+
+(define (die-forms die)
+ (abbrev-forms (die-abbrev die)))
+
+(define (die-vals die)
+ (let ((vals (%die-vals die)))
+ (or vals
+ (begin
+ (%set-die-vals! die (read-values (die-ctx die) (skip-leb128 (die-ctx die) (die-offset die)) (die-abbrev die)))
+ (die-vals die)))))
+
+(define* (die-next-offset die #:optional offset-vals)
+ (let ((ctx (die-ctx die)))
+ (skip-values ctx (or offset-vals (skip-leb128 ctx (die-offset die)))
+ (die-abbrev die))))
+
+(define* (die-ref die attr #:optional default)
+ (cond
+ ((list-index (die-attrs die) attr)
+ => (lambda (n) (list-ref (die-vals die) n)))
+ (else default)))
+
+(define (die-specification die)
+ (and=> (die-ref die 'specification)
+ (lambda (offset) (find-die-by-offset (die-ctx die) offset))))
+
+(define (die-name die)
+ (or (die-ref die 'name)
+ (and=> (die-specification die) die-name)))
+
+(define (die-qname die)
+ (cond
+ ((eq? (die-tag die) 'compile-unit) "")
+ ((die-ref die 'name)
+ => (lambda (name)
+ (if (eq? (die-tag (ctx-die (die-ctx die))) 'compile-unit)
+ name ; short cut
+ (string-append (die-qname (ctx-die (die-ctx die))) "::" name))))
+ ((die-specification die)
+ => die-qname)
+ (else #f)))
+
+(define (die-line-prog die)
+ (let ((stmt-list (die-ref die 'stmt-list)))
+ (and stmt-list
+ (let* ((ctx (die-ctx die))
+ (meta (ctx-meta ctx)))
+ (make-line-prog ctx
+ (+ (meta-line-start meta) stmt-list)
+ (meta-line-end meta))))))
+
+(define (read-values ctx offset abbrev)
+ (let lp ((attrs (abbrev-attrs abbrev))
+ (forms (abbrev-forms abbrev))
+ (vals '())
+ (pos offset))
+ (if (null? forms)
+ (values (reverse vals) pos)
+ (let-values (((val pos) (read-value ctx pos (car forms))))
+ (lp (cdr attrs) (cdr forms)
+ (cons (parse-attribute ctx (car attrs) val) vals)
+ pos)))))
+
+(define (skip-values ctx offset abbrev)
+ (let lp ((forms (abbrev-forms abbrev))
+ (pos offset))
+ (if (null? forms)
+ pos
+ (lp (cdr forms) (skip-value ctx pos (car forms))))))
+
+(define (read-die-abbrev ctx offset)
+ (let*-values (((code pos) (read-uleb128 ctx offset)))
+ (values (cond ((zero? code) #f)
+ ((vector-ref (ctx-abbrevs ctx) code))
+ (else (error "unknown abbrev" ctx code)))
+ pos)))
+
+(define (read-die ctx offset)
+ (let*-values (((abbrev pos) (read-die-abbrev ctx offset)))
+ (if abbrev
+ (values (make-die ctx offset abbrev #f)
+ (skip-values ctx pos abbrev))
+ (values #f pos))))
+
+(define* (die-sibling ctx abbrev offset #:optional offset-vals offset-end)
+ (cond
+ ((not (abbrev-has-children? abbrev))
+ (or offset-end
+ (skip-values ctx
+ (or offset-vals (skip-leb128 ctx offset))
+ abbrev)))
+ ((memq 'sibling (abbrev-attrs abbrev))
+ (let lp ((offset (or offset-vals (skip-leb128 ctx offset)))
+ (attrs (abbrev-attrs abbrev))
+ (forms (abbrev-forms abbrev)))
+ (if (eq? (car attrs) 'sibling)
+ (read-value ctx offset (car forms))
+ (lp (skip-value ctx offset (car forms))
+ (cdr attrs) (cdr forms)))))
+ (else
+ (call-with-values
+ (lambda ()
+ (fold-die-list ctx
+ (or offset-end
+ (skip-values ctx
+ (or offset-vals
+ (skip-leb128 ctx offset))
+ abbrev))
+ (lambda (ctx offset abbrev) #t)
+ error
+ #f))
+ (lambda (seed pos)
+ pos)))))
+
+(define (find-die-context ctx offset)
+ (define (not-found)
+ (error "failed to find DIE by context" offset))
+ (define (in-context? ctx)
+ (and (<= (ctx-start ctx) offset)
+ (< offset (ctx-end ctx))))
+ (define (find-root ctx)
+ (if (in-context? ctx)
+ ctx
+ (find-root (or (ctx-parent ctx) (not-found)))))
+ (define (find-leaf ctx)
+ (let lp ((kids (ctx-children ctx)))
+ (if (null? kids)
+ ctx
+ (if (in-context? (car kids))
+ (find-leaf (car kids))
+ (lp (cdr kids))))))
+ (find-leaf (find-root ctx)))
+
+(define (find-die-by-offset ctx offset)
+ (or (read-die (find-die-context ctx offset) offset)
+ (error "Failed to read DIE at offset" offset)))
+
+(define-syntax-rule (let/ec k e e* ...)
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (let ((k (lambda args (apply abort-to-prompt tag args))))
+ e e* ...))
+ (lambda (_ res) res))))
+
+(define* (find-die roots pred #:key
+ (skip? (lambda (ctx offset abbrev) #f))
+ (recurse? (lambda (die) #t)))
+ (let/ec k
+ (define (visit-die die)
+ (cond
+ ((pred die)
+ (k die))
+ ((recurse? die)
+ (fold-die-children die (lambda (die seed) (visit-die die)) #f
+ #:skip? skip?))
+ (else #f)))
+ (for-each visit-die roots)
+ #f))
+
+(define (die-low-pc die)
+ (die-ref die 'low-pc))
+(define (die-high-pc die)
+ (let ((val (die-ref die 'high-pc)))
+ (and val
+ (let ((idx (list-index (die-attrs die) 'high-pc)))
+ (case (list-ref (die-forms die) idx)
+ ((addr) val)
+ (else (+ val (die-low-pc die))))))))
+
+(define (find-die-by-pc roots pc)
+ ;; The result will be a subprogram.
+ (define (skip? ctx offset abbrev)
+ (case (abbrev-tag abbrev)
+ ((subprogram compile-unit) #f)
+ (else #t)))
+ (define (recurse? die)
+ (case (die-tag die)
+ ((compile-unit)
+ (not (or (and=> (die-low-pc die)
+ (lambda (low) (< pc low)))
+ (and=> (die-high-pc die)
+ (lambda (high) (<= high pc))))))
+ (else #f)))
+ (find-die roots
+ (lambda (die)
+ (and (eq? (die-tag die) 'subprogram)
+ (equal? (die-low-pc die) pc)))
+ #:skip? skip? #:recurse? recurse?))
+
+(define (fold-die-list ctx offset skip? proc seed)
+ (let ((ctx (find-die-context ctx offset)))
+ (let lp ((offset offset) (seed seed))
+ (let-values (((abbrev pos) (read-die-abbrev ctx offset)))
+ (cond
+ ((not abbrev) (values seed pos))
+ ((skip? ctx offset abbrev)
+ (lp (die-sibling ctx abbrev offset pos) seed))
+ (else
+ (let-values (((vals pos) (read-values ctx pos abbrev)))
+ (let* ((die (make-die ctx offset abbrev vals))
+ (seed (proc die seed)))
+ (lp (die-sibling ctx abbrev offset #f pos) seed)))))))))
+
+(define* (fold-die-children die proc seed #:key
+ (skip? (lambda (ctx offset abbrev) #f)))
+ (if (abbrev-has-children? (die-abbrev die))
+ (values (fold-die-list (die-ctx die) (die-next-offset die)
+ skip? proc seed))
+ seed))
+
+(define (die-children die)
+ (reverse (fold-die-children die cons '())))
+
+(define (add-to-parent! ctx)
+ (let ((parent (ctx-parent ctx)))
+ (set-children! parent
+ (append (ctx-children parent) (list ctx)))
+ ctx))
+
+(define (make-compilation-unit-context ctx offset-size addr-size
+ abbrevs start len)
+ (unless (= addr-size (ctx-addr-size ctx))
+ (error "ELF word size not equal to compilation unit addrsize"))
+ (add-to-parent!
+ (make-dwarf-context (ctx-bv ctx)
+ offset-size (ctx-endianness ctx)
+ (ctx-meta ctx)
+ abbrevs ctx #f start (+ start 4 len) '())))
+
+(define (make-child-context die)
+ (let ((ctx (die-ctx die)))
+ (add-to-parent!
+ (make-dwarf-context (ctx-bv ctx)
+ (ctx-offset-size ctx) (ctx-endianness ctx)
+ (ctx-meta ctx)
+ (ctx-abbrevs ctx)
+ ctx die
+ (die-next-offset die)
+ (die-sibling ctx (die-abbrev die) (die-offset die))
+ '()))))
+
+(define (ctx-language ctx)
+ (or (and=> (ctx-die ctx) (lambda (x) (die-ref x 'language)))
+ (and=> (ctx-parent ctx) ctx-language)))
+
+(define (populate-context-tree! die)
+ (define (skip? ctx offset abbrev)
+ (case (abbrev-tag abbrev)
+ ((class-type structure-type namespace) #f)
+ (else #t)))
+ (case (die-tag die)
+ ((compile-unit class-type structure-type namespace)
+ (let ((ctx (make-child-context die)))
+ ;; For C++, descend into classes and structures so that we
+ ;; populate the context tree. Note that for compile-unit, we
+ ;; still need to call `make-child-context' for its side effect of
+ ;; adding to the context tree.
+ (when (eq? (ctx-language ctx) 'c++)
+ (fold-die-children die
+ (lambda (die seed) (populate-context-tree! die))
+ #f
+ #:skip? skip?))))))
+
+(define (read-compilation-unit ctx pos)
+ (let*-values (((start) pos)
+ ((len pos offset-size) (read-initial-length ctx pos))
+ ((version pos) (read-u16 ctx pos))
+ ((abbrevs-offset pos) (read-offset ctx pos offset-size))
+ ((av) (read-abbrevs ctx abbrevs-offset))
+ ((addrsize pos) (read-u8 ctx pos))
+ ((ctx) (make-compilation-unit-context ctx offset-size addrsize
+ av start len))
+ ((die pos) (read-die ctx pos)))
+ (populate-context-tree! die)
+ (values die (ctx-end ctx))))
+
+(define (read-die-roots ctx)
+ (let lp ((dies '()) (pos (meta-info-start (ctx-meta ctx))))
+ (if (< pos (meta-info-end (ctx-meta ctx)))
+ (let-values (((die pos) (read-compilation-unit ctx pos)))
+ (if die
+ (lp (cons die dies) pos)
+ (reverse dies)))
+ (reverse dies))))
+
+(define (fold-pubname-set ctx pos folder seed)
+ (let*-values (((len pos offset-size) (read-initial-length ctx pos))
+ ((version pos) (read-u16 ctx pos))
+ ((info-offset pos) (read-offset ctx pos offset-size))
+ ((info-offset) (+ info-offset
+ (meta-info-start (ctx-meta ctx))))
+ ((info-len pos) (read-offset ctx pos offset-size)))
+ (let lp ((pos pos) (seed seed))
+ (let-values (((offset pos) (read-offset ctx pos offset-size)))
+ (if (zero? offset)
+ (values seed pos)
+ (let-values (((str pos) (read-string ctx pos)))
+ (lp pos
+ (folder str (+ offset info-offset) seed))))))))
+
+(define (fold-pubnames ctx folder seed)
+ (let ((end (meta-pubnames-end (ctx-meta ctx))))
+ (if end
+ (let lp ((pos (meta-pubnames-start (ctx-meta ctx))) (seed seed))
+ (if (< pos end)
+ (let-values (((seed pos) (fold-pubname-set ctx pos folder seed)))
+ (lp pos seed))
+ seed))
+ seed)))
+
+(define (align address alignment)
+ (+ address
+ (modulo (- alignment (modulo address alignment)) alignment)))
+
+(define (fold-arange-set ctx pos folder seed)
+ (let*-values (((len pos offset-size) (read-initial-length ctx pos))
+ ((version pos) (read-u16 ctx pos))
+ ((info-offset pos) (read-offset ctx pos offset-size))
+ ((info-offset) (+ info-offset
+ (meta-info-start (ctx-meta ctx))))
+ ((addr-size pos) (read-u8 ctx pos))
+ ((segment-size pos) (read-u8 ctx pos)))
+ (let lp ((pos (align pos (* 2 (ctx-addr-size ctx)))) (seed seed))
+ (let*-values (((addr pos) (read-addr ctx pos))
+ ((len pos) (read-addr ctx pos)))
+ (if (and (zero? addr) (zero? len))
+ (values seed pos)
+ (lp pos
+ (folder info-offset addr len seed)))))))
+
+(define (fold-aranges ctx folder seed)
+ (let ((end (meta-aranges-end (ctx-meta ctx))))
+ (if end
+ (let lp ((pos (meta-aranges-start (ctx-meta ctx))) (seed seed))
+ (if (< pos end)
+ (let-values (((seed pos) (fold-arange-set ctx pos folder seed)))
+ (lp pos seed))
+ seed))
+ seed)))
+
+(define* (elf->dwarf-context elf #:key (vaddr 0) (memsz 0)
+ (path #f) (lib-path path))
+ (let* ((sections (elf-sections-by-name elf))
+ (info (assoc-ref sections ".debug_info"))
+ (abbrevs (assoc-ref sections ".debug_abbrev"))
+ (strtab (assoc-ref sections ".debug_str"))
+ (loc (assoc-ref sections ".debug_loc"))
+ (line (assoc-ref sections ".debug_line"))
+ (pubnames (assoc-ref sections ".debug_pubnames"))
+ (aranges (assoc-ref sections ".debug_aranges")))
+ (make-dwarf-context (elf-bytes elf)
+ 4 ;; initial offset size
+ (elf-byte-order elf)
+ (make-dwarf-meta
+ (elf-word-size elf)
+ vaddr memsz
+ path lib-path
+ (elf-section-offset info)
+ (+ (elf-section-offset info)
+ (elf-section-size info))
+ (elf-section-offset abbrevs)
+ (+ (elf-section-offset abbrevs)
+ (elf-section-size abbrevs))
+ (elf-section-offset strtab)
+ (+ (elf-section-offset strtab)
+ (elf-section-size strtab))
+ (elf-section-offset loc)
+ (+ (elf-section-offset loc)
+ (elf-section-size loc))
+ (and line
+ (elf-section-offset line))
+ (and line
+ (+ (elf-section-offset line)
+ (elf-section-size line)))
+ (and pubnames
+ (elf-section-offset pubnames))
+ (and pubnames
+ (+ (elf-section-offset pubnames)
+ (elf-section-size pubnames)))
+ (and aranges
+ (elf-section-offset aranges))
+ (and aranges
+ (+ (elf-section-offset aranges)
+ (elf-section-size aranges))))
+ #() #f #f
+ (elf-section-offset info)
+ (+ (elf-section-offset info)
+ (elf-section-size info))
+ '())))
+
+(define (die->tree die)
+ (cons* (die-tag die)
+ (cons 'offset (die-offset die))
+ (reverse! (fold-die-children
+ die
+ (lambda (die seed)
+ (cons (die->tree die) seed))
+ (fold acons '() (die-attrs die) (die-vals die))))))
--- /dev/null
+;;; Guile ELF reader and writer
+
+;; Copyright (C) 2011, 2012, 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; A module to read and write Executable and Linking Format (ELF)
+;;; files.
+;;;
+;;; This module exports a number of record types that represent the
+;;; various parts that make up ELF files. Fundamentally this is the
+;;; main header, the segment headers (program headers), and the section
+;;; headers. It also exports bindings for symbolic constants and
+;;; utilities to parse and write special kinds of ELF sections.
+;;;
+;;; See elf(5) for more information on ELF.
+;;;
+;;; Code:
+
+(define-module (system vm elf)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system foreign)
+ #:use-module (system base target)
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 vlist)
+ #:export (has-elf-header?
+
+ (make-elf* . make-elf)
+ elf?
+ elf-bytes elf-word-size elf-byte-order
+ elf-abi elf-type elf-machine-type
+ elf-entry elf-phoff elf-shoff elf-flags elf-ehsize
+ elf-phentsize elf-phnum elf-shentsize elf-shnum elf-shstrndx
+
+ ELFOSABI_NONE ELFOSABI_HPUX ELFOSABI_NETBSD ELFOSABI_GNU
+ ELFOSABI_SOLARIS ELFOSABI_AIX ELFOSABI_IRIX ELFOSABI_FREEBSD
+ ELFOSABI_TRU64 ELFOSABI_MODESTO ELFOSABI_OPENBSD
+ ELFOSABI_ARM_AEABI ELFOSABI_ARM ELFOSABI_STANDALONE
+
+ ET_NONE ET_REL ET_EXEC ET_DYN ET_CORE
+
+ EM_NONE EM_SPARC EM_386 EM_MIPS EM_PPC EM_PPC64 EM_ARM EM_SH
+ EM_SPARCV9 EM_IA_64 EM_X86_64
+
+ elf-header-len elf-header-shoff-offset
+ write-elf-header
+
+ (make-elf-segment* . make-elf-segment)
+ elf-segment?
+ elf-segment-index
+ elf-segment-type elf-segment-offset elf-segment-vaddr
+ elf-segment-paddr elf-segment-filesz elf-segment-memsz
+ elf-segment-flags elf-segment-align
+
+ elf-program-header-len write-elf-program-header
+
+ PT_NULL PT_LOAD PT_DYNAMIC PT_INTERP PT_NOTE PT_SHLIB
+ PT_PHDR PT_TLS PT_NUM PT_LOOS PT_GNU_EH_FRAME PT_GNU_STACK
+ PT_GNU_RELRO
+
+ PF_R PF_W PF_X
+
+ (make-elf-section* . make-elf-section)
+ elf-section?
+ elf-section-index
+ elf-section-name elf-section-type elf-section-flags
+ elf-section-addr elf-section-offset elf-section-size
+ elf-section-link elf-section-info elf-section-addralign
+ elf-section-entsize
+
+ elf-section-header-len elf-section-header-addr-offset
+ elf-section-header-offset-offset
+ write-elf-section-header
+
+ (make-elf-symbol* . make-elf-symbol)
+ elf-symbol?
+ elf-symbol-name elf-symbol-value elf-symbol-size
+ elf-symbol-info elf-symbol-other elf-symbol-shndx
+ elf-symbol-binding elf-symbol-type elf-symbol-visibility
+
+ elf-symbol-len elf-symbol-value-offset write-elf-symbol
+
+ SHN_UNDEF
+
+ SHT_NULL SHT_PROGBITS SHT_SYMTAB SHT_STRTAB SHT_RELA
+ SHT_HASH SHT_DYNAMIC SHT_NOTE SHT_NOBITS SHT_REL SHT_SHLIB
+ SHT_DYNSYM SHT_INIT_ARRAY SHT_FINI_ARRAY SHT_PREINIT_ARRAY
+ SHT_GROUP SHT_SYMTAB_SHNDX SHT_NUM SHT_LOOS SHT_HIOS
+ SHT_LOPROC SHT_HIPROC SHT_LOUSER SHT_HIUSER
+
+ SHF_WRITE SHF_ALLOC SHF_EXECINSTR SHF_MERGE SHF_STRINGS
+ SHF_INFO_LINK SHF_LINK_ORDER SHF_OS_NONCONFORMING SHF_GROUP
+ SHF_TLS
+
+ DT_NULL DT_NEEDED DT_PLTRELSZ DT_PLTGOT DT_HASH DT_STRTAB
+ DT_SYMTAB DT_RELA DT_RELASZ DT_RELAENT DT_STRSZ DT_SYMENT
+ DT_INIT DT_FINI DT_SONAME DT_RPATH DT_SYMBOLIC DT_REL
+ DT_RELSZ DT_RELENT DT_PLTREL DT_DEBUG DT_TEXTREL DT_JMPREL
+ DT_BIND_NOW DT_INIT_ARRAY DT_FINI_ARRAY DT_INIT_ARRAYSZ
+ DT_FINI_ARRAYSZ DT_RUNPATH DT_FLAGS DT_ENCODING
+ DT_PREINIT_ARRAY DT_PREINIT_ARRAYSZ DT_NUM DT_LOGUILE
+ DT_GUILE_GC_ROOT DT_GUILE_GC_ROOT_SZ DT_GUILE_ENTRY
+ DT_GUILE_VM_VERSION DT_GUILE_FRAME_MAPS DT_HIGUILE
+ DT_LOOS DT_HIOS DT_LOPROC DT_HIPROC
+
+ string-table-ref
+
+ STB_LOCAL STB_GLOBAL STB_WEAK STB_NUM STB_LOOS STB_GNU
+ STB_HIOS STB_LOPROC STB_HIPROC
+
+ STT_NOTYPE STT_OBJECT STT_FUNC STT_SECTION STT_FILE
+ STT_COMMON STT_TLS STT_NUM STT_LOOS STT_GNU STT_HIOS
+ STT_LOPROC STT_HIPROC
+
+ STV_DEFAULT STV_INTERNAL STV_HIDDEN STV_PROTECTED
+
+ NT_GNU_ABI_TAG NT_GNU_HWCAP NT_GNU_BUILD_ID NT_GNU_GOLD_VERSION
+
+ parse-elf
+ elf-segment elf-segments
+ elf-section elf-sections elf-section-by-name elf-sections-by-name
+ elf-symbol-table-len elf-symbol-table-ref
+
+ parse-elf-note
+ elf-note-name elf-note-desc elf-note-type))
+
+;; #define EI_NIDENT 16
+
+;; typedef struct {
+;; unsigned char e_ident[EI_NIDENT];
+;; uint16_t e_type;
+;; uint16_t e_machine;
+;; uint32_t e_version;
+;; ElfN_Addr e_entry;
+;; ElfN_Off e_phoff;
+;; ElfN_Off e_shoff;
+;; uint32_t e_flags;
+;; uint16_t e_ehsize;
+;; uint16_t e_phentsize;
+;; uint16_t e_phnum;
+;; uint16_t e_shentsize;
+;; uint16_t e_shnum;
+;; uint16_t e_shstrndx;
+;; } ElfN_Ehdr;
+
+(define elf32-header-len 52)
+(define elf64-header-len 64)
+(define (elf-header-len word-size)
+ (case word-size
+ ((4) elf32-header-len)
+ ((8) elf64-header-len)
+ (else (error "invalid word size" word-size))))
+(define (elf-header-shoff-offset word-size)
+ (case word-size
+ ((4) 32)
+ ((8) 40)
+ (else (error "bad word size" word-size))))
+
+(define ELFCLASS32 1) ; 32-bit objects
+(define ELFCLASS64 2) ; 64-bit objects
+
+(define ELFDATA2LSB 1) ; 2's complement, little endian
+(define ELFDATA2MSB 2) ; 2's complement, big endian
+
+(define EV_CURRENT 1) ; Current version
+
+(define ELFOSABI_NONE 0) ; UNIX System V ABI */
+(define ELFOSABI_HPUX 1) ; HP-UX
+(define ELFOSABI_NETBSD 2) ; NetBSD.
+(define ELFOSABI_GNU 3) ; Object uses GNU ELF extensions.
+(define ELFOSABI_SOLARIS 6) ; Sun Solaris.
+(define ELFOSABI_AIX 7) ; IBM AIX.
+(define ELFOSABI_IRIX 8) ; SGI Irix.
+(define ELFOSABI_FREEBSD 9) ; FreeBSD.
+(define ELFOSABI_TRU64 10) ; Compaq TRU64 UNIX.
+(define ELFOSABI_MODESTO 11) ; Novell Modesto.
+(define ELFOSABI_OPENBSD 12) ; OpenBSD.
+(define ELFOSABI_ARM_AEABI 64) ; ARM EABI
+(define ELFOSABI_ARM 97) ; ARM
+(define ELFOSABI_STANDALONE 255) ; Standalone (embedded) application
+
+(define ET_NONE 0) ; No file type
+(define ET_REL 1) ; Relocatable file
+(define ET_EXEC 2) ; Executable file
+(define ET_DYN 3) ; Shared object file
+(define ET_CORE 4) ; Core file
+
+;;
+;; Machine types
+;;
+;; Just a sampling of these values. We could include more, but the
+;; important thing is to recognize architectures for which we have a
+;; native compiler. Recognizing more common machine types is icing on
+;; the cake.
+;;
+(define EM_NONE 0) ; No machine
+(define EM_SPARC 2) ; SUN SPARC
+(define EM_386 3) ; Intel 80386
+(define EM_MIPS 8) ; MIPS R3000 big-endian
+(define EM_PPC 20) ; PowerPC
+(define EM_PPC64 21) ; PowerPC 64-bit
+(define EM_ARM 40) ; ARM
+(define EM_SH 42) ; Hitachi SH
+(define EM_SPARCV9 43) ; SPARC v9 64-bit
+(define EM_IA_64 50) ; Intel Merced
+(define EM_X86_64 62) ; AMD x86-64 architecture
+
+(define cpu-mapping (make-hash-table))
+(for-each (lambda (pair)
+ (hashq-set! cpu-mapping (car pair) (cdr pair)))
+ `((none . ,EM_NONE)
+ (sparc . ,EM_SPARC) ; FIXME: map 64-bit to SPARCV9 ?
+ (i386 . ,EM_386)
+ (mips . ,EM_MIPS)
+ (ppc . ,EM_PPC)
+ (ppc64 . ,EM_PPC64)
+ (arm . ,EM_ARM) ; FIXME: there are more arm cpu variants
+ (sh . ,EM_SH) ; FIXME: there are more sh cpu variants
+ (ia64 . ,EM_IA_64)
+ (x86_64 . ,EM_X86_64)))
+
+(define SHN_UNDEF 0)
+
+(define host-machine-type
+ (hashq-ref cpu-mapping
+ (string->symbol (car (string-split %host-type #\-)))
+ EM_NONE))
+
+(define host-word-size
+ (sizeof '*))
+
+(define host-byte-order
+ (native-endianness))
+
+(define (has-elf-header? bv)
+ (and
+ ;; e_ident
+ (>= (bytevector-length bv) 16)
+ (= (bytevector-u8-ref bv 0) #x7f)
+ (= (bytevector-u8-ref bv 1) (char->integer #\E))
+ (= (bytevector-u8-ref bv 2) (char->integer #\L))
+ (= (bytevector-u8-ref bv 3) (char->integer #\F))
+ (cond
+ ((= (bytevector-u8-ref bv 4) ELFCLASS32)
+ (>= (bytevector-length bv) elf32-header-len))
+ ((= (bytevector-u8-ref bv 4) ELFCLASS64)
+ (>= (bytevector-length bv) elf64-header-len))
+ (else #f))
+ (or (= (bytevector-u8-ref bv 5) ELFDATA2LSB)
+ (= (bytevector-u8-ref bv 5) ELFDATA2MSB))
+ (= (bytevector-u8-ref bv 6) EV_CURRENT)
+ ;; Look at ABI later.
+ (= (bytevector-u8-ref bv 8) 0) ; ABI version
+ ;; The rest of the e_ident is padding.
+
+ ;; e_version
+ (let ((byte-order (if (= (bytevector-u8-ref bv 5) ELFDATA2LSB)
+ (endianness little)
+ (endianness big))))
+ (= (bytevector-u32-ref bv 20 byte-order) EV_CURRENT))))
+
+(define-record-type <elf>
+ (make-elf bytes word-size byte-order abi type machine-type
+ entry phoff shoff flags ehsize
+ phentsize phnum shentsize shnum shstrndx)
+ elf?
+ (bytes elf-bytes)
+ (word-size elf-word-size)
+ (byte-order elf-byte-order)
+ (abi elf-abi)
+ (type elf-type)
+ (machine-type elf-machine-type)
+ (entry elf-entry)
+ (phoff elf-phoff)
+ (shoff elf-shoff)
+ (flags elf-flags)
+ (ehsize elf-ehsize)
+ (phentsize elf-phentsize)
+ (phnum elf-phnum)
+ (shentsize elf-shentsize)
+ (shnum elf-shnum)
+ (shstrndx elf-shstrndx))
+
+(define* (make-elf* #:key (bytes #f)
+ (byte-order (target-endianness))
+ (word-size (target-word-size))
+ (abi ELFOSABI_STANDALONE)
+ (type ET_DYN)
+ (machine-type EM_NONE)
+ (entry 0)
+ (phoff (elf-header-len word-size))
+ (shoff -1)
+ (flags 0)
+ (ehsize (elf-header-len word-size))
+ (phentsize (elf-program-header-len word-size))
+ (phnum 0)
+ (shentsize (elf-section-header-len word-size))
+ (shnum 0)
+ (shstrndx SHN_UNDEF))
+ (make-elf bytes word-size byte-order abi type machine-type
+ entry phoff shoff flags ehsize
+ phentsize phnum shentsize shnum shstrndx))
+
+(define (parse-elf32 bv byte-order)
+ (make-elf bv 4 byte-order
+ (bytevector-u8-ref bv 7)
+ (bytevector-u16-ref bv 16 byte-order)
+ (bytevector-u16-ref bv 18 byte-order)
+ (bytevector-u32-ref bv 24 byte-order)
+ (bytevector-u32-ref bv 28 byte-order)
+ (bytevector-u32-ref bv 32 byte-order)
+ (bytevector-u32-ref bv 36 byte-order)
+ (bytevector-u16-ref bv 40 byte-order)
+ (bytevector-u16-ref bv 42 byte-order)
+ (bytevector-u16-ref bv 44 byte-order)
+ (bytevector-u16-ref bv 46 byte-order)
+ (bytevector-u16-ref bv 48 byte-order)
+ (bytevector-u16-ref bv 50 byte-order)))
+
+(define (write-elf-ident bv class data abi)
+ (bytevector-u8-set! bv 0 #x7f)
+ (bytevector-u8-set! bv 1 (char->integer #\E))
+ (bytevector-u8-set! bv 2 (char->integer #\L))
+ (bytevector-u8-set! bv 3 (char->integer #\F))
+ (bytevector-u8-set! bv 4 class)
+ (bytevector-u8-set! bv 5 data)
+ (bytevector-u8-set! bv 6 EV_CURRENT)
+ (bytevector-u8-set! bv 7 abi)
+ (bytevector-u8-set! bv 8 0) ; ABI version
+ (bytevector-u8-set! bv 9 0) ; Pad to 16 bytes.
+ (bytevector-u8-set! bv 10 0)
+ (bytevector-u8-set! bv 11 0)
+ (bytevector-u8-set! bv 12 0)
+ (bytevector-u8-set! bv 13 0)
+ (bytevector-u8-set! bv 14 0)
+ (bytevector-u8-set! bv 15 0))
+
+(define (write-elf32-header bv elf)
+ (let ((byte-order (elf-byte-order elf)))
+ (write-elf-ident bv ELFCLASS32
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ (elf-abi elf))
+ (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
+ (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u32-set! bv 24 (elf-entry elf) byte-order)
+ (bytevector-u32-set! bv 28 (elf-phoff elf) byte-order)
+ (bytevector-u32-set! bv 32 (elf-shoff elf) byte-order)
+ (bytevector-u32-set! bv 36 (elf-flags elf) byte-order)
+ (bytevector-u16-set! bv 40 (elf-ehsize elf) byte-order)
+ (bytevector-u16-set! bv 42 (elf-phentsize elf) byte-order)
+ (bytevector-u16-set! bv 44 (elf-phnum elf) byte-order)
+ (bytevector-u16-set! bv 46 (elf-shentsize elf) byte-order)
+ (bytevector-u16-set! bv 48 (elf-shnum elf) byte-order)
+ (bytevector-u16-set! bv 50 (elf-shstrndx elf) byte-order)))
+
+(define (parse-elf64 bv byte-order)
+ (make-elf bv 8 byte-order
+ (bytevector-u8-ref bv 7)
+ (bytevector-u16-ref bv 16 byte-order)
+ (bytevector-u16-ref bv 18 byte-order)
+ (bytevector-u64-ref bv 24 byte-order)
+ (bytevector-u64-ref bv 32 byte-order)
+ (bytevector-u64-ref bv 40 byte-order)
+ (bytevector-u32-ref bv 48 byte-order)
+ (bytevector-u16-ref bv 52 byte-order)
+ (bytevector-u16-ref bv 54 byte-order)
+ (bytevector-u16-ref bv 56 byte-order)
+ (bytevector-u16-ref bv 58 byte-order)
+ (bytevector-u16-ref bv 60 byte-order)
+ (bytevector-u16-ref bv 62 byte-order)))
+
+(define (write-elf64-header bv elf)
+ (let ((byte-order (elf-byte-order elf)))
+ (write-elf-ident bv ELFCLASS64
+ (case byte-order
+ ((little) ELFDATA2LSB)
+ ((big) ELFDATA2MSB)
+ (else (error "unknown endianness" byte-order)))
+ (elf-abi elf))
+ (bytevector-u16-set! bv 16 (elf-type elf) byte-order)
+ (bytevector-u16-set! bv 18 (elf-machine-type elf) byte-order)
+ (bytevector-u32-set! bv 20 EV_CURRENT byte-order)
+ (bytevector-u64-set! bv 24 (elf-entry elf) byte-order)
+ (bytevector-u64-set! bv 32 (elf-phoff elf) byte-order)
+ (bytevector-u64-set! bv 40 (elf-shoff elf) byte-order)
+ (bytevector-u32-set! bv 48 (elf-flags elf) byte-order)
+ (bytevector-u16-set! bv 52 (elf-ehsize elf) byte-order)
+ (bytevector-u16-set! bv 54 (elf-phentsize elf) byte-order)
+ (bytevector-u16-set! bv 56 (elf-phnum elf) byte-order)
+ (bytevector-u16-set! bv 58 (elf-shentsize elf) byte-order)
+ (bytevector-u16-set! bv 60 (elf-shnum elf) byte-order)
+ (bytevector-u16-set! bv 62 (elf-shstrndx elf) byte-order)))
+
+(define (parse-elf bv)
+ (cond
+ ((has-elf-header? bv)
+ (let ((class (bytevector-u8-ref bv 4))
+ (byte-order (let ((data (bytevector-u8-ref bv 5)))
+ (cond
+ ((= data ELFDATA2LSB) (endianness little))
+ ((= data ELFDATA2MSB) (endianness big))
+ (else (error "unhandled byte order" data))))))
+ (cond
+ ((= class ELFCLASS32) (parse-elf32 bv byte-order))
+ ((= class ELFCLASS64) (parse-elf64 bv byte-order))
+ (else (error "unhandled class" class)))))
+ (else
+ (error "Invalid ELF" bv))))
+
+(define* (write-elf-header bv elf)
+ ((case (elf-word-size elf)
+ ((4) write-elf32-header)
+ ((8) write-elf64-header)
+ (else (error "unknown word size" (elf-word-size elf))))
+ bv elf))
+
+;;
+;; Segment types
+;;
+(define PT_NULL 0) ; Program header table entry unused
+(define PT_LOAD 1) ; Loadable program segment
+(define PT_DYNAMIC 2) ; Dynamic linking information
+(define PT_INTERP 3) ; Program interpreter
+(define PT_NOTE 4) ; Auxiliary information
+(define PT_SHLIB 5) ; Reserved
+(define PT_PHDR 6) ; Entry for header table itself
+(define PT_TLS 7) ; Thread-local storage segment
+(define PT_NUM 8) ; Number of defined types
+(define PT_LOOS #x60000000) ; Start of OS-specific
+(define PT_GNU_EH_FRAME #x6474e550) ; GCC .eh_frame_hdr segment
+(define PT_GNU_STACK #x6474e551) ; Indicates stack executability
+(define PT_GNU_RELRO #x6474e552) ; Read-only after relocation
+
+;;
+;; Segment flags
+;;
+(define PF_X (ash 1 0)) ; Segment is executable
+(define PF_W (ash 1 1)) ; Segment is writable
+(define PF_R (ash 1 2)) ; Segment is readable
+
+(define-record-type <elf-segment>
+ (make-elf-segment index type offset vaddr paddr filesz memsz flags align)
+ elf-segment?
+ (index elf-segment-index)
+ (type elf-segment-type)
+ (offset elf-segment-offset)
+ (vaddr elf-segment-vaddr)
+ (paddr elf-segment-paddr)
+ (filesz elf-segment-filesz)
+ (memsz elf-segment-memsz)
+ (flags elf-segment-flags)
+ (align elf-segment-align))
+
+(define* (make-elf-segment* #:key (index -1) (type PT_LOAD) (offset 0) (vaddr 0)
+ (paddr 0) (filesz 0) (memsz filesz)
+ (flags (logior PF_W PF_R))
+ (align 8))
+ (make-elf-segment index type offset vaddr paddr filesz memsz flags align))
+
+;; typedef struct {
+;; uint32_t p_type;
+;; Elf32_Off p_offset;
+;; Elf32_Addr p_vaddr;
+;; Elf32_Addr p_paddr;
+;; uint32_t p_filesz;
+;; uint32_t p_memsz;
+;; uint32_t p_flags;
+;; uint32_t p_align;
+;; } Elf32_Phdr;
+
+(define (parse-elf32-program-header index bv offset byte-order)
+ (if (<= (+ offset 32) (bytevector-length bv))
+ (make-elf-segment index
+ (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u32-ref bv (+ offset 8) byte-order)
+ (bytevector-u32-ref bv (+ offset 12) byte-order)
+ (bytevector-u32-ref bv (+ offset 16) byte-order)
+ (bytevector-u32-ref bv (+ offset 20) byte-order)
+ (bytevector-u32-ref bv (+ offset 24) byte-order)
+ (bytevector-u32-ref bv (+ offset 28) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf32-program-header bv offset byte-order seg)
+ (bytevector-u32-set! bv offset (elf-segment-type seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-segment-offset seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 8) (elf-segment-vaddr seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 12) (elf-segment-paddr seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 16) (elf-segment-filesz seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 20) (elf-segment-memsz seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 24) (elf-segment-flags seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 28) (elf-segment-align seg) byte-order))
+
+
+;; typedef struct {
+;; uint32_t p_type;
+;; uint32_t p_flags;
+;; Elf64_Off p_offset;
+;; Elf64_Addr p_vaddr;
+;; Elf64_Addr p_paddr;
+;; uint64_t p_filesz;
+;; uint64_t p_memsz;
+;; uint64_t p_align;
+;; } Elf64_Phdr;
+
+;; NB: position of `flags' is different!
+
+(define (parse-elf64-program-header index bv offset byte-order)
+ (if (<= (+ offset 56) (bytevector-length bv))
+ (make-elf-segment index
+ (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u64-ref bv (+ offset 8) byte-order)
+ (bytevector-u64-ref bv (+ offset 16) byte-order)
+ (bytevector-u64-ref bv (+ offset 24) byte-order)
+ (bytevector-u64-ref bv (+ offset 32) byte-order)
+ (bytevector-u64-ref bv (+ offset 40) byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u64-ref bv (+ offset 48) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf64-program-header bv offset byte-order seg)
+ (bytevector-u32-set! bv offset (elf-segment-type seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 8) (elf-segment-offset seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 16) (elf-segment-vaddr seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 24) (elf-segment-paddr seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 32) (elf-segment-filesz seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 40) (elf-segment-memsz seg) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-segment-flags seg) byte-order)
+ (bytevector-u64-set! bv (+ offset 48) (elf-segment-align seg) byte-order))
+
+(define (write-elf-program-header bv offset byte-order word-size seg)
+ ((case word-size
+ ((4) write-elf32-program-header)
+ ((8) write-elf64-program-header)
+ (else (error "invalid word size" word-size)))
+ bv offset byte-order seg))
+
+(define (elf-program-header-len word-size)
+ (case word-size
+ ((4) 32)
+ ((8) 56)
+ (else (error "bad word size" word-size))))
+
+(define (elf-segment elf n)
+ (if (not (< -1 n (elf-phnum elf)))
+ (error "bad segment number" n))
+ ((case (elf-word-size elf)
+ ((4) parse-elf32-program-header)
+ ((8) parse-elf64-program-header)
+ (else (error "unhandled pointer size")))
+ (elf-bytes elf)
+ (+ (elf-phoff elf) (* n (elf-phentsize elf)))
+ (elf-byte-order elf)))
+
+(define (elf-segments elf)
+ (let lp ((n (elf-phnum elf)) (out '()))
+ (if (zero? n)
+ out
+ (lp (1- n) (cons (elf-segment elf (1- n)) out)))))
+
+(define-record-type <elf-section>
+ (make-elf-section index name type flags
+ addr offset size link info addralign entsize)
+ elf-section?
+ (index elf-section-index)
+ (name elf-section-name)
+ (type elf-section-type)
+ (flags elf-section-flags)
+ (addr elf-section-addr)
+ (offset elf-section-offset)
+ (size elf-section-size)
+ (link elf-section-link)
+ (info elf-section-info)
+ (addralign elf-section-addralign)
+ (entsize elf-section-entsize))
+
+(define* (make-elf-section* #:key (index SHN_UNDEF) (name 0) (type SHT_PROGBITS)
+ (flags SHF_ALLOC) (addr 0) (offset 0) (size 0)
+ (link 0) (info 0) (addralign 8) (entsize 0))
+ (make-elf-section index name type flags addr offset size link info addralign
+ entsize))
+
+;; typedef struct {
+;; uint32_t sh_name;
+;; uint32_t sh_type;
+;; uint32_t sh_flags;
+;; Elf32_Addr sh_addr;
+;; Elf32_Off sh_offset;
+;; uint32_t sh_size;
+;; uint32_t sh_link;
+;; uint32_t sh_info;
+;; uint32_t sh_addralign;
+;; uint32_t sh_entsize;
+;; } Elf32_Shdr;
+
+(define (parse-elf32-section-header index bv offset byte-order)
+ (if (<= (+ offset 40) (bytevector-length bv))
+ (make-elf-section index
+ (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u32-ref bv (+ offset 8) byte-order)
+ (bytevector-u32-ref bv (+ offset 12) byte-order)
+ (bytevector-u32-ref bv (+ offset 16) byte-order)
+ (bytevector-u32-ref bv (+ offset 20) byte-order)
+ (bytevector-u32-ref bv (+ offset 24) byte-order)
+ (bytevector-u32-ref bv (+ offset 28) byte-order)
+ (bytevector-u32-ref bv (+ offset 32) byte-order)
+ (bytevector-u32-ref bv (+ offset 36) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf32-section-header bv offset byte-order sec)
+ (bytevector-u32-set! bv offset (elf-section-name sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-section-type sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 8) (elf-section-flags sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 12) (elf-section-addr sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 16) (elf-section-offset sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 20) (elf-section-size sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 24) (elf-section-link sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 28) (elf-section-info sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 32) (elf-section-addralign sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 36) (elf-section-entsize sec) byte-order))
+
+
+;; typedef struct {
+;; uint32_t sh_name;
+;; uint32_t sh_type;
+;; uint64_t sh_flags;
+;; Elf64_Addr sh_addr;
+;; Elf64_Off sh_offset;
+;; uint64_t sh_size;
+;; uint32_t sh_link;
+;; uint32_t sh_info;
+;; uint64_t sh_addralign;
+;; uint64_t sh_entsize;
+;; } Elf64_Shdr;
+
+(define (elf-section-header-len word-size)
+ (case word-size
+ ((4) 40)
+ ((8) 64)
+ (else (error "bad word size" word-size))))
+
+(define (elf-section-header-addr-offset word-size)
+ (case word-size
+ ((4) 12)
+ ((8) 16)
+ (else (error "bad word size" word-size))))
+
+(define (elf-section-header-offset-offset word-size)
+ (case word-size
+ ((4) 16)
+ ((8) 24)
+ (else (error "bad word size" word-size))))
+
+(define (parse-elf64-section-header index bv offset byte-order)
+ (if (<= (+ offset 64) (bytevector-length bv))
+ (make-elf-section index
+ (bytevector-u32-ref bv offset byte-order)
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u64-ref bv (+ offset 8) byte-order)
+ (bytevector-u64-ref bv (+ offset 16) byte-order)
+ (bytevector-u64-ref bv (+ offset 24) byte-order)
+ (bytevector-u64-ref bv (+ offset 32) byte-order)
+ (bytevector-u32-ref bv (+ offset 40) byte-order)
+ (bytevector-u32-ref bv (+ offset 44) byte-order)
+ (bytevector-u64-ref bv (+ offset 48) byte-order)
+ (bytevector-u64-ref bv (+ offset 56) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf64-section-header bv offset byte-order sec)
+ (bytevector-u32-set! bv offset (elf-section-name sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-section-type sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 8) (elf-section-flags sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 16) (elf-section-addr sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 24) (elf-section-offset sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 32) (elf-section-size sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 40) (elf-section-link sec) byte-order)
+ (bytevector-u32-set! bv (+ offset 44) (elf-section-info sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 48) (elf-section-addralign sec) byte-order)
+ (bytevector-u64-set! bv (+ offset 56) (elf-section-entsize sec) byte-order))
+
+(define (elf-section elf n)
+ (if (not (< -1 n (elf-shnum elf)))
+ (error "bad section number" n))
+ ((case (elf-word-size elf)
+ ((4) parse-elf32-section-header)
+ ((8) parse-elf64-section-header)
+ (else (error "unhandled pointer size")))
+ n
+ (elf-bytes elf)
+ (+ (elf-shoff elf) (* n (elf-shentsize elf)))
+ (elf-byte-order elf)))
+
+(define (write-elf-section-header bv offset byte-order word-size sec)
+ ((case word-size
+ ((4) write-elf32-section-header)
+ ((8) write-elf64-section-header)
+ (else (error "invalid word size" word-size)))
+ bv offset byte-order sec))
+
+(define (elf-sections elf)
+ (let lp ((n (elf-shnum elf)) (out '()))
+ (if (zero? n)
+ out
+ (lp (1- n) (cons (elf-section elf (1- n)) out)))))
+
+;;
+;; Section Types
+;;
+(define SHT_NULL 0) ; Section header table entry unused
+(define SHT_PROGBITS 1) ; Program data
+(define SHT_SYMTAB 2) ; Symbol table
+(define SHT_STRTAB 3) ; String table
+(define SHT_RELA 4) ; Relocation entries with addends
+(define SHT_HASH 5) ; Symbol hash table
+(define SHT_DYNAMIC 6) ; Dynamic linking information
+(define SHT_NOTE 7) ; Notes
+(define SHT_NOBITS 8) ; Program space with no data (bss)
+(define SHT_REL 9) ; Relocation entries, no addends
+(define SHT_SHLIB 10) ; Reserved
+(define SHT_DYNSYM 11) ; Dynamic linker symbol table
+(define SHT_INIT_ARRAY 14) ; Array of constructors
+(define SHT_FINI_ARRAY 15) ; Array of destructors
+(define SHT_PREINIT_ARRAY 16) ; Array of pre-constructors
+(define SHT_GROUP 17) ; Section group
+(define SHT_SYMTAB_SHNDX 18) ; Extended section indeces
+(define SHT_NUM 19) ; Number of defined types.
+(define SHT_LOOS #x60000000) ; Start OS-specific.
+(define SHT_HIOS #x6fffffff) ; End OS-specific type
+(define SHT_LOPROC #x70000000) ; Start of processor-specific
+(define SHT_HIPROC #x7fffffff) ; End of processor-specific
+(define SHT_LOUSER #x80000000) ; Start of application-specific
+(define SHT_HIUSER #x8fffffff) ; End of application-specific
+
+;;
+;; Section Flags
+;;
+(define SHF_WRITE (ash 1 0)) ; Writable
+(define SHF_ALLOC (ash 1 1)) ; Occupies memory during execution
+(define SHF_EXECINSTR (ash 1 2)) ; Executable
+(define SHF_MERGE (ash 1 4)) ; Might be merged
+(define SHF_STRINGS (ash 1 5)) ; Contains nul-terminated strings
+(define SHF_INFO_LINK (ash 1 6)) ; `sh_info' contains SHT index
+(define SHF_LINK_ORDER (ash 1 7)) ; Preserve order after combining
+(define SHF_OS_NONCONFORMING (ash 1 8)) ; Non-standard OS specific handling required
+(define SHF_GROUP (ash 1 9)) ; Section is member of a group.
+(define SHF_TLS (ash 1 10)) ; Section hold thread-local data.
+
+;;
+;; Dynamic entry types. The DT_GUILE types are non-standard.
+;;
+(define DT_NULL 0) ; Marks end of dynamic section
+(define DT_NEEDED 1) ; Name of needed library
+(define DT_PLTRELSZ 2) ; Size in bytes of PLT relocs
+(define DT_PLTGOT 3) ; Processor defined value
+(define DT_HASH 4) ; Address of symbol hash table
+(define DT_STRTAB 5) ; Address of string table
+(define DT_SYMTAB 6) ; Address of symbol table
+(define DT_RELA 7) ; Address of Rela relocs
+(define DT_RELASZ 8) ; Total size of Rela relocs
+(define DT_RELAENT 9) ; Size of one Rela reloc
+(define DT_STRSZ 10) ; Size of string table
+(define DT_SYMENT 11) ; Size of one symbol table entry
+(define DT_INIT 12) ; Address of init function
+(define DT_FINI 13) ; Address of termination function
+(define DT_SONAME 14) ; Name of shared object
+(define DT_RPATH 15) ; Library search path (deprecated)
+(define DT_SYMBOLIC 16) ; Start symbol search here
+(define DT_REL 17) ; Address of Rel relocs
+(define DT_RELSZ 18) ; Total size of Rel relocs
+(define DT_RELENT 19) ; Size of one Rel reloc
+(define DT_PLTREL 20) ; Type of reloc in PLT
+(define DT_DEBUG 21) ; For debugging ; unspecified
+(define DT_TEXTREL 22) ; Reloc might modify .text
+(define DT_JMPREL 23) ; Address of PLT relocs
+(define DT_BIND_NOW 24) ; Process relocations of object
+(define DT_INIT_ARRAY 25) ; Array with addresses of init fct
+(define DT_FINI_ARRAY 26) ; Array with addresses of fini fct
+(define DT_INIT_ARRAYSZ 27) ; Size in bytes of DT_INIT_ARRAY
+(define DT_FINI_ARRAYSZ 28) ; Size in bytes of DT_FINI_ARRAY
+(define DT_RUNPATH 29) ; Library search path
+(define DT_FLAGS 30) ; Flags for the object being loaded
+(define DT_ENCODING 32) ; Start of encoded range
+(define DT_PREINIT_ARRAY 32) ; Array with addresses of preinit fc
+(define DT_PREINIT_ARRAYSZ 33) ; size in bytes of DT_PREINIT_ARRAY
+(define DT_NUM 34) ; Number used
+(define DT_LOGUILE #x37146000) ; Start of Guile-specific
+(define DT_GUILE_GC_ROOT #x37146000) ; Offset of GC roots
+(define DT_GUILE_GC_ROOT_SZ #x37146001) ; Size in machine words of GC roots
+(define DT_GUILE_ENTRY #x37146002) ; Address of entry thunk
+(define DT_GUILE_VM_VERSION #x37146003) ; Bytecode version
+(define DT_GUILE_FRAME_MAPS #x37146004) ; Offset of .guile.frame-maps
+(define DT_HIGUILE #x37146fff) ; End of Guile-specific
+(define DT_LOOS #x6000000d) ; Start of OS-specific
+(define DT_HIOS #x6ffff000) ; End of OS-specific
+(define DT_LOPROC #x70000000) ; Start of processor-specific
+(define DT_HIPROC #x7fffffff) ; End of processor-specific
+
+
+(define (string-table-ref bv offset)
+ (let lp ((end offset))
+ (if (zero? (bytevector-u8-ref bv end))
+ (let ((out (make-bytevector (- end offset))))
+ (bytevector-copy! bv offset out 0 (- end offset))
+ (utf8->string out))
+ (lp (1+ end)))))
+
+(define (elf-section-by-name elf name)
+ (let ((off (elf-section-offset (elf-section elf (elf-shstrndx elf)))))
+ (let lp ((n (elf-shnum elf)))
+ (and (> n 0)
+ (let ((section (elf-section elf (1- n))))
+ (if (equal? (string-table-ref (elf-bytes elf)
+ (+ off (elf-section-name section)))
+ name)
+ section
+ (lp (1- n))))))))
+
+(define (elf-sections-by-name elf)
+ (let* ((sections (elf-sections elf))
+ (off (elf-section-offset (list-ref sections (elf-shstrndx elf)))))
+ (map (lambda (section)
+ (cons (string-table-ref (elf-bytes elf)
+ (+ off (elf-section-name section)))
+ section))
+ sections)))
+
+(define-record-type <elf-symbol>
+ (make-elf-symbol name value size info other shndx)
+ elf-symbol?
+ (name elf-symbol-name)
+ (value elf-symbol-value)
+ (size elf-symbol-size)
+ (info elf-symbol-info)
+ (other elf-symbol-other)
+ (shndx elf-symbol-shndx))
+
+(define* (make-elf-symbol* #:key (name 0) (value 0) (size 0)
+ (binding STB_LOCAL) (type STT_NOTYPE)
+ (info (logior (ash binding 4) type))
+ (visibility STV_DEFAULT) (other visibility)
+ (shndx SHN_UNDEF))
+ (make-elf-symbol name value size info other shndx))
+
+;; typedef struct {
+;; uint32_t st_name;
+;; Elf32_Addr st_value;
+;; uint32_t st_size;
+;; unsigned char st_info;
+;; unsigned char st_other;
+;; uint16_t st_shndx;
+;; } Elf32_Sym;
+
+(define (elf-symbol-len word-size)
+ (case word-size
+ ((4) 16)
+ ((8) 24)
+ (else (error "bad word size" word-size))))
+
+(define (elf-symbol-value-offset word-size)
+ (case word-size
+ ((4) 4)
+ ((8) 8)
+ (else (error "bad word size" word-size))))
+
+(define (parse-elf32-symbol bv offset stroff byte-order)
+ (if (<= (+ offset 16) (bytevector-length bv))
+ (make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
+ (if stroff
+ (string-table-ref bv (+ stroff name))
+ name))
+ (bytevector-u32-ref bv (+ offset 4) byte-order)
+ (bytevector-u32-ref bv (+ offset 8) byte-order)
+ (bytevector-u8-ref bv (+ offset 12))
+ (bytevector-u8-ref bv (+ offset 13))
+ (bytevector-u16-ref bv (+ offset 14) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf32-symbol bv offset byte-order sym)
+ (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
+ (bytevector-u32-set! bv (+ offset 4) (elf-symbol-value sym) byte-order)
+ (bytevector-u32-set! bv (+ offset 8) (elf-symbol-size sym) byte-order)
+ (bytevector-u8-set! bv (+ offset 12) (elf-symbol-info sym))
+ (bytevector-u8-set! bv (+ offset 13) (elf-symbol-other sym))
+ (bytevector-u16-set! bv (+ offset 14) (elf-symbol-shndx sym) byte-order))
+
+;; typedef struct {
+;; uint32_t st_name;
+;; unsigned char st_info;
+;; unsigned char st_other;
+;; uint16_t st_shndx;
+;; Elf64_Addr st_value;
+;; uint64_t st_size;
+;; } Elf64_Sym;
+
+(define (parse-elf64-symbol bv offset stroff byte-order)
+ (if (<= (+ offset 24) (bytevector-length bv))
+ (make-elf-symbol (let ((name (bytevector-u32-ref bv offset byte-order)))
+ (if stroff
+ (string-table-ref bv (+ stroff name))
+ name))
+ (bytevector-u64-ref bv (+ offset 8) byte-order)
+ (bytevector-u64-ref bv (+ offset 16) byte-order)
+ (bytevector-u8-ref bv (+ offset 4))
+ (bytevector-u8-ref bv (+ offset 5))
+ (bytevector-u16-ref bv (+ offset 6) byte-order))
+ (error "corrupt ELF (offset out of range)" offset)))
+
+(define (write-elf64-symbol bv offset byte-order sym)
+ (bytevector-u32-set! bv offset (elf-symbol-name sym) byte-order)
+ (bytevector-u8-set! bv (+ offset 4) (elf-symbol-info sym))
+ (bytevector-u8-set! bv (+ offset 5) (elf-symbol-other sym))
+ (bytevector-u16-set! bv (+ offset 6) (elf-symbol-shndx sym) byte-order)
+ (bytevector-u64-set! bv (+ offset 8) (elf-symbol-value sym) byte-order)
+ (bytevector-u64-set! bv (+ offset 16) (elf-symbol-size sym) byte-order))
+
+(define (write-elf-symbol bv offset byte-order word-size sym)
+ ((case word-size
+ ((4) write-elf32-symbol)
+ ((8) write-elf64-symbol)
+ (else (error "invalid word size" word-size)))
+ bv offset byte-order sym))
+
+(define (elf-symbol-table-len section)
+ (let ((len (elf-section-size section))
+ (entsize (elf-section-entsize section)))
+ (unless (and (not (zero? entsize)) (zero? (modulo len entsize)))
+ (error "bad symbol table" section))
+ (/ len entsize)))
+
+(define* (elf-symbol-table-ref elf section n #:optional strtab)
+ (let ((bv (elf-bytes elf))
+ (byte-order (elf-byte-order elf))
+ (stroff (and strtab (elf-section-offset strtab)))
+ (base (elf-section-offset section))
+ (len (elf-section-size section))
+ (entsize (elf-section-entsize section)))
+ (unless (<= (* (1+ n) entsize) len)
+ (error "out of range symbol table access" section n))
+ (case (elf-word-size elf)
+ ((4)
+ (unless (<= 16 entsize)
+ (error "bad entsize for symbol table" section))
+ (parse-elf32-symbol bv (+ base (* n entsize)) stroff byte-order))
+ ((8)
+ (unless (<= 24 entsize)
+ (error "bad entsize for symbol table" section))
+ (parse-elf64-symbol bv (+ base (* n entsize)) stroff byte-order))
+ (else (error "bad word size" elf)))))
+
+;; Legal values for ST_BIND subfield of st_info (symbol binding).
+
+(define STB_LOCAL 0) ; Local symbol
+(define STB_GLOBAL 1) ; Global symbol
+(define STB_WEAK 2) ; Weak symbol
+(define STB_NUM 3) ; Number of defined types.
+(define STB_LOOS 10) ; Start of OS-specific
+(define STB_GNU_UNIQUE 10) ; Unique symbol.
+(define STB_HIOS 12) ; End of OS-specific
+(define STB_LOPROC 13) ; Start of processor-specific
+(define STB_HIPROC 15) ; End of processor-specific
+
+;; Legal values for ST_TYPE subfield of st_info (symbol type).
+
+(define STT_NOTYPE 0) ; Symbol type is unspecified
+(define STT_OBJECT 1) ; Symbol is a data object
+(define STT_FUNC 2) ; Symbol is a code object
+(define STT_SECTION 3) ; Symbol associated with a section
+(define STT_FILE 4) ; Symbol's name is file name
+(define STT_COMMON 5) ; Symbol is a common data object
+(define STT_TLS 6) ; Symbol is thread-local data objec
+(define STT_NUM 7) ; Number of defined types.
+(define STT_LOOS 10) ; Start of OS-specific
+(define STT_GNU_IFUNC 10) ; Symbol is indirect code object
+(define STT_HIOS 12) ; End of OS-specific
+(define STT_LOPROC 13) ; Start of processor-specific
+(define STT_HIPROC 15) ; End of processor-specific
+
+;; Symbol visibility specification encoded in the st_other field.
+
+(define STV_DEFAULT 0) ; Default symbol visibility rules
+(define STV_INTERNAL 1) ; Processor specific hidden class
+(define STV_HIDDEN 2) ; Sym unavailable in other modules
+(define STV_PROTECTED 3) ; Not preemptible, not exported
+
+(define (elf-symbol-binding sym)
+ (ash (elf-symbol-info sym) -4))
+
+(define (elf-symbol-type sym)
+ (logand (elf-symbol-info sym) #xf))
+
+(define (elf-symbol-visibility sym)
+ (logand (elf-symbol-other sym) #x3))
+
+(define NT_GNU_ABI_TAG 1)
+(define NT_GNU_HWCAP 2)
+(define NT_GNU_BUILD_ID 3)
+(define NT_GNU_GOLD_VERSION 4)
+
+(define-record-type <elf-note>
+ (make-elf-note name desc type)
+ elf-note?
+ (name elf-note-name)
+ (desc elf-note-desc)
+ (type elf-note-type))
+
+(define (parse-elf-note elf section)
+ (let ((bv (elf-bytes elf))
+ (byte-order (elf-byte-order elf))
+ (offset (elf-section-offset section)))
+ (unless (<= (+ offset 12) (bytevector-length bv))
+ (error "corrupt ELF (offset out of range)" offset))
+ (let ((namesz (bytevector-u32-ref bv offset byte-order))
+ (descsz (bytevector-u32-ref bv (+ offset 4) byte-order))
+ (type (bytevector-u32-ref bv (+ offset 8) byte-order)))
+ (unless (<= (+ offset 12 namesz descsz) (bytevector-length bv))
+ (error "corrupt ELF (offset out of range)" offset))
+ (let ((name (make-bytevector (1- namesz)))
+ (desc (make-bytevector descsz)))
+ (bytevector-copy! bv (+ offset 12) name 0 (1- namesz))
+ (bytevector-copy! bv (+ offset 12 namesz) desc 0 descsz)
+ (make-elf-note (utf8->string name) desc type)))))
;;; Guile VM frame functions
-;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013, 2014 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 (system vm frame)
#:use-module (system base pmatch)
+ #:use-module (system foreign)
#:use-module (system vm program)
- #:use-module (system vm instruction)
- #:use-module (system vm objcode)
- #:export (frame-bindings
+ #:use-module (system vm debug)
+ #:use-module (system vm disassembler)
+ #:use-module (srfi srfi-9)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
+ #:export (binding-index
+ binding-name
+ binding-slot
+
+ frame-bindings
frame-lookup-binding
frame-binding-ref frame-binding-set!
- frame-next-source frame-call-representation
+ frame-call-representation
frame-environment
- frame-object-binding frame-object-name
- frame-return-values))
+ frame-object-binding frame-object-name))
-(define (frame-bindings frame)
- (let ((p (frame-procedure frame)))
- (if (program? p)
- (program-bindings-for-ip p (frame-instruction-pointer frame))
- '())))
+(define-record-type <binding>
+ (make-binding idx name slot)
+ binding?
+ (idx binding-index)
+ (name binding-name)
+ (slot binding-slot))
+
+(define (parse-code code)
+ (let ((len (bytevector-length code)))
+ (let lp ((pos 0) (out '()))
+ (cond
+ ((< pos len)
+ (let* ((inst-len (instruction-length code pos))
+ (pos (+ pos inst-len)))
+ (unless (<= pos len)
+ (error "Failed to parse codestream"))
+ (lp pos (cons inst-len out))))
+ (else
+ (list->vector (reverse out)))))))
+
+(define (compute-predecessors code parsed)
+ (let ((preds (make-vector (vector-length parsed) '())))
+ (define (add-pred! from target)
+ (let lp ((to from) (target target))
+ (cond
+ ((negative? target)
+ (lp (1- to) (+ target (vector-ref parsed (1- to)))))
+ ((positive? target)
+ (lp (1+ to) (- target (vector-ref parsed to))))
+ ((= to (vector-length preds))
+ ;; This can happen when an arity fails to match. Just ignore
+ ;; this case.
+ #t)
+ (else
+ (vector-set! preds to (cons from (vector-ref preds to)))))))
+ (let lp ((n 0) (pos 0))
+ (when (< n (vector-length preds))
+ (when (instruction-has-fallthrough? code pos)
+ (add-pred! n (vector-ref parsed n)))
+ (for-each (lambda (target)
+ (add-pred! n target))
+ (instruction-relative-jump-targets code pos))
+ (lp (1+ n) (+ pos (vector-ref parsed n)))))
+ preds))
+
+(define (compute-genv parsed defs)
+ (let ((genv (make-vector (vector-length parsed) '())))
+ (define (add-def! pos var)
+ (vector-set! genv pos (cons var (vector-ref genv pos))))
+ (let lp ((var 0) (pos 0) (pc-offset 0))
+ (when (< var (vector-length defs))
+ (match (vector-ref defs var)
+ (#(name offset slot)
+ (when (< offset pc-offset)
+ (error "mismatch between def offsets and parsed code"))
+ (cond
+ ((< pc-offset offset)
+ (lp var (1+ pos) (+ pc-offset (vector-ref parsed pos))))
+ (else
+ (add-def! pos var)
+ (lp (1+ var) pos pc-offset)))))))
+ genv))
+
+(define (compute-defs-by-slot defs)
+ (let* ((nslots (match defs
+ (#(#(_ _ slot) ...) (1+ (apply max slot)))))
+ (by-slot (make-vector nslots #f)))
+ (let lp ((n 0))
+ (when (< n nslots)
+ (vector-set! by-slot n (make-bitvector (vector-length defs) #f))
+ (lp (1+ n))))
+ (let lp ((n 0))
+ (when (< n (vector-length defs))
+ (match (vector-ref defs n)
+ (#(_ _ slot)
+ (bitvector-set! (vector-ref by-slot slot) n #t)
+ (lp (1+ n))))))
+ by-slot))
+
+(define (compute-killv code parsed defs)
+ (let ((defs-by-slot (compute-defs-by-slot defs))
+ (killv (make-vector (vector-length parsed) #f)))
+ (define (kill-slot! n slot)
+ (bit-set*! (vector-ref killv n) (vector-ref defs-by-slot slot) #t))
+ (let lp ((n 0))
+ (when (< n (vector-length killv))
+ (vector-set! killv n (make-bitvector (vector-length defs) #f))
+ (lp (1+ n))))
+ ;; Some defs get into place without explicit instructions -- this is
+ ;; the case if no shuffling need occur, for example. In any case,
+ ;; mark them as killing any previous definitions at that slot.
+ (let lp ((var 0) (pos 0) (pc-offset 0))
+ (when (< var (vector-length defs))
+ (match (vector-ref defs var)
+ (#(name offset slot)
+ (when (< offset pc-offset)
+ (error "mismatch between def offsets and parsed code"))
+ (cond
+ ((< pc-offset offset)
+ (lp var (1+ pos) (+ pc-offset (vector-ref parsed pos))))
+ (else
+ (kill-slot! pos slot)
+ (lp (1+ var) pos pc-offset)))))))
+ (let lp ((n 0) (pos 0))
+ (when (< n (vector-length parsed))
+ (for-each (lambda (slot)
+ (when (< slot (vector-length defs-by-slot))
+ (kill-slot! n slot)))
+ (instruction-slot-clobbers code pos
+ (vector-length defs-by-slot)))
+ (lp (1+ n) (+ pos (vector-ref parsed n)))))
+ killv))
+
+(define (available-bindings arity ip top-frame?)
+ (let* ((defs (list->vector (arity-definitions arity)))
+ (code (arity-code arity))
+ (parsed (parse-code code))
+ (len (vector-length parsed))
+ (preds (compute-predecessors code parsed))
+ (genv (compute-genv parsed defs))
+ (killv (compute-killv code parsed defs))
+ (inv (make-vector len #f))
+ (outv (make-vector len #f))
+ (tmp (make-bitvector (vector-length defs) #f)))
+ (define (bitvector-copy! dst src)
+ (bitvector-fill! dst #f)
+ (bit-set*! dst src #t))
+ (define (bitvector-meet! accum src)
+ (bitvector-copy! tmp src)
+ (bit-invert! tmp)
+ (bit-set*! accum tmp #f))
+
+ (let lp ((n 0))
+ (when (< n len)
+ (vector-set! inv n (make-bitvector (vector-length defs) #f))
+ (vector-set! outv n (make-bitvector (vector-length defs) #f))
+ (lp (1+ n))))
+
+ (let lp ((n 0) (first? #t) (changed? #f))
+ (cond
+ ((< n len)
+ (let ((in (vector-ref inv n))
+ (out (vector-ref outv n))
+ (kill (vector-ref killv n))
+ (gen (vector-ref genv n)))
+ (let ((out-count (or changed? (bit-count #t out))))
+ (bitvector-fill! in (not (zero? n)))
+ (let lp ((preds (vector-ref preds n)))
+ (match preds
+ (() #t)
+ ((pred . preds)
+ (unless (and first? (<= n pred))
+ (bitvector-meet! in (vector-ref outv pred)))
+ (lp preds))))
+ (bitvector-copy! out in)
+ (bit-set*! out kill #f)
+ (for-each (lambda (def)
+ (bitvector-set! out def #t))
+ gen)
+ (lp (1+ n) first?
+ (or changed? (not (eqv? out-count (bit-count #t out))))))))
+ ((or changed? first?)
+ (lp 0 #f #f))))
+
+ (let lp ((n 0) (offset (- ip (arity-low-pc arity))))
+ (when (< offset 0)
+ (error "ip did not correspond to an instruction boundary?"))
+ (if (zero? offset)
+ (let ((live (if top-frame?
+ (vector-ref inv n)
+ ;; If we're not at a top frame, the IP points
+ ;; to the continuation -- but we haven't
+ ;; returned and defined its values yet. The
+ ;; set of live variables is the set that was
+ ;; live going into the call, minus the set
+ ;; killed by the call, but not including
+ ;; values defined by the call.
+ (begin
+ (bitvector-copy! tmp (vector-ref inv (1- n)))
+ (bit-set*! tmp (vector-ref killv (1- n)) #f)
+ tmp))))
+ (let lp ((n 0))
+ (let ((n (bit-position #t live n)))
+ (if n
+ (match (vector-ref defs n)
+ (#(name def-offset slot)
+ ;; Binding 0 is the closure, and is not present
+ ;; in arity-definitions.
+ (cons (make-binding (1+ n) name slot)
+ (lp (1+ n)))))
+ '()))))
+ (lp (1+ n) (- offset (vector-ref parsed n)))))))
+
+(define* (frame-bindings frame #:optional top-frame?)
+ (let ((ip (frame-instruction-pointer frame)))
+ (cond
+ ((find-program-arity ip)
+ => (lambda (arity)
+ (available-bindings arity ip top-frame?)))
+ (else '()))))
(define (frame-lookup-binding frame var)
(let lp ((bindings (frame-bindings frame)))
(cond ((null? bindings)
#f)
- ((eq? (binding:name (car bindings)) var)
+ ((eq? (binding-name (car bindings)) var)
(car bindings))
(else
(lp (cdr bindings))))))
(define (frame-binding-set! frame var val)
(frame-local-set! frame
- (binding:index
+ (binding-slot
(or (frame-lookup-binding frame var)
(error "variable not bound in frame" var frame)))
val))
(define (frame-binding-ref frame var)
(frame-local-ref frame
- (binding:index
+ (binding-slot
(or (frame-lookup-binding frame var)
(error "variable not bound in frame" var frame)))))
;;; Pretty printing
;;;
-(define (frame-next-source frame)
- (let ((proc (frame-procedure frame)))
- (if (program? proc)
- (program-source proc
- (frame-instruction-pointer frame)
- (program-sources-pre-retire proc))
- '())))
-
-
;; Basically there are two cases to deal with here:
;;
;; 1. We've already parsed the arguments, and bound them to local
;; the types don't match. In that case the arguments are all on the
;; stack, and nothing else is on the stack.
-(define (frame-call-representation frame)
- (let ((p (frame-procedure frame)))
+(define* (frame-call-representation frame #:key top-frame?)
+ (let* ((ip (frame-instruction-pointer frame))
+ (info (find-program-debug-info ip))
+ (nlocals (frame-num-locals frame))
+ (closure (frame-procedure frame)))
+ (define (find-slot i bindings)
+ (match bindings
+ (#f (and (< i nlocals) i))
+ (() #f)
+ ((($ <binding> idx name slot) . bindings)
+ (if (< idx i)
+ (find-slot i bindings)
+ (and (= idx i) slot)))))
+ (define (local-ref i bindings)
+ (cond
+ ((find-slot i bindings)
+ => (lambda (slot) (frame-local-ref frame slot)))
+ (else
+ '_)))
+ (define (application-arguments)
+ ;; Case 1.
+ (map (lambda (local) (local-ref local #f))
+ ;; Cdr past the 0th local, which is the procedure.
+ (cdr (iota nlocals))))
+ (define (reconstruct-arguments bindings nreq nopt kw has-rest? local)
+ ;; Case 2.
+ (cond
+ ((positive? nreq)
+ (cons (local-ref local bindings)
+ (reconstruct-arguments bindings
+ (1- nreq) nopt kw has-rest? (1+ local))))
+ ((positive? nopt)
+ (cons (local-ref local bindings)
+ (reconstruct-arguments bindings
+ nreq (1- nopt) kw has-rest? (1+ local))))
+ ((pair? kw)
+ (cons* (caar kw) (local-ref (cdar kw) bindings)
+ (reconstruct-arguments bindings
+ nreq nopt (cdr kw) has-rest? (1+ local))))
+ (has-rest?
+ (local-ref local bindings))
+ (else
+ '())))
(cons
- (or (false-if-exception (procedure-name p)) p)
+ (or (and=> info program-debug-info-name)
+ (and (procedure? closure) (procedure-name closure))
+ closure)
(cond
- ((and (program? p)
- (program-arguments-alist p (frame-instruction-pointer frame)))
- ;; case 1
- => (lambda (arguments)
- (define (binding-ref sym i)
- (cond
- ((frame-lookup-binding frame sym)
- => (lambda (b) (frame-local-ref frame (binding:index b))))
- ((< i (frame-num-locals frame))
- (frame-local-ref frame i))
- (else
- ;; let's not error here, as we are called during backtraces...
- '???)))
- (let lp ((req (or (assq-ref arguments 'required) '()))
- (opt (or (assq-ref arguments 'optional) '()))
- (key (or (assq-ref arguments 'keyword) '()))
- (rest (or (assq-ref arguments 'rest) #f))
- (i 0))
- (cond
- ((pair? req)
- (cons (binding-ref (car req) i)
- (lp (cdr req) opt key rest (1+ i))))
- ((pair? opt)
- (cons (binding-ref (car opt) i)
- (lp req (cdr opt) key rest (1+ i))))
- ((pair? key)
- (cons* (caar key)
- (frame-local-ref frame (cdar key))
- (lp req opt (cdr key) rest (1+ i))))
- (rest
- (binding-ref rest i))
- (else
- '())))))
+ ((find-program-arity ip)
+ => (lambda (arity)
+ (if (and top-frame? (eqv? ip (arity-low-pc arity)))
+ (application-arguments)
+ (reconstruct-arguments (available-bindings arity ip top-frame?)
+ (arity-nreq arity)
+ (arity-nopt arity)
+ (arity-keyword-args arity)
+ (arity-has-rest? arity)
+ 1))))
+ ((and (primitive? closure)
+ (program-arguments-alist closure ip))
+ => (lambda (args)
+ (match args
+ ((('required . req)
+ ('optional . opt)
+ ('keyword . kw)
+ ('allow-other-keys? . _)
+ ('rest . rest))
+ (reconstruct-arguments #f
+ (length req) (length opt) kw rest 1)))))
(else
- ;; case 2
- (map (lambda (i)
- (frame-local-ref frame i))
- (iota (frame-num-locals frame))))))))
+ (application-arguments))))))
\f
(define (frame-environment frame)
(map (lambda (binding)
- (cons (binding:name binding) (frame-binding-ref frame binding)))
+ (cons (binding-name binding) (frame-binding-ref frame binding)))
(frame-bindings frame)))
(define (frame-object-binding frame obj)
(and (pair? bs) (car bs)))))
(define (frame-object-name frame obj)
- (cond ((frame-object-binding frame obj) => binding:name)
+ (cond ((frame-object-binding frame obj) => binding-name)
(else #f)))
-
-;; Nota bene, only if frame is in a return context (i.e. in a
-;; pop-continuation hook dispatch).
-(define (frame-return-values frame)
- (let* ((len (frame-num-locals frame))
- (nvalues (frame-local-ref frame (1- len))))
- (map (lambda (i)
- (frame-local-ref frame (+ (- len nvalues 1) i)))
- (iota nvalues))))
;;; Guile VM debugging facilities
-;;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2011, 2013 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 (system base syntax)
#:use-module (system vm vm)
#:use-module (system vm frame)
- #:use-module ((language assembly disassemble)
- #:select ((disassemble . %disassemble)))
+ #:use-module (system vm disassembler)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 format)
(display x))
(define-command ((commands disassemble x))
- "Disassemble the current object, which should be objcode or a procedure."
+ "Disassemble the current object, which should be a procedure."
(catch #t
(lambda ()
- (%disassemble x))
+ (disassemble-program x))
(lambda args
(format #t "Error disassembling object: ~a\n" args))))
+++ /dev/null
-;;; Guile VM instructions
-
-;; Copyright (C) 2001, 2010 Free Software Foundation, Inc.
-
-;;; This library is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU Lesser General Public
-;;; License as published by the Free Software Foundation; either
-;;; version 3 of the License, or (at your option) any later version.
-;;;
-;;; This library is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this library; if not, write to the Free Software
-;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Code:
-
-(define-module (system vm instruction)
- #:export (instruction-list
- instruction? instruction-length
- instruction-pops instruction-pushes
- instruction->opcode opcode->instruction))
-
-(load-extension (string-append "libguile-" (effective-version))
- "scm_init_instructions")
--- /dev/null
+;;; Guile ELF linker
+
+;; Copyright (C) 2011, 2012, 2013, 2014 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
+
+;;; Commentary:
+;;;
+;;; A linker combines several linker objects into an executable or a
+;;; loadable library.
+;;;
+;;; There are several common formats for libraries out there. Since
+;;; Guile includes its own linker and loader, we are free to choose any
+;;; format, or make up our own.
+;;;
+;;; There are essentially two requirements for a linker format:
+;;; libraries should be able to be loaded with the minimal amount of
+;;; work; and they should support introspection in some way, in order to
+;;; enable good debugging.
+;;;
+;;; These requirements are somewhat at odds, as loading should not have
+;;; to stumble over features related to introspection. It so happens
+;;; that a lot of smart people have thought about this situation, and
+;;; the ELF format embodies the outcome of their thinking. Guile uses
+;;; ELF as its format, regardless of the platform's native library
+;;; format. It's not inconceivable that Guile could interoperate with
+;;; the native dynamic loader at some point, but it's not a near-term
+;;; goal.
+;;;
+;;; Guile's linker takes a list of objects, sorts them according to
+;;; similarity from the perspective of the loader, then writes them out
+;;; into one big bytevector in ELF format.
+;;;
+;;; It is often the case that different parts of a library need to refer
+;;; to each other. For example, program text may need to refer to a
+;;; constant from writable memory. When the linker places sections
+;;; (linker objects) into specific locations in the linked bytevector,
+;;; it needs to fix up those references. This process is called
+;;; /relocation/. References needing relocations are recorded in
+;;; "linker-reloc" objects, and collected in a list in each
+;;; "linker-object". The actual definitions of the references are
+;;; stored in "linker-symbol" objects, also collected in a list in each
+;;; "linker-object".
+;;;
+;;; By default, the ELF files created by the linker include some padding
+;;; so that different parts of the file can be loaded in with different
+;;; permissions. For example, some parts of the file are read-only and
+;;; thus can be shared between processes. Some parts of the file don't
+;;; need to be loaded at all. However this padding can be too much for
+;;; interactive compilation, when the code is never written out to disk;
+;;; in that case, pass #:page-aligned? #f to `link-elf'.
+;;;
+;;; Code:
+
+(define-module (system vm linker)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system foreign)
+ #:use-module (system base target)
+ #:use-module ((srfi srfi-1) #:select (append-map))
+ #:use-module (srfi srfi-9)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (system vm elf)
+ #:export (make-linker-reloc
+ make-linker-symbol
+
+ make-linker-object
+ linker-object?
+ linker-object-section
+ linker-object-bv
+ linker-object-relocs
+ (linker-object-symbols* . linker-object-symbols)
+
+ make-string-table
+ string-table-intern!
+ link-string-table!
+
+ link-elf))
+
+(define-syntax fold-values
+ (lambda (x)
+ (syntax-case x ()
+ ((_ proc list seed ...)
+ (with-syntax (((s ...) (generate-temporaries #'(seed ...))))
+ #'(let ((p proc))
+ (let lp ((l list) (s seed) ...)
+ (match l
+ (() (values s ...))
+ ((elt . l)
+ (call-with-values (lambda () (p elt s ...))
+ (lambda (s ...) (lp l s ...))))))))))))
+
+;; A relocation records a reference to a symbol. When the symbol is
+;; resolved to an address, the reloc location will be updated to point
+;; to the address.
+;;
+;; Two types. Abs32/1 and Abs64/1 are absolute offsets in bytes.
+;; Rel32/1 and Rel32/1 are relative signed offsets, in 8-bit or 32-bit
+;; units, respectively. Either can have an arbitrary addend as well.
+;;
+(define-record-type <linker-reloc>
+ (make-linker-reloc type loc addend symbol)
+ linker-reloc?
+ (type linker-reloc-type) ;; rel32/1, rel32/4, abs32/1, abs64/1
+ (loc linker-reloc-loc)
+ (addend linker-reloc-addend)
+ (symbol linker-reloc-symbol))
+
+;; A symbol is an association between a name and an address. The
+;; address is always in regard to some particular address space. When
+;; objects come into the linker, their symbols live in the object
+;; address space. When the objects are allocated into ELF segments, the
+;; symbols will be relocated into memory address space, corresponding to
+;; the position the ELF will be loaded at.
+;;
+(define-record-type <linker-symbol>
+ (make-linker-symbol name address)
+ linker-symbol?
+ (name linker-symbol-name)
+ (address linker-symbol-address))
+
+(define-record-type <linker-object>
+ (%make-linker-object section bv relocs symbols)
+ linker-object?
+ (section linker-object-section)
+ (bv linker-object-bv)
+ (relocs linker-object-relocs)
+ (symbols linker-object-symbols))
+
+(define (make-linker-object section bv relocs symbols)
+ "Create a linker object with the @code{<elf-section>} header
+@var{section}, bytevector contents @var{bv}, list of linker relocations
+@var{relocs}, and list of linker symbols @var{symbols}."
+ (%make-linker-object section bv relocs
+ ;; Hide a symbol to the beginning of the section
+ ;; in the symbols.
+ (cons (make-linker-symbol (gensym "*section*") 0)
+ symbols)))
+(define (linker-object-section-symbol object)
+ "Return the linker symbol corresponding to the start of this section."
+ (car (linker-object-symbols object)))
+(define (linker-object-symbols* object)
+ "Return the linker symbols defined by the user for this this section."
+ (cdr (linker-object-symbols object)))
+
+(define-record-type <string-table>
+ (%make-string-table strings linked?)
+ string-table?
+ (strings string-table-strings set-string-table-strings!)
+ (linked? string-table-linked? set-string-table-linked?!))
+
+(define (make-string-table)
+ "Return a string table with one entry: the empty string."
+ (%make-string-table '(("" 0 #vu8())) #f))
+
+(define (string-table-length strings)
+ "Return the number of bytes needed for the @var{strings}."
+ (match strings
+ (((str pos bytes) . _)
+ ;; The + 1 is for the trailing NUL byte.
+ (+ pos (bytevector-length bytes) 1))))
+
+(define (string-table-intern! table str)
+ "Ensure that @var{str} is present in the string table @var{table}.
+Returns the byte index of the string in that table."
+ (match table
+ (($ <string-table> strings linked?)
+ (match (assoc str strings)
+ ((_ pos _) pos)
+ (#f
+ (let ((next (string-table-length strings)))
+ (when linked?
+ (error "string table already linked, can't intern" table str))
+ (set-string-table-strings! table
+ (cons (list str next (string->utf8 str))
+ strings))
+ next))))))
+
+(define (link-string-table! table)
+ "Link the functional string table @var{table} into a sequence of
+bytes, suitable for use as the contents of an ELF string table section."
+ (match table
+ (($ <string-table> strings #f)
+ (let ((out (make-bytevector (string-table-length strings) 0)))
+ (for-each
+ (match-lambda
+ ((_ pos bytes)
+ (bytevector-copy! bytes 0 out pos (bytevector-length bytes))))
+ strings)
+ (set-string-table-linked?! table #t)
+ out))))
+
+(define (segment-kind section)
+ "Return the type of segment needed to store @var{section}, as a pair.
+The car is the @code{PT_} segment type, or @code{#f} if the section
+doesn't need to be present in a loadable segment. The cdr is a bitfield
+of associated @code{PF_} permissions."
+ (let ((flags (elf-section-flags section)))
+ ;; Sections without SHF_ALLOC don't go in segments.
+ (cons (if (zero? flags) #f PT_LOAD)
+ (logior (if (logtest SHF_ALLOC flags) PF_R 0)
+ (if (logtest SHF_EXECINSTR flags) PF_X 0)
+ (if (logtest SHF_WRITE flags) PF_W 0)))))
+
+(define (count-segments objects)
+ "Return the total number of segments needed to represent the linker
+objects in @var{objects}, including the segment needed for the ELF
+header and segment table."
+ (define (adjoin x xs)
+ (if (member x xs) xs (cons x xs)))
+ (length
+ (fold-values (lambda (object kinds)
+ (let ((kind (segment-kind (linker-object-section object))))
+ (if (= (elf-section-type (linker-object-section object))
+ SHT_DYNAMIC)
+ ;; The dynamic section is part of a loadable
+ ;; segment, and also gets the additional
+ ;; PT_DYNAMIC segment header.
+ (cons (cons PT_DYNAMIC (cdr kind))
+ (adjoin kind kinds))
+ (if (car kind) (adjoin kind kinds) kinds))))
+ objects
+ ;; We know there will be at least one segment,
+ ;; containing at least the header and segment table.
+ (list (cons PT_LOAD PF_R)))))
+
+(define (group-by-cars ls)
+ (let lp ((ls ls) (k #f) (group #f) (out '()))
+ (match ls
+ (()
+ (reverse!
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out)))
+ (((k* . v) . ls)
+ (if (and group (equal? k k*))
+ (lp ls k (cons v group) out)
+ (lp ls k* (list v)
+ (if group
+ (cons (cons k (reverse! group)) out)
+ out)))))))
+
+(define (collate-objects-into-segments objects)
+ "Given the list of linker objects @var{objects}, group them into
+contiguous ELF segments of the same type and flags. The result is an
+alist that maps segment types to lists of linker objects. See
+@code{segment-type} for a description of segment types. Within a
+segment, the order of the linker objects is preserved."
+ (group-by-cars
+ (stable-sort!
+ (map (lambda (o)
+ (cons (segment-kind (linker-object-section o)) o))
+ objects)
+ (lambda (x y)
+ (let* ((x-kind (car x)) (y-kind (car y))
+ (x-type (car x-kind)) (y-type (car y-kind))
+ (x-flags (cdr x-kind)) (y-flags (cdr y-kind))
+ (x-section (linker-object-section (cdr x)))
+ (y-section (linker-object-section (cdr y))))
+ (cond
+ ((not (equal? x-kind y-kind))
+ (cond
+ ((and x-type y-type)
+ (cond
+ ((not (equal? x-flags y-flags))
+ (< x-flags y-flags))
+ (else
+ (< x-type y-type))))
+ (else
+ (not y-type))))
+ ((not (equal? (elf-section-type x-section)
+ (elf-section-type y-section)))
+ (cond
+ ((equal? (elf-section-type x-section) SHT_NOBITS) #t)
+ ((equal? (elf-section-type y-section) SHT_NOBITS) #f)
+ (else (< (elf-section-type x-section)
+ (elf-section-type y-section)))))
+ (else
+ ;; Leave them in the initial order. This allows us to ensure
+ ;; that the ELF header is written first.
+ #f)))))))
+
+(define (align address alignment)
+ (if (zero? alignment)
+ address
+ (+ address
+ (modulo (- alignment (modulo address alignment)) alignment))))
+
+(define (relocate-section-header sec offset)
+ "Return a new section header, just like @var{sec} but with its
+@code{offset} (and @code{addr} if it is loadable) set to @var{offset}."
+ (make-elf-section #:index (elf-section-index sec)
+ #:name (elf-section-name sec)
+ #:type (elf-section-type sec)
+ #:flags (elf-section-flags sec)
+ #:addr (if (zero? (logand SHF_ALLOC
+ (elf-section-flags sec)))
+ 0
+ offset)
+ #:offset offset
+ #:size (elf-section-size sec)
+ #:link (elf-section-link sec)
+ #:info (elf-section-info sec)
+ #:addralign (elf-section-addralign sec)
+ #:entsize (elf-section-entsize sec)))
+
+(define *page-size* 4096)
+
+(define (add-symbols symbols offset symtab)
+ "Add @var{symbols} to the symbol table @var{symtab}, relocating them
+from object address space to memory address space. Returns a new symbol
+table."
+ (fold-values
+ (lambda (symbol symtab)
+ (let ((name (linker-symbol-name symbol))
+ (addr (linker-symbol-address symbol)))
+ (when (vhash-assq name symtab)
+ (error "duplicate symbol" name))
+ (vhash-consq name (make-linker-symbol name (+ addr offset)) symtab)))
+ symbols
+ symtab))
+
+(define (allocate-segment write-segment-header!
+ phidx type flags objects addr symtab alignment)
+ "Given a list of linker objects that should go in a segment, the type
+and flags that the segment should have, and the address at which the
+segment should start, compute the positions that each object should have
+in the segment.
+
+Returns three values: the address of the next byte after the segment, a
+list of relocated objects, and the symbol table. The symbol table is
+the same as @var{symtab}, augmented with the symbols defined in
+@var{objects}, relocated to their positions in the image.
+
+In what is something of a quirky interface, this routine also patches up
+the segment table using @code{write-segment-header!}."
+ (let* ((alignment (fold-values (lambda (o alignment)
+ (lcm (elf-section-addralign
+ (linker-object-section o))
+ alignment))
+ objects
+ alignment))
+ (addr (align addr alignment)))
+ (receive (objects endaddr symtab)
+ (fold-values
+ (lambda (o out addr symtab)
+ (let* ((section (linker-object-section o))
+ (addr (align addr (elf-section-addralign section))))
+ (values
+ (cons (make-linker-object
+ (relocate-section-header section addr)
+ (linker-object-bv o)
+ (linker-object-relocs o)
+ (linker-object-symbols o))
+ out)
+ (+ addr (elf-section-size section))
+ (add-symbols (linker-object-symbols o) addr symtab))))
+ objects
+ '() addr symtab)
+ (when type
+ (write-segment-header!
+ (make-elf-segment #:index phidx #:type type
+ #:offset addr #:vaddr addr #:paddr addr
+ #:filesz (- endaddr addr) #:memsz (- endaddr addr)
+ #:flags flags #:align alignment)))
+ (values endaddr
+ (reverse objects)
+ symtab))))
+
+(define (process-reloc reloc bv section-offset symtab endianness)
+ "Process a relocation. Given that a section containing @var{reloc}
+was just written into the image @var{bv} at offset @var{section-offset},
+fix it up so that its reference points to the correct position of its
+symbol, as present in @var{symtab}."
+ (match (vhash-assq (linker-reloc-symbol reloc) symtab)
+ (#f
+ (error "Undefined symbol" (linker-reloc-symbol reloc)))
+ ((name . symbol)
+ ;; The reloc was written at LOC bytes after SECTION-OFFSET.
+ (let* ((offset (+ (linker-reloc-loc reloc) section-offset))
+ (target (linker-symbol-address symbol)))
+ (case (linker-reloc-type reloc)
+ ((rel32/4)
+ (let ((diff (- target offset)))
+ (unless (zero? (modulo diff 4))
+ (error "Bad offset" reloc symbol offset))
+ (bytevector-s32-set! bv offset
+ (+ (/ diff 4) (linker-reloc-addend reloc))
+ endianness)))
+ ((rel32/1)
+ (let ((diff (- target offset)))
+ (bytevector-s32-set! bv offset
+ (+ diff (linker-reloc-addend reloc))
+ endianness)))
+ ((abs32/1)
+ (bytevector-u32-set! bv offset target endianness))
+ ((abs64/1)
+ (bytevector-u64-set! bv offset target endianness))
+ (else
+ (error "bad reloc type" reloc)))))))
+
+(define (write-linker-object bv o symtab endianness)
+ "Write the bytevector for the section wrapped by the linker object
+@var{o} into the image @var{bv}. The section header in @var{o} should
+already be relocated its final position in the image. Any relocations
+in the section will be processed to point to the correct symbol
+locations, as given in @var{symtab}."
+ (let* ((section (linker-object-section o))
+ (offset (elf-section-offset section))
+ (len (elf-section-size section))
+ (bytes (linker-object-bv o))
+ (relocs (linker-object-relocs o)))
+ (if (zero? (logand SHF_ALLOC (elf-section-flags section)))
+ (unless (zero? (elf-section-addr section))
+ (error "non-loadable section has non-zero addr" section))
+ (unless (= offset (elf-section-addr section))
+ (error "loadable section has offset != addr" section)))
+ (if (not (= (elf-section-type section) SHT_NOBITS))
+ (begin
+ (if (not (= len (bytevector-length bytes)))
+ (error "unexpected length" section bytes))
+ (bytevector-copy! bytes 0 bv offset len)
+ (for-each (lambda (reloc)
+ (process-reloc reloc bv offset symtab endianness))
+ relocs)))))
+
+(define (find-shstrndx objects)
+ "Find the section name string table in @var{objects}, and return its
+section index."
+ (or-map (lambda (object)
+ (let* ((section (linker-object-section object))
+ (bv (linker-object-bv object))
+ (name (elf-section-name section)))
+ (and (= (elf-section-type section) SHT_STRTAB)
+ (equal? (false-if-exception (string-table-ref bv name))
+ ".shstrtab")
+ (elf-section-index section))))
+ objects))
+
+(define (add-elf-objects objects endianness word-size abi type machine-type)
+ "Given the list of linker objects supplied by the user, add linker
+objects corresponding to parts of the ELF file: the null object, the ELF
+header, and the section table.
+
+Both of these internal objects include relocs, allowing their
+inter-object references to be patched up when the final image allocation
+is known. There is special support for patching up the segment table,
+however. Because the segment table needs to know the segment sizes,
+which is the difference between two symbols in image space, and there is
+no reloc kind that is the difference between two symbols, we make a hack
+and return a closure that patches up segment table entries. It seems to
+work.
+
+Returns two values: the procedure to patch the segment table, and the
+list of objects, augmented with objects for the special ELF sections."
+ (define phoff (elf-header-len word-size))
+ (define phentsize (elf-program-header-len word-size))
+ (define shentsize (elf-section-header-len word-size))
+ (define shnum (+ (length objects) 3))
+ (define reloc-kind
+ (case word-size
+ ((4) 'abs32/1)
+ ((8) 'abs64/1)
+ (else (error "bad word size" word-size))))
+
+ ;; ELF requires that the first entry in the section table be of type
+ ;; SHT_NULL.
+ ;;
+ (define (make-null-section)
+ (make-linker-object (make-elf-section #:index 0 #:type SHT_NULL
+ #:flags 0 #:addralign 0)
+ #vu8() '() '()))
+
+ ;; The ELF header and the segment table.
+ ;;
+ (define (make-header phnum index shoff-label)
+ (let* ((header (make-elf #:byte-order endianness #:word-size word-size
+ #:abi abi #:type type #:machine-type machine-type
+ #:phoff phoff #:phnum phnum #:phentsize phentsize
+ #:shoff 0 #:shnum shnum #:shentsize shentsize
+ #:shstrndx (or (find-shstrndx objects) SHN_UNDEF)))
+ (shoff-reloc (make-linker-reloc reloc-kind
+ (elf-header-shoff-offset word-size)
+ 0
+ shoff-label))
+ (size (+ phoff (* phnum phentsize)))
+ (bv (make-bytevector size 0)))
+ (write-elf-header bv header)
+ ;; Leave the segment table uninitialized; it will be filled in
+ ;; later by calls to the write-segment-header! closure.
+ (make-linker-object (make-elf-section #:index index #:type SHT_PROGBITS
+ #:flags SHF_ALLOC #:size size)
+ bv
+ (list shoff-reloc)
+ '())))
+
+ ;; The section table.
+ ;;
+ (define (make-footer objects shoff-label)
+ (let* ((size (* shentsize shnum))
+ (bv (make-bytevector size 0))
+ (section-table (make-elf-section #:index (length objects)
+ #:type SHT_PROGBITS
+ #:flags 0
+ #:size size)))
+ (define (write-and-reloc section-label section relocs)
+ (let ((offset (* shentsize (elf-section-index section))))
+ (write-elf-section-header bv offset endianness word-size section)
+ (if (= (elf-section-type section) SHT_NULL)
+ relocs
+ (let ((relocs
+ (cons (make-linker-reloc
+ reloc-kind
+ (+ offset
+ (elf-section-header-offset-offset word-size))
+ 0
+ section-label)
+ relocs)))
+ (if (zero? (logand SHF_ALLOC (elf-section-flags section)))
+ relocs
+ (cons (make-linker-reloc
+ reloc-kind
+ (+ offset
+ (elf-section-header-addr-offset word-size))
+ 0
+ section-label)
+ relocs))))))
+ (let ((relocs (fold-values
+ (lambda (object relocs)
+ (write-and-reloc
+ (linker-symbol-name
+ (linker-object-section-symbol object))
+ (linker-object-section object)
+ relocs))
+ objects
+ (write-and-reloc shoff-label section-table '()))))
+ (%make-linker-object section-table bv relocs
+ (list (make-linker-symbol shoff-label 0))))))
+
+ (let* ((null-section (make-null-section))
+ (objects (cons null-section objects))
+
+ (shoff (gensym "*section-table*"))
+ (header (make-header (count-segments objects) (length objects) shoff))
+ (objects (cons header objects))
+
+ (footer (make-footer objects shoff))
+ (objects (cons footer objects)))
+
+ ;; The header includes the segment table, which needs offsets and
+ ;; sizes of the segments. Normally we would use relocs to rewrite
+ ;; these values, but there is no reloc type that would allow us to
+ ;; compute size. Such a reloc would need to take the difference
+ ;; between two symbols, and it's probably a bad idea architecturally
+ ;; to create one.
+ ;;
+ ;; So instead we return a closure to patch up the segment table.
+ ;; Normally we'd shy away from such destructive interfaces, but it's
+ ;; OK as we create the header section ourselves.
+ ;;
+ (define (write-segment-header! segment)
+ (let ((bv (linker-object-bv header))
+ (offset (+ phoff (* (elf-segment-index segment) phentsize))))
+ (write-elf-program-header bv offset endianness word-size segment)))
+
+ (values write-segment-header! objects)))
+
+(define (record-special-segments write-segment-header! phidx all-objects)
+ (let lp ((phidx phidx) (objects all-objects))
+ (match objects
+ (() #t)
+ ((object . objects)
+ (let ((section (linker-object-section object)))
+ (cond
+ ((eqv? (elf-section-type section) SHT_DYNAMIC)
+ (let ((addr (elf-section-offset section))
+ (size (elf-section-size section))
+ (align (elf-section-addralign section))
+ (flags (cdr (segment-kind section))))
+ (write-segment-header!
+ (make-elf-segment #:index phidx #:type PT_DYNAMIC
+ #:offset addr #:vaddr addr #:paddr addr
+ #:filesz size #:memsz size
+ #:flags flags #:align align))
+ (lp (1+ phidx) objects)))
+ (else
+ (lp phidx objects))))))))
+
+(define (allocate-elf objects page-aligned? endianness word-size
+ abi type machine-type)
+ "Lay out @var{objects} into an ELF image, computing the size of the
+file, the positions of the objects, and the global symbol table.
+
+If @var{page-aligned?} is true, read-only and writable data are
+separated so that only those writable parts of the image need be mapped
+with writable permissions. This makes the resulting image larger. It
+is more suitable to situations where you would write a file out to disk
+and read it in with mmap. Otherwise if @var{page-aligned?} is false,
+sections default to 8-byte alignment.
+
+Returns three values: the total image size, a list of objects with
+relocated headers, and the global symbol table."
+ (receive (write-segment-header! objects)
+ (add-elf-objects objects endianness word-size abi type machine-type)
+ (let lp ((seglists (collate-objects-into-segments objects))
+ (objects '())
+ (phidx 0)
+ (addr 0)
+ (symtab vlist-null)
+ (prev-flags 0))
+ (match seglists
+ ((((type . flags) objs-in ...) seglists ...)
+ (receive (addr objs-out symtab)
+ (allocate-segment
+ write-segment-header!
+ phidx type flags objs-in addr symtab
+ (if (and page-aligned?
+ (not (= flags prev-flags))
+ ;; Allow sections that are not in
+ ;; loadable segments to share pages
+ ;; with PF_R segments.
+ (not (and (not type) (= PF_R prev-flags))))
+ *page-size*
+ 8))
+ (lp seglists
+ (fold-values cons objs-out objects)
+ (if type (1+ phidx) phidx)
+ addr
+ symtab
+ flags)))
+ (()
+ (record-special-segments write-segment-header! phidx objects)
+ (values addr
+ (reverse objects)
+ symtab))))))
+
+(define (check-section-numbers objects)
+ "Verify that taken as a whole, that all objects have distinct,
+contiguous section numbers, starting from 1. (Section 0 is the null
+section.)"
+ (let* ((nsections (1+ (length objects))) ; 1+ for initial NULL section.
+ (sections (make-vector nsections #f)))
+ (for-each (lambda (object)
+ (let ((n (elf-section-index (linker-object-section object))))
+ (cond
+ ((< n 1)
+ (error "Invalid section number" object))
+ ((>= n nsections)
+ (error "Invalid section number" object))
+ ((vector-ref sections n)
+ (error "Duplicate section" (vector-ref sections n) object))
+ (else
+ (vector-set! sections n object)))))
+ objects)))
+
+;; Given a list of linker objects, collate the objects into segments,
+;; allocate the segments, allocate the ELF bytevector, and write the
+;; segments into the bytevector, relocating as we go.
+;;
+(define* (link-elf objects #:key
+ (page-aligned? #t)
+ (endianness (target-endianness))
+ (word-size (target-word-size))
+ (abi ELFOSABI_STANDALONE)
+ (type ET_DYN)
+ (machine-type EM_NONE))
+ "Create an ELF image from the linker objects, @var{objects}.
+
+If @var{page-aligned?} is true, read-only and writable data are
+separated so that only those writable parts of the image need be mapped
+with writable permissions. This is suitable for situations where you
+would write a file out to disk and read it in with @code{mmap}.
+Otherwise if @var{page-aligned?} is false, sections default to 8-byte
+alignment.
+
+Returns a bytevector."
+ (check-section-numbers objects)
+ (receive (size objects symtab)
+ (allocate-elf objects page-aligned? endianness word-size
+ abi type machine-type)
+ (let ((bv (make-bytevector size 0)))
+ (for-each
+ (lambda (object)
+ (write-linker-object bv object symtab endianness))
+ objects)
+ bv)))
;;; Guile VM object code
-;; Copyright (C) 2001, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2010, 2012, 2013 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 (system vm objcode)
- #:export (objcode? objcode-meta
- bytecode->objcode objcode->bytecode
- load-objcode write-objcode
- word-size byte-order))
+(define-module (system vm loader)
+ #:export (load-thunk-from-file
+ load-thunk-from-memory
+ find-mapped-elf-image all-mapped-elf-images))
(load-extension (string-append "libguile-" (effective-version))
- "scm_init_objcodes")
+ "scm_init_loader")
;;; Guile VM program functions
-;;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2013, 2014 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 (system vm program)
- #:use-module (system base pmatch)
- #:use-module (system vm instruction)
- #:use-module (system vm objcode)
+ #:use-module (ice-9 match)
+ #:use-module (system vm debug)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
- #:export (make-program
-
- make-binding binding:name binding:boxed? binding:index
- binding:start binding:end
-
- source:addr source:line source:column source:file
+ #:export (source:addr source:line source:column source:file
source:line-for-user
program-sources program-sources-pre-retire program-source
- program-bindings program-bindings-by-index program-bindings-for-ip
+ program-address-range
+
program-arities program-arity arity:start arity:end
arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
- program-arguments-alist program-lambda-list
+ program-arguments-alist program-arguments-alists
+ program-lambda-list
- program-meta
- program-objcode program? program-objects
- program-module program-base
+ program? program-code
program-free-variables
program-num-free-variables
- program-free-variable-ref program-free-variable-set!))
+ program-free-variable-ref program-free-variable-set!
+
+ print-program
+
+ primitive?))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_programs")
-(define (make-binding name boxed? index start end)
- (list name boxed? index start end))
-(define (binding:name b) (list-ref b 0))
-(define (binding:boxed? b) (list-ref b 1))
-(define (binding:index b) (list-ref b 2))
-(define (binding:start b) (list-ref b 3))
-(define (binding:end b) (list-ref b 4))
+;; These procedures are called by programs.c.
+(define (program-name program)
+ (and=> (find-program-debug-info (program-code program))
+ program-debug-info-name))
+(define (program-documentation program)
+ (find-program-docstring (program-code program)))
+(define (program-minimum-arity program)
+ (find-program-minimum-arity (program-code program)))
+(define (program-properties program)
+ (find-program-properties (program-code program)))
(define (source:addr source)
(car source))
(define (source:line-for-user source)
(1+ (source:line source)))
-;; FIXME: pull this definition from elsewhere.
-(define *bytecode-header-len* 8)
+(define (source-for-addr addr)
+ (and=> (find-source-for-addr addr)
+ (lambda (source)
+ ;; FIXME: absolute or relative address?
+ (cons* 0
+ (source-file source)
+ (source-line source)
+ (source-column source)))))
-;; We could decompile the program to get this, but that seems like a
-;; waste.
-(define (bytecode-instruction-length bytecode ip)
- (let* ((idx (+ ip *bytecode-header-len*))
- (inst (opcode->instruction (bytevector-u8-ref bytecode idx))))
- ;; 1+ for the instruction itself.
- (1+ (cond
- ((eq? inst 'load-program)
- (+ (bytevector-u32-native-ref bytecode (+ idx 1))
- (bytevector-u32-native-ref bytecode (+ idx 5))))
- ((< (instruction-length inst) 0)
- ;; variable length instruction -- the length is encoded in the
- ;; instruction stream.
- (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16)
- (ash (bytevector-u8-ref bytecode (+ idx 2)) 8)
- (bytevector-u8-ref bytecode (+ idx 3))))
- (else
- ;; fixed length
- (instruction-length inst))))))
+(define (program-sources proc)
+ (map (lambda (source)
+ (cons* (- (source-post-pc source) (program-code proc))
+ (source-file source)
+ (source-line source)
+ (source-column source)))
+ (find-program-sources (program-code proc))))
+
+(define* (program-source proc ip #:optional (sources (program-sources proc)))
+ (let lp ((source #f) (sources sources))
+ (match sources
+ (() source)
+ (((and s (pc . _)) . sources)
+ (if (<= pc ip)
+ (lp s sources)
+ source)))))
+
+(define (program-address-range program)
+ "Return the start and end addresses of @var{program}'s code, as a pair
+of integers."
+ (let ((pdi (find-program-debug-info (program-code program))))
+ (and pdi
+ (cons (program-debug-info-addr pdi)
+ (+ (program-debug-info-addr pdi)
+ (program-debug-info-size pdi))))))
;; Source information could in theory be correlated with the ip of the
;; instruction, or the ip just after the instruction is retired. Guile
;; pre-retire addresses.
;;
(define (program-sources-pre-retire proc)
- (let ((bv (objcode->bytecode (program-objcode proc))))
- (let lp ((in (program-sources proc))
- (out '())
- (ip 0))
- (cond
- ((null? in)
- (reverse out))
- (else
- (pmatch (car in)
- ((,post-ip . ,source)
- (let lp2 ((ip ip)
- (next ip))
- (if (< next post-ip)
- (lp2 next (+ next (bytecode-instruction-length bv next)))
- (lp (cdr in)
- (acons ip source out)
- next))))
- (else
- (error "unexpected"))))))))
-
-(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)))))))))
+ (map (lambda (source)
+ (cons* (- (source-pre-pc source) (program-code proc))
+ (source-file source)
+ (source-line source)
+ (source-column source)))
+ (find-program-sources (program-code proc))))
(define (arity:start a)
- (pmatch a ((,start ,end . _) start) (else (error "bad arity" a))))
+ (match a ((start end . _) start) (_ (error "bad arity" a))))
(define (arity:end a)
- (pmatch a ((,start ,end . _) end) (else (error "bad arity" a))))
+ (match a ((start end . _) end) (_ (error "bad arity" a))))
(define (arity:nreq a)
- (pmatch a ((_ _ ,nreq . _) nreq) (else 0)))
+ (match a ((_ _ nreq . _) nreq) (_ 0)))
(define (arity:nopt a)
- (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0)))
+ (match a ((_ _ nreq nopt . _) nopt) (_ 0)))
(define (arity:rest? a)
- (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f)))
+ (match a ((_ _ nreq nopt rest? . _) rest?) (_ #f)))
(define (arity:kw a)
- (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '())))
+ (match a ((_ _ nreq nopt rest? (_ . kw)) kw) (_ '())))
(define (arity:allow-other-keys? a)
- (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f)))
+ (match a ((_ _ nreq nopt rest? (aok . kw)) aok) (_ #f)))
(define (program-arity prog ip)
(let ((arities (program-arities prog)))
(else (lp (cdr arities))))))))
(define (arglist->arguments-alist arglist)
- (pmatch arglist
- ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
+ (match 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)))
+ (_ #f)))
(define* (arity->arguments-alist prog arity
#:optional
(make-placeholder
(lambda (i) (string->symbol "_"))))
- (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)
- (or (assv-ref rbinds i)
- ;; if we don't know the name, return a placeholder
- (make-placeholder 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)
+ (lp (1- nreq) (cons (make-placeholder n) req)
nopt opt rest? rest (1+ n)))
((< 0 nopt)
(lp nreq req
- (1- nopt) (cons (var-by-index n) opt)
+ (1- nopt) (cons (make-placeholder n) opt)
rest? rest (1+ n)))
(rest?
(lp nreq req nopt opt
- #f (var-by-index (+ n (length (arity:kw arity))))
+ #f (make-placeholder (+ n (length (arity:kw arity))))
(1+ n)))
(else
`((required . ,(reverse req))
;; the name "program-arguments" is taken by features.c...
(define* (program-arguments-alist prog #:optional ip)
"Returns the signature of the given procedure in the form of an association list."
- (let ((arity (program-arity prog ip)))
- (and arity
- (arity->arguments-alist prog arity))))
+ (cond
+ ((primitive? prog)
+ (match (procedure-minimum-arity prog)
+ (#f #f)
+ ((nreq nopt rest?)
+ (let ((start (primitive-call-ip prog)))
+ ;; Assume that there is only one IP for the call.
+ (and (or (not ip) (= start ip))
+ (arity->arguments-alist
+ prog
+ (list 0 0 nreq nopt rest? '(#f . ()))))))))
+ ((program? prog)
+ (or-map (lambda (arity)
+ (and (or (not ip)
+ (and (<= (arity-low-pc arity) ip)
+ (< ip (arity-high-pc arity))))
+ (arity-arguments-alist arity)))
+ (or (find-program-arities (program-code prog)) '())))
+ (else
+ (let ((arity (program-arity prog ip)))
+ (and arity
+ (arity->arguments-alist prog arity))))))
(define* (program-lambda-list prog #:optional ip)
"Returns the signature of the given procedure in the form of an argument list."
1+
0)))
-(define (write-program prog port)
- (format port "#<procedure ~a~a>"
- (or (procedure-name prog)
- (and=> (program-source prog 0)
- (lambda (s)
- (format #f "~a at ~a:~a:~a"
- (number->string (object-address prog) 16)
- (or (source:file s)
- (if s "<current input>" "<unknown port>"))
- (source:line-for-user s) (source:column s))))
- (number->string (object-address prog) 16))
- (let ((arities (program-arities prog)))
- (if (or (not arities) (null? arities))
- ""
+(define (program-arguments-alists prog)
+ "Returns all arities of the given procedure, as a list of association
+lists."
+ (define (fallback)
+ (match (procedure-minimum-arity prog)
+ (#f '())
+ ((nreq nopt rest?)
+ (list
+ (arity->arguments-alist
+ prog
+ (list 0 0 nreq nopt rest? '(#f . ())))))))
+ (cond
+ ((primitive? prog) (fallback))
+ ((program? prog)
+ (let ((arities (find-program-arities (program-code prog))))
+ (if arities
+ (map arity-arguments-alist arities)
+ (fallback))))
+ (else (error "expected a program" prog))))
+
+(define* (print-program #:optional program (port (current-output-port))
+ #:key (addr (program-code program))
+ (always-print-addr? #f) (never-print-addr? #f)
+ (always-print-source? #f) (never-print-source? #f)
+ (name-only? #f) (print-formals? #t))
+ (let* ((pdi (find-program-debug-info addr))
+ ;; It could be the procedure had its name property set via the
+ ;; procedure property interface.
+ (name (or (and program (procedure-name program))
+ (program-debug-info-name pdi)))
+ (source (match (find-program-sources addr)
+ (() #f)
+ ((source . _) source)))
+ (formals (if program
+ (program-arguments-alists program)
+ (let ((arities (find-program-arities addr)))
+ (if arities
+ (map arity-arguments-alist arities)
+ '())))))
+ (define (hex n)
+ (number->string n 16))
+
+ (cond
+ ((and name-only? name)
+ (format port "~a" name))
+ (else
+ (format port "#<procedure")
+ (format port " ~a"
+ (or name
+ (and program (hex (object-address program)))
+ (if never-print-addr?
+ ""
+ (string-append "@" (hex addr)))))
+ (when (and always-print-addr? (not never-print-addr?))
+ (unless (and (not name) (not program))
+ (format port " @~a" (hex addr))))
+ (when (and source (not never-print-source?)
+ (or always-print-source? (not name)))
+ (format port " at ~a:~a:~a"
+ (or (source-file source) "<unknown port>")
+ (source-line-for-user source)
+ (source-column source)))
+ (unless (or (null? formals) (not print-formals?))
+ (format port "~a"
(string-append
" " (string-join (map (lambda (a)
(object->string
- (arguments-alist->lambda-list
- (arity->arguments-alist prog a))))
- arities)
- " | "))))))
+ (arguments-alist->lambda-list a)))
+ formals)
+ " | "))))
+ (format port ">")))))
+(define (write-program prog port)
+ (print-program prog port))
;;; Guile VM tracer
-;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014 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 (system vm vm)
#:use-module (system vm frame)
#:use-module (system vm program)
- #:use-module (system vm objcode)
#:use-module (system vm traps)
#:use-module (rnrs bytevectors)
- #:use-module (system vm instruction)
#:use-module (ice-9 format)
#:export (trace-calls-in-procedure
trace-calls-to-procedure
trace-instructions-in-procedure
call-with-trace))
-;; FIXME: this constant needs to go in system vm objcode
-(define *objcode-header-len* 8)
-
(define (build-prefix prefix depth infix numeric-format max-indent)
(let lp ((indent "") (n 0))
(cond
(format (current-error-port) "~a~v:@y\n"
prefix
width
- (frame-call-representation frame))))
+ (frame-call-representation frame #:top-frame? #t))))
-(define* (print-return frame depth width prefix max-indent)
- (let* ((len (frame-num-locals frame))
- (nvalues (frame-local-ref frame (1- len)))
- (prefix (build-prefix prefix depth "| " "~d< "max-indent)))
- (case nvalues
+(define (print-return depth width prefix max-indent values)
+ (let ((prefix (build-prefix prefix depth "| " "~d< "max-indent)))
+ (case (length values)
((0)
(format (current-error-port) "~ano values\n" prefix))
((1)
(format (current-error-port) "~a~v:@y\n"
prefix
width
- (frame-local-ref frame (- len 2))))
+ (car values)))
(else
;; this should work, but there appears to be a bug
;; "~a~d values:~:{ ~v:@y~}\n"
(format (current-error-port) "~a~d values:~{ ~a~}\n"
- prefix nvalues
+ prefix (length values)
(map (lambda (val)
(format #f "~v:@y" width val))
- (frame-return-values frame)))))))
-
-(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm))
+ values))))))
+
+(define* (trace-calls-to-procedure proc #:key (width 80)
(prefix "trace: ")
(max-indent (- width 40)))
(define (apply-handler frame depth)
(print-application frame depth width prefix max-indent))
- (define (return-handler frame depth)
- (print-return frame depth width prefix max-indent))
- (trap-calls-to-procedure proc apply-handler return-handler
- #:vm vm))
+ (define (return-handler frame depth . values)
+ (print-return depth width prefix max-indent values))
+ (trap-calls-to-procedure proc apply-handler return-handler))
-(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm))
+(define* (trace-calls-in-procedure proc #:key (width 80)
(prefix "trace: ")
(max-indent (- width 40)))
(define (apply-handler frame depth)
(print-application frame depth width prefix max-indent))
- (define (return-handler frame depth)
- (print-return frame depth width prefix max-indent))
- (trap-calls-in-dynamic-extent proc apply-handler return-handler
- #:vm vm))
+ (define (return-handler frame depth . values)
+ (print-return depth width prefix max-indent values))
+ (trap-calls-in-dynamic-extent proc apply-handler return-handler))
-(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm))
+(define* (trace-instructions-in-procedure proc #:key (width 80)
(max-indent (- width 40)))
(define (trace-next frame)
- (let* ((ip (frame-instruction-pointer frame))
- (objcode (program-objcode (frame-procedure frame)))
- (opcode (bytevector-u8-ref (objcode->bytecode objcode)
- (+ ip *objcode-header-len*))))
- (format #t "~8d: ~a\n" ip (opcode->instruction opcode))))
+ ;; FIXME: We could disassemble this instruction here.
+ (let ((ip (frame-instruction-pointer frame)))
+ (format #t "0x~x\n" ip)))
- (trap-instructions-in-dynamic-extent proc trace-next
- #:vm vm))
+ (trap-instructions-in-dynamic-extent proc trace-next))
;; Note that because this procedure manipulates the VM trace level
;; directly, it doesn't compose well with traps at the REPL.
;;
(define* (call-with-trace thunk #:key (calls? #t) (instructions? #f)
- (width 80) (vm (the-vm)) (max-indent (- width 40)))
+ (width 80) (max-indent (- width 40)))
(let ((call-trap #f)
(inst-trap #f))
(dynamic-wind
(lambda ()
(if calls?
(set! call-trap
- (trace-calls-in-procedure thunk #:vm vm #:width width
+ (trace-calls-in-procedure thunk #:width width
#:max-indent max-indent)))
(if instructions?
(set! inst-trap
- (trace-instructions-in-procedure thunk #:vm vm #:width width
+ (trace-instructions-in-procedure thunk #:width width
#:max-indent max-indent)))
- (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
+ (set-vm-trace-level! (1+ (vm-trace-level))))
thunk
(lambda ()
- (set-vm-trace-level! vm (1- (vm-trace-level vm)))
+ (set-vm-trace-level! (1- (vm-trace-level)))
(if call-trap (call-trap))
(if inst-trap (inst-trap))
(set! call-trap #f)
;;; trap-state.scm: a set of traps
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2013 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
;;;
-;;; VM-local trap states
+;;; Per-thread trap states
;;;
-(define *trap-states* (make-weak-key-hash-table))
+;; FIXME: This should be thread-local -- not something you can inherit
+;; from a dynamic state.
-(define (trap-state-for-vm vm)
- (or (hashq-ref *trap-states* vm)
- (let ((ts (make-trap-state)))
- (hashq-set! *trap-states* vm ts)
- (trap-state-for-vm vm))))
+(define %trap-state (make-parameter #f))
(define (the-trap-state)
- (trap-state-for-vm (the-vm)))
+ (or (%trap-state)
+ (let ((ts (make-trap-state)))
+ (%trap-state ts)
+ ts)))
\f
(lambda ()
;; Don't enable hooks if the handler is #f.
(if handler
- (set-vm-trace-level! (the-vm) (trap-state->trace-level trap-state))))
+ (set-vm-trace-level! (trap-state->trace-level trap-state))))
thunk
(lambda ()
(if handler
- (set-vm-trace-level! (the-vm) 0))))))
+ (set-vm-trace-level! 0))))))
(define* (list-traps #:optional (trap-state (the-trap-state)))
(map trap-wrapper-index (trap-state-wrappers trap-state)))
(and (<= (frame-address f) fp)
(predicate f))))))
- (let* ((source (frame-next-source frame))
+ (let* ((source (frame-source frame))
(idx (next-ephemeral-index! trap-state))
(trap (trap-matching-instructions
(wrap-predicate-according-to-into
(if instruction?
(lambda (f) #t)
- (lambda (f) (not (equal? (frame-next-source f) source)))))
+ (lambda (f) (not (equal? (frame-source f) source)))))
(ephemeral-handler-for-index trap-state idx handler))))
(add-trap-wrapper!
trap-state
;;; Traps: stepping, breakpoints, and such.
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012, 2013, 2014 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 (system vm traps)
#:use-module (system base pmatch)
#:use-module (system vm vm)
+ #:use-module (system vm debug)
#:use-module (system vm frame)
#:use-module (system vm program)
- #:use-module (system vm objcode)
- #:use-module (system vm instruction)
#:use-module (system xref)
#:use-module (rnrs bytevectors)
#:export (trap-at-procedure-call
(if (not (predicate? arg))
(error "bad argument ~a: expected ~a" 'arg 'predicate?)))))
-(define (new-disabled-trap vm enable disable)
+(define (new-disabled-trap enable disable)
(let ((enabled? #f))
(define-syntax disabled?
(identifier-syntax
enable-trap))
-(define (new-enabled-trap vm frame enable disable)
- ((new-disabled-trap vm enable disable) frame))
+(define (new-enabled-trap frame enable disable)
+ ((new-disabled-trap enable disable) frame))
-(define (frame-matcher proc match-objcode?)
+;; Returns an absolute IP.
+(define (program-last-ip prog)
+ (let ((pdi (find-program-debug-info (program-code prog))))
+ (and pdi (program-debug-info-size pdi))))
+
+(define (frame-matcher proc match-code?)
(let ((proc (if (struct? proc)
(procedure proc)
proc)))
- (if match-objcode?
- (lambda (frame)
- (let ((frame-proc (frame-procedure frame)))
- (or (eq? frame-proc proc)
- (and (program? frame-proc)
- (eq? (program-objcode frame-proc)
- (program-objcode proc))))))
+ (if match-code?
+ (if (program? proc)
+ (let ((start (program-code proc))
+ (end (program-last-ip proc)))
+ (lambda (frame)
+ (let ((ip (frame-instruction-pointer frame)))
+ (and (<= start ip) (< ip end)))))
+ (lambda (frame) #f))
(lambda (frame)
(eq? (frame-procedure frame) proc)))))
;; A basic trap, fires when a procedure is called.
;;
-(define* (trap-at-procedure-call proc handler #:key (vm (the-vm))
- (closure? #f)
+(define* (trap-at-procedure-call proc handler #:key (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check handler procedure?)
(handler frame)))
(new-enabled-trap
- vm #f
+ #f
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook))
+ (add-hook! (vm-apply-hook) apply-hook))
(lambda (frame)
- (remove-hook! (vm-apply-hook vm) apply-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)))))
;; A more complicated trap, traps when control enters a procedure.
;;
;; * An abort.
;;
(define* (trap-in-procedure proc enter-handler exit-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
(if (our-frame? frame)
(enter-proc frame)))
- (define (push-cont-hook frame)
- (if in-proc?
- (exit-proc frame)))
-
- (define (pop-cont-hook frame)
- (if in-proc?
- (exit-proc frame))
- (if (our-frame? (frame-previous frame))
- (enter-proc (frame-previous frame))))
-
- (define (abort-hook frame)
+ (define (pop-cont-hook frame . values)
(if in-proc?
(exit-proc frame))
(if (our-frame? frame)
(enter-proc frame)))
- (define (restore-hook frame)
+ (define (abort-hook frame . values)
(if in-proc?
(exit-proc frame))
(if (our-frame? frame)
(enter-proc frame)))
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook)
- (add-hook! (vm-push-continuation-hook vm) push-cont-hook)
- (add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (add-hook! (vm-abort-continuation-hook vm) abort-hook)
- (add-hook! (vm-restore-continuation-hook vm) restore-hook)
+ (add-hook! (vm-apply-hook) apply-hook)
+ (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (add-hook! (vm-abort-continuation-hook) abort-hook)
(if (and frame (our-frame? frame))
(enter-proc frame)))
(lambda (frame)
(if in-proc?
(exit-proc frame))
- (remove-hook! (vm-apply-hook vm) apply-hook)
- (remove-hook! (vm-push-continuation-hook vm) push-cont-hook)
- (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
- (remove-hook! (vm-restore-continuation-hook vm) restore-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)
+ (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (remove-hook! (vm-abort-continuation-hook) abort-hook)))))
;; Building on trap-in-procedure, we have trap-instructions-in-procedure
;;
(define* (trap-instructions-in-procedure proc next-handler exit-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
(next-handler frame)))
(define (enter frame)
- (add-hook! (vm-next-hook vm) next-hook)
+ (add-hook! (vm-next-hook) next-hook)
(if frame (next-hook frame)))
(define (exit frame)
(exit-handler frame)
- (remove-hook! (vm-next-hook vm) next-hook))
+ (remove-hook! (vm-next-hook) next-hook))
(trap-in-procedure proc enter exit
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
(define (non-negative-integer? x)
;; trap-at-procedure-ip-in-range.
;;
(define* (trap-at-procedure-ip-in-range proc range handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
(set! fp-stack (cdr fp-stack))))
(trap-instructions-in-procedure proc next-handler exit-handler
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
-;; FIXME: define this in objcode somehow. We are reffing the first
-;; uint32 in the objcode, which is the length of the program (without
-;; the meta).
-(define (program-last-ip prog)
- (bytevector-u32-native-ref (objcode->bytecode (program-objcode prog)) 0))
-
(define (program-sources-by-line proc file)
- (let lp ((sources (program-sources-pre-retire proc))
- (out '()))
- (if (pair? sources)
- (lp (cdr sources)
- (pmatch (car sources)
- ((,start-ip ,start-file ,start-line . ,start-col)
- (if (equal? start-file file)
- (cons (cons start-line
- (if (pair? (cdr sources))
- (pmatch (cadr sources)
- ((,end-ip . _)
- (cons start-ip end-ip))
- (else (error "unexpected")))
- (cons start-ip (program-last-ip proc))))
- out)
- out))
- (else (error "unexpected"))))
- (let ((alist '()))
- (for-each
- (lambda (pair)
- (set! alist
- (assv-set! alist (car pair)
- (cons (cdr pair)
- (or (assv-ref alist (car pair))
- '())))))
- out)
- (sort! alist (lambda (x y) (< (car x) (car y))))
- alist))))
+ (cond
+ ((program? proc)
+ (let ((code (program-code proc)))
+ (let lp ((sources (program-sources proc))
+ (out '()))
+ (if (pair? sources)
+ (lp (cdr sources)
+ (pmatch (car sources)
+ ((,start-ip ,start-file ,start-line . ,start-col)
+ (if (equal? start-file file)
+ (acons start-line
+ (if (pair? (cdr sources))
+ (pmatch (cadr sources)
+ ((,end-ip . _)
+ (cons (+ start-ip code)
+ (+ end-ip code)))
+ (else (error "unexpected")))
+ (cons (+ start-ip code)
+ (program-last-ip proc)))
+ out)
+ out))
+ (else (error "unexpected"))))
+ (let ((alist '()))
+ (for-each
+ (lambda (pair)
+ (set! alist
+ (assv-set! alist (car pair)
+ (cons (cdr pair)
+ (or (assv-ref alist (car pair))
+ '())))))
+ out)
+ (sort! alist (lambda (x y) (< (car x) (car y))))
+ alist)))))
+ (else '())))
(define (source->ip-range proc file line)
(or (or-map (lambda (line-and-ranges)
;; trap-at-source-location. The parameter `user-line' is one-indexed, as
;; a user counts lines, instead of zero-indexed, as Guile counts lines.
;;
-(define* (trap-at-source-location file user-line handler
- #:key current-frame (vm (the-vm)))
+(define* (trap-at-source-location file user-line handler #:key current-frame)
(arg-check file string?)
(arg-check user-line positive-integer?)
(arg-check handler procedure?)
(lambda () (source-closures-or-procedures file (1- user-line)))
(lambda (procs closures?)
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
(set! traps
(map
(let ((range (source->ip-range proc file (1- user-line))))
(trap-at-procedure-ip-in-range proc range handler
#:current-frame current-frame
- #:vm vm
#:closure? closures?)))
procs))
(if (null? traps)
;; do useful things during the dynamic extent of a procedure's
;; application. First, a trap for when a frame returns.
;;
-(define* (trap-frame-finish frame return-handler abort-handler
- #:key (vm (the-vm)))
+(define (trap-frame-finish frame return-handler abort-handler)
(arg-check frame frame?)
(arg-check return-handler procedure?)
(arg-check abort-handler procedure?)
(let ((fp (frame-address frame)))
- (define (pop-cont-hook frame)
- (if (and fp (eq? (frame-address frame) fp))
+ (define (pop-cont-hook frame . values)
+ (if (and fp (< (frame-address frame) fp))
(begin
(set! fp #f)
- (return-handler frame))))
+ (apply return-handler frame values))))
- (define (abort-hook frame)
+ (define (abort-hook frame . values)
(if (and fp (< (frame-address frame) fp))
(begin
(set! fp #f)
- (abort-handler frame))))
+ (apply abort-handler frame values))))
(new-enabled-trap
- vm frame
+ frame
(lambda (frame)
(if (not fp)
(error "return-or-abort traps may only be enabled once"))
- (add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (add-hook! (vm-abort-continuation-hook vm) abort-hook)
- (add-hook! (vm-restore-continuation-hook vm) abort-hook))
+ (add-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (add-hook! (vm-abort-continuation-hook) abort-hook))
(lambda (frame)
(set! fp #f)
- (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
- (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
- (remove-hook! (vm-restore-continuation-hook vm) abort-hook)))))
+ (remove-hook! (vm-pop-continuation-hook) pop-cont-hook)
+ (remove-hook! (vm-abort-continuation-hook) abort-hook)))))
;; A more traditional dynamic-wind trap. Perhaps this should not be
;; based on the above trap-frame-finish?
;;
(define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
(arg-check return-handler procedure?)
(arg-check abort-handler procedure?)
(let ((exit-trap #f))
- (define (return-hook frame)
+ (define (return-hook frame . values)
(exit-trap frame) ; disable the return/abort trap.
(set! exit-trap #f)
(return-handler frame))
- (define (abort-hook frame)
+ (define (abort-hook frame . values)
(exit-trap frame) ; disable the return/abort trap.
(set! exit-trap #f)
(abort-handler frame))
(begin
(enter-handler frame)
(set! exit-trap
- (trap-frame-finish frame return-hook abort-hook
- #:vm vm)))))
+ (trap-frame-finish frame return-hook abort-hook)))))
(new-enabled-trap
- vm current-frame
+ current-frame
(lambda (frame)
- (add-hook! (vm-apply-hook vm) apply-hook))
+ (add-hook! (vm-apply-hook) apply-hook))
(lambda (frame)
(if exit-trap
(abort-hook frame))
(set! exit-trap #f)
- (remove-hook! (vm-apply-hook vm) apply-hook)))))
+ (remove-hook! (vm-apply-hook) apply-hook)))))
;; Trapping all procedure calls within a dynamic extent, recording the
;; depth of the call stack relative to the original procedure.
;;
(define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
(define (trace-push frame)
(set! *call-depth* (1+ *call-depth*)))
- (define (trace-pop frame)
- (return-handler frame *call-depth*)
+ (define (trace-pop frame . values)
+ (apply return-handler frame *call-depth* values)
(set! *call-depth* (1- *call-depth*)))
(define (trace-apply frame)
;; FIXME: recalc depth on abort
(define (enter frame)
- (add-hook! (vm-push-continuation-hook vm) trace-push)
- (add-hook! (vm-pop-continuation-hook vm) trace-pop)
- (add-hook! (vm-apply-hook vm) trace-apply))
+ (add-hook! (vm-push-continuation-hook) trace-push)
+ (add-hook! (vm-pop-continuation-hook) trace-pop)
+ (add-hook! (vm-apply-hook) trace-apply))
(define (leave frame)
- (remove-hook! (vm-push-continuation-hook vm) trace-push)
- (remove-hook! (vm-pop-continuation-hook vm) trace-pop)
- (remove-hook! (vm-apply-hook vm) trace-apply))
+ (remove-hook! (vm-push-continuation-hook) trace-push)
+ (remove-hook! (vm-pop-continuation-hook) trace-pop)
+ (remove-hook! (vm-apply-hook) trace-apply))
(define (return frame)
(leave frame))
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
;; Trapping all retired intructions within a dynamic extent.
;;
(define* (trap-instructions-in-dynamic-extent proc next-handler
- #:key current-frame (vm (the-vm))
- (closure? #f)
+ #:key current-frame (closure? #f)
(our-frame?
(frame-matcher proc closure?)))
(arg-check proc procedure?)
(next-handler frame))
(define (enter frame)
- (add-hook! (vm-next-hook vm) trace-next))
+ (add-hook! (vm-next-hook) trace-next))
(define (leave frame)
- (remove-hook! (vm-next-hook vm) trace-next))
+ (remove-hook! (vm-next-hook) trace-next))
(define (return frame)
(leave frame))
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm
+ #:current-frame current-frame
#:our-frame? our-frame?)))
;; Traps calls and returns for a given procedure, keeping track of the call depth.
;;
-(define* (trap-calls-to-procedure proc apply-handler return-handler
- #:key (vm (the-vm)))
+(define (trap-calls-to-procedure proc apply-handler return-handler)
(arg-check proc procedure?)
(arg-check apply-handler procedure?)
(arg-check return-handler procedure?)
(apply-handler frame depth)
- (if (not (eq? (frame-address frame) last-fp))
+ (if (not (eqv? (frame-address frame) last-fp))
(let ((finish-trap #f))
(define (frame-finished frame)
(finish-trap frame) ;; disables the trap.
(delq finish-trap pending-finish-traps))
(set! finish-trap #f))
- (define (return-hook frame)
+ (define (return-hook frame . values)
(frame-finished frame)
- (return-handler frame depth))
+ (apply return-handler frame depth values))
;; FIXME: abort handler?
- (define (abort-hook frame)
+ (define (abort-hook frame . values)
(frame-finished frame))
(set! finish-trap
- (trap-frame-finish frame return-hook abort-hook #:vm vm))
+ (trap-frame-finish frame return-hook abort-hook))
(set! pending-finish-traps
(cons finish-trap pending-finish-traps))))))
(with-pending-finish-enablers (trap frame))))
(with-pending-finish-disablers
- (trap-at-procedure-call proc apply-hook #:vm vm))))
+ (trap-at-procedure-call proc apply-hook))))
;; Trap when the source location changes.
;;
-(define* (trap-matching-instructions frame-pred handler
- #:key (vm (the-vm)))
+(define (trap-matching-instructions frame-pred handler)
(arg-check frame-pred procedure?)
(arg-check handler procedure?)
(let ()
(handler frame)))
(new-enabled-trap
- vm #f
+ #f
(lambda (frame)
- (add-hook! (vm-next-hook vm) next-hook))
+ (add-hook! (vm-next-hook) next-hook))
(lambda (frame)
- (remove-hook! (vm-next-hook vm) next-hook)))))
+ (remove-hook! (vm-next-hook) next-hook)))))
;;; Guile VM core
-;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2013, 2014 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 (system vm vm)
- #:export (vm?
- make-vm the-vm call-with-vm
- vm:ip vm:sp vm:fp
-
+ #:export (call-with-vm
+ call-with-stack-overflow-handler
vm-trace-level set-vm-trace-level!
vm-engine set-vm-engine! set-default-vm-engine!
vm-push-continuation-hook vm-pop-continuation-hook
vm-apply-hook
vm-next-hook
- vm-abort-continuation-hook vm-restore-continuation-hook))
+ vm-abort-continuation-hook))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_vm")
-;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2013 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
(define-module (system xref)
- #:use-module (system base pmatch)
#:use-module (system base compile)
#:use-module (system vm program)
+ #:use-module (system vm disassembler)
+ #:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (*xref-ignored-modules*
procedure-callees
;;; The cross-reference database: who calls whom.
;;;
+(define (nested-procedures prog)
+ (define (cons-uniq x y)
+ (if (memq x y) y (cons x y)))
+ (if (program? prog)
+ (reverse
+ (fold-program-code (lambda (elt out)
+ (match elt
+ (('static-ref dst proc)
+ (if (program? proc)
+ (fold cons-uniq
+ (cons proc out)
+ (nested-procedures prog))
+ out))
+ (_ out)))
+ (list prog)
+ prog))
+ (list prog)))
+
(define (program-callee-rev-vars prog)
(define (cons-uniq x y)
(if (memq x y) y (cons x y)))
- (cond
- ((program-objects prog)
- => (lambda (objects)
- (let ((n (vector-length objects))
- (progv (make-vector (vector-length objects) #f))
- (asm (decompile (program-objcode prog) #:to 'assembly)))
- (pmatch asm
- ((load-program ,labels ,len . ,body)
- (for-each
- (lambda (x)
- (pmatch x
- ((toplevel-ref ,n) (vector-set! progv n #t))
- ((toplevel-set ,n) (vector-set! progv n #t))))
- body)))
- (let lp ((i 0) (out '()))
- (cond
- ((= i n) out)
- ((program? (vector-ref objects i))
- (lp (1+ i)
- (fold cons-uniq out
- (program-callee-rev-vars (vector-ref objects i)))))
- ((vector-ref progv i)
- (let ((obj (vector-ref objects i)))
- (if (variable? obj)
- (lp (1+ i) (cons-uniq obj out))
- ;; otherwise it's an unmemoized binding
- (pmatch obj
- (,sym (guard (symbol? sym))
- (let ((v (module-variable (or (program-module prog)
- the-root-module)
- sym)))
- (lp (1+ i) (if v (cons-uniq v out) out))))
- ((,mod ,sym ,public?)
- ;; hm, hacky.
- (let* ((m (nested-ref-module (resolve-module '() #f)
- mod))
- (v (and m
- (module-variable
- (if public?
- (module-public-interface m)
- m)
- sym))))
- (lp (1+ i)
- (if v (cons-uniq v out) out))))))))
- (else (lp (1+ i) out)))))))
- (else '())))
+ (fold (lambda (prog out)
+ (fold-program-code
+ (lambda (elt out)
+ (match elt
+ (('toplevel-box dst var mod sym bound?)
+ (let ((var (or var (and mod (module-variable mod sym)))))
+ (if var
+ (cons-uniq var out)
+ out)))
+ (('module-box dst var public? mod-name sym bound?)
+ (let ((var (or var
+ (module-variable (if public?
+ (resolve-interface mod-name)
+ (resolve-module mod-name))
+ sym))))
+ (if var
+ (cons-uniq var out)
+ out)))
+ (_ out)))
+ out
+ prog))
+ '()
+ (nested-procedures prog)))
(define (procedure-callee-rev-vars proc)
(cond
(let ((v (cond ((variable? var) var)
((symbol? var) (module-variable (current-module) var))
(else
- (pmatch var
- ((,modname . ,sym)
+ (match var
+ ((modname . sym)
(module-variable (resolve-module modname) sym))
- (else
+ (_
(error "expected a variable, symbol, or (modname . sym)" var)))))))
(untaint-modules)
(hashq-ref *callers-db* v '())))
sources)
;; Actually add the source entries.
(for-each (lambda (source)
- (pmatch source
- ((,ip ,file ,line . ,col)
+ (match source
+ ((ip file line . col)
(add-source proc file line db))
- (else (error "unexpected source format" source))))
+ (_ (error "unexpected source format" source))))
sources)))
;; Add source entries for nested procedures.
(for-each (lambda (obj)
- (if (procedure? obj)
- (add-sources obj mod-name *closure-sources-db*)))
- (or (and (program? proc)
- (and=> (program-objects proc) vector->list))
- '()))))
+ (add-sources obj mod-name *closure-sources-db*))
+ (cdr (nested-procedures proc)))))
(define (forget-sources proc mod-name db)
(let ((mod-table (hash-ref *module-sources-db* mod-name)))
- (if mod-table
- (begin
- ;; Forget source entries.
- (for-each (lambda (source)
- (pmatch source
- ((,ip ,file ,line . ,col)
- (forget-source proc file line db))
- (else (error "unexpected source format" source))))
- (hashq-ref mod-table proc '()))
- ;; Forget the proc.
- (hashq-remove! mod-table proc)
- ;; Forget source entries for nested procedures.
- (for-each (lambda (obj)
- (if (procedure? obj)
- (forget-sources obj mod-name *closure-sources-db*)))
- (or (and (program? proc)
- (and=> (program-objects proc) vector->list))
- '()))))))
+ (when mod-table
+ ;; Forget source entries.
+ (for-each (lambda (source)
+ (match source
+ ((ip file line . col)
+ (forget-source proc file line db))
+ (_ (error "unexpected source format" source))))
+ (hashq-ref mod-table proc '()))
+ ;; Forget the proc.
+ (hashq-remove! mod-table proc)
+ ;; Forget source entries for nested procedures.
+ (for-each (lambda (obj)
+ (forget-sources obj mod-name *closure-sources-db*))
+ (cdr (nested-procedures proc))))))
(define (untaint-sources)
(define (untaint m)
(pxref INLINE-TEXT-ARGS
. (node #:opt name section info-file manual))
(url ALIAS . uref)
- (uref INLINE-ARGS . (url #:opt title replacement))
+ (uref INLINE-TEXT-ARGS . (url #:opt title replacement))
(anchor INLINE-ARGS . (name))
(dots INLINE-ARGS . ())
(result INLINE-ARGS . ())
(delete-duplicates
(getaddrinfo (uri-host uri)
(cond (port => number->string)
- (else (symbol->string (uri-scheme uri))))
+ ((uri-scheme uri) => symbol->string)
+ (else (error "Not an absolute URI" uri)))
(if port
AI_NUMERICSERV
0))
(bad-request "Bad Request-Line: ~s" line))))
(define (write-uri uri port)
- (if (uri-host uri)
- (begin
- (display (uri-scheme uri) port)
- (display "://" port)
- (if (uri-userinfo uri)
- (begin
- (display (uri-userinfo uri) port)
- (display #\@ port)))
- (display (uri-host uri) port)
- (let ((p (uri-port uri)))
- (if (and p (not (eqv? p 80)))
- (begin
- (display #\: port)
- (display p port))))))
+ (when (uri-host uri)
+ (when (uri-scheme uri)
+ (display (uri-scheme uri) port)
+ (display #\: port))
+ (display "//" port)
+ (when (uri-userinfo uri)
+ (display (uri-userinfo uri) port)
+ (display #\@ port))
+ (display (uri-host uri) port)
+ (let ((p (uri-port uri)))
+ (when (and p (not (eqv? p 80)))
+ (display #\: port)
+ (display p port))))
(let* ((path (uri-path uri))
(len (string-length path)))
(cond
(bad-request "Empty path and no host for URI: ~s" uri))
(else
(display path port))))
- (if (uri-query uri)
- (begin
- (display #\? port)
- (display (uri-query uri) port))))
+ (when (uri-query uri)
+ (display #\? port)
+ (display (uri-query uri) port)))
(define (write-request-line method uri version port)
"Write the first line of an HTTP request to PORT."
(@@ (web uri) absolute-uri?)
write-uri))
-;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1)
-(define (declare-relative-uri-header! name)
+;; emacs: (put 'declare-uri-reference-header! 'scheme-indent-function 1)
+(define (declare-uri-reference-header! name)
(declare-header! name
(lambda (str)
- (or ((@@ (web uri) string->uri*) str)
+ (or (string->uri-reference str)
(bad-header-component 'uri str)))
uri?
write-uri))
;;
(declare-integer-header! "Content-Length")
-;; Content-Location = ( absoluteURI | relativeURI )
+;; Content-Location = URI-reference
;;
-(declare-relative-uri-header! "Content-Location")
+(declare-uri-reference-header! "Content-Location")
;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
;;
(display (cdr pair) port)))
",")))
-;; Referer = ( absoluteURI | relativeURI )
+;; Referer = URI-reference
;;
-(declare-relative-uri-header! "Referer")
+(declare-uri-reference-header! "Referer")
;; TE = #( t-codings )
;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
entity-tag?
write-entity-tag)
-;; Location = absoluteURI
+;; Location = URI-reference
+;;
+;; In RFC 2616, Location was specified as being an absolute URI. This
+;; was changed in RFC 7231 to permit URI references generally, which
+;; matches web reality.
;;
-(declare-uri-header! "Location")
+(declare-uri-reference-header! "Location")
;; Proxy-Authenticate = 1#challenge
;;
(define-request-accessor user-agent #f)
;; Misc accessors
-(define* (request-absolute-uri r #:optional default-host default-port)
+(define* (request-absolute-uri r #:optional default-host default-port
+ default-scheme)
"A helper routine to determine the absolute URI of a request, using the
‘host’ header and the default host and port."
(let ((uri (request-uri r)))
(bad-request
"URI not absolute, no Host header, and no default: ~s"
uri)))))
- (build-uri (uri-scheme uri)
+ (build-uri (or (uri-scheme uri)
+ default-scheme
+ (bad-request "URI not absolute and no default-port"
+ uri))
#:host (car host)
#:port (cdr host)
#:path (uri-path uri)
#:post-error (lambda _ (values #f #f #f))))
(define (extend-response r k v . additional)
+ (define (extend-alist alist k v)
+ (let ((pair (assq k alist)))
+ (acons k v (if pair (delq pair alist) alist))))
(let ((r (set-field r (response-headers)
- (assoc-set! (copy-tree (response-headers r))
- k v))))
+ (extend-alist (response-headers r) k v))))
(if (null? additional)
r
(apply extend-response r additional))))
;;;; (web uri) --- URI manipulation tools
;;;;
-;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013,2014 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
uri-path uri-query uri-fragment
build-uri
+ build-uri-reference
declare-default-port!
- string->uri uri->string
+ string->uri string->uri-reference
+ uri->string
uri-decode uri-encode
split-and-decode-uri-path
encode-and-join-uri-path))
(define (positive-exact-integer? port)
(and (number? port) (exact? port) (integer? port) (positive? port)))
-(define (validate-uri scheme userinfo host port path query fragment)
+(define* (validate-uri scheme userinfo host port path query fragment
+ #:key reference?)
(cond
- ((not (symbol? scheme))
+ ((and (not reference?) (not (symbol? scheme)))
(uri-error "Expected a symbol for the URI scheme: ~s" scheme))
((and (or userinfo port) (not host))
(uri-error "Expected a host, given userinfo or port"))
(define* (build-uri scheme #:key userinfo host port (path "") query fragment
(validate? #t))
- "Construct a URI object. SCHEME should be a symbol, PORT
-either a positive, exact integer or ‘#f’, and the rest of the
-fields are either strings or ‘#f’. If VALIDATE? is true,
-also run some consistency checks to make sure that the constructed URI
-is valid."
+ "Construct a URI object. SCHEME should be a symbol, PORT either a
+positive, exact integer or ‘#f’, and the rest of the fields are either
+strings or ‘#f’. If VALIDATE? is true, also run some consistency checks
+to make sure that the constructed object is a valid absolute URI."
(if validate?
(validate-uri scheme userinfo host port path query fragment))
(make-uri scheme userinfo host port path query fragment))
+(define* (build-uri-reference #:key scheme userinfo host port (path "") query
+ fragment (validate? #t))
+ "Construct a URI object. SCHEME should be a symbol or ‘#f’, PORT
+either a positive, exact integer or ‘#f’, and the rest of the fields
+are either strings or ‘#f’. If VALIDATE? is true, also run some
+consistency checks to make sure that the constructed URI is a valid URI
+reference (either an absolute URI or a relative reference)."
+ (if validate?
+ (validate-uri scheme userinfo host port path query fragment
+ #:reference? #t))
+ (make-uri scheme userinfo host port path query fragment))
+
;; See RFC 3986 #3.2.2 for comments on percent-encodings, IDNA (RFC
;; 3490), and non-ASCII host names.
;;
;;; / path-absolute
;;; / path-rootless
;;; / path-empty
+;;;
+;;; A URI-reference is the same as URI, but where the scheme is
+;;; optional. If the scheme is not present, its colon isn't present
+;;; either.
(define scheme-pat
"[a-zA-Z][a-zA-Z0-9+.-]*")
(define uri-regexp
(make-regexp uri-pat))
-(define (string->uri* string)
- "Parse STRING into a URI object. Return ‘#f’ if the string
-could not be parsed."
+(define (string->uri-reference string)
+ "Parse the URI reference written as STRING into a URI object. Return
+‘#f’ if the string could not be parsed."
(% (let ((m (regexp-exec uri-regexp string)))
(if (not m) (abort))
(let ((scheme (let ((str (match:substring m 2)))
(authority (match:substring m 3))
(path (match:substring m 4))
(query (match:substring m 6))
- (fragment (match:substring m 7)))
+ (fragment (match:substring m 8)))
(call-with-values
(lambda ()
(if authority
#f)))
(define (string->uri string)
- "Parse STRING into a URI object. Return ‘#f’ if the string
+ "Parse STRING into an absolute URI object. Return ‘#f’ if the string
could not be parsed."
- (let ((uri (string->uri* string)))
+ (let ((uri (string->uri-reference string)))
(and uri (uri-scheme uri) uri)))
(define *default-ports* (make-hash-table))
tests/and-let-star.test \
tests/arbiters.test \
tests/arrays.test \
- tests/asm-to-bytecode.test \
tests/bit-operations.test \
tests/bitvectors.test \
tests/brainfuck.test \
tests/control.test \
tests/continuations.test \
tests/coverage.test \
- tests/cse.test \
+ tests/cross-compilation.test \
tests/curried-definitions.test \
+ tests/dwarf.test \
tests/encoding-escapes.test \
tests/encoding-iso88591.test \
tests/encoding-iso88597.test \
tests/options.test \
tests/pairs.test \
tests/parameters.test \
+ tests/peg.test \
tests/peval.test \
tests/print.test \
tests/procprop.test \
tests/r6rs-unicode.test \
tests/rnrs-libraries.test \
tests/ramap.test \
+ tests/random.test \
tests/rdelim.test \
tests/reader.test \
tests/records.test \
tests/receive.test \
tests/regexp.test \
+ tests/rtl.test \
+ tests/rtl-compilation.test \
tests/session.test \
tests/signals.test \
tests/sort.test \
TESTS = $(LALR_TESTS)
TESTS_ENVIRONMENT = \
- GUILE_INSTALL_LOCALE=1 \
- GUILE_AUTO_COMPILE=0 \
@LOCALCHARSET_TESTS_ENVIRONMENT@ \
- $(top_builddir)/meta/guile
+ $(top_builddir)/meta/guile --no-auto-compile
EXTRA_DIST += $(LALR_EXTRA) $(LALR_TESTS) tests/sxml-match-tests.ss
srcdir="$(srcdir)" \
builddir="$(builddir)" \
@LOCALCHARSET_TESTS_ENVIRONMENT@ \
- GUILE_INSTALL_LOCALE=1 GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env"
+ GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env"
## Check for headers in $(srcdir) and build dir before $(CPPFLAGS), which
## may point us to an old, installed version of guile.
check_PROGRAMS += test-smob-mark
TESTS += test-smob-mark
+check_SCRIPTS += test-stack-overflow
+TESTS += test-stack-overflow
+
+check_SCRIPTS += test-out-of-memory
+TESTS += test-out-of-memory
+
EXTRA_DIST += ${check_SCRIPTS}
-/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010,
+/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010, 2011
* 2012, 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#include <stdio.h>
#include <assert.h>
+#include <limits.h>
SCM out_of_range_handler (void *data, SCM key, SCM args);
SCM call_num2long_long_body (void *data);
test_long_long ()
{
{
- SCM n = scm_from_long_long (SCM_I_LLONG_MIN);
+ SCM n = scm_from_long_long (LLONG_MIN);
long long result = scm_to_long_long(n);
- assert (result == SCM_I_LLONG_MIN);
+ assert (result == LLONG_MIN);
}
/* LLONG_MIN - 1 */
{
- SCM n = scm_difference (scm_from_long_long (SCM_I_LLONG_MIN), scm_from_int (1));
+ SCM n = scm_difference (scm_from_long_long (LLONG_MIN), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
/* SCM_I_LLONG_MIN + SCM_I_LLONG_MIN/2 */
{
- SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MIN),
- scm_from_long_long (SCM_I_LLONG_MIN / 2));
+ SCM n = scm_sum (scm_from_long_long (LLONG_MIN),
+ scm_from_long_long (LLONG_MIN / 2));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
/* SCM_I_LLONG_MAX + 1 */
{
- SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MAX), scm_from_int (1));
+ SCM n = scm_sum (scm_from_long_long (LLONG_MAX), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
test_ulong_long ()
{
{
- SCM n = scm_from_ulong_long (SCM_I_ULLONG_MAX);
+ SCM n = scm_from_ulong_long (ULLONG_MAX);
unsigned long long result = scm_to_ulong_long(n);
- assert (result == SCM_I_ULLONG_MAX);
+ assert (result == ULLONG_MAX);
}
/* -1 */
/* SCM_I_ULLONG_MAX + 1 */
{
- SCM n = scm_sum (scm_from_ulong_long (SCM_I_ULLONG_MAX), scm_from_int (1));
+ SCM n = scm_sum (scm_from_ulong_long (ULLONG_MAX), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
--- /dev/null
+#!/bin/sh
+guild compile "$0"
+exec guile -q -s "$0" "$@"
+!#
+
+(unless (defined? 'setrlimit)
+ ;; Without an rlimit, this test can take down your system, as it
+ ;; consumes all of your memory. That doesn't seem like something we
+ ;; should run as part of an automated test suite.
+ (exit 0))
+
+(catch #t
+ ;; Silence GC warnings.
+ (lambda ()
+ (current-warning-port (open-output-file "/dev/null")))
+ (lambda (k . args)
+ (print-exception (current-error-port) #f k args)
+ (write "Skipping test.\n" (current-error-port))
+ (exit 0)))
+
+;; 50 MB.
+(define *limit* (* 50 1024 1024))
+
+(call-with-values (lambda () (getrlimit 'as))
+ (lambda (soft hard)
+ (unless (and soft (< soft *limit*))
+ (setrlimit 'as (if hard (min *limit* hard) *limit*) hard))))
+
+(define (test thunk)
+ (catch 'out-of-memory
+ (lambda ()
+ (thunk)
+ (error "should not be reached"))
+ (lambda _
+ #t)))
+
+(use-modules (rnrs bytevectors))
+
+(test (lambda ()
+ ;; Unhappily, on 32-bit systems, vectors are limited to 16M
+ ;; elements. Boo. Anyway, a vector with 16M elements takes 64
+ ;; MB, which doesn't fit into 50 MB.
+ (make-vector (1- (ash 1 24)))))
+(test (lambda ()
+ ;; Likewise for a bytevector. This is different from the above,
+ ;; as the elements of a bytevector are not traced by GC.
+ (make-bytevector #e1e9)))
+(test (lambda ()
+ ;; This one is the kicker -- we allocate pairs until the heap
+ ;; can't expand. This is the hardest test to deal with because
+ ;; the error-handling machinery has no memory in which to work.
+ (iota #e1e8)))
+(test (lambda ()
+ ;; The same, but also causing allocating during the unwind
+ ;; (ouch!)
+ (dynamic-wind
+ (lambda () #t)
+ (lambda () (iota #e1e8))
+ (lambda () (iota #e1e8)))))
+
+;; Local Variables:
+;; mode: scheme
+;; End:
--- /dev/null
+#!/bin/sh
+guild compile "$0"
+exec guile -q -s "$0" "$@"
+!#
+
+(unless (defined? 'setrlimit)
+ ;; Without an rlimit, this test can take down your system, as it
+ ;; consumes all of your memory in stack space. That doesn't seem like
+ ;; something we should run as part of an automated test suite.
+ (exit 0))
+
+;; 100 MB.
+(define *limit* (* 100 1024 1024))
+
+(call-with-values (lambda () (getrlimit 'as))
+ (lambda (soft hard)
+ (unless (and soft (< soft *limit*))
+ (setrlimit 'as (if hard (min *limit* hard) *limit*) hard))))
+
+(define (test)
+ (catch 'stack-overflow
+ (lambda ()
+ (let lp ()
+ (lp)
+ (error "should not be reached")))
+ (lambda _
+ #t)))
+
+;; Run the test a few times. The stack will only be enlarged and
+;; relocated on the first one.
+(test)
+(test)
+(test)
+(test)
+(test)
+
+;; Local Variables:
+;; mode: scheme
+;; End:
;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite lib)
- #:use-module (ice-9 stack-catch)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 match)
#:autoload (srfi srfi-1) (append-map)
#:autoload (system base compile) (compile)
#:export (
;;; A helper function to implement the macros that test for exceptions.
(define (run-test-exception name exception expect-pass thunk)
- (run-test name expect-pass
- (lambda ()
- (stack-catch (car exception)
- (lambda () (thunk) #f)
- (lambda (key proc message . rest)
- (cond
- ;; handle explicit key
- ((string-match (cdr exception) message)
- #t)
- ;; handle `(error ...)' which uses `misc-error' for key and doesn't
- ;; yet format the message and args (we have to do it here).
- ((and (eq? 'misc-error (car exception))
- (list? rest)
- (string-match (cdr exception)
- (apply simple-format #f message (car rest))))
- #t)
- ;; handle syntax errors which use `syntax-error' for key and don't
- ;; yet format the message and args (we have to do it here).
- ((and (eq? 'syntax-error (car exception))
- (list? rest)
- (string-match (cdr exception)
- (apply simple-format #f message (car rest))))
- #t)
- ;; unhandled; throw again
- (else
- (apply throw key proc message rest))))))))
+ (match exception
+ ((expected-key . expected-pattern)
+ (run-test
+ name
+ expect-pass
+ (lambda ()
+ (catch expected-key
+ (lambda () (thunk) #f)
+ (lambda (key proc message . rest)
+ ;; Match the message against the expected pattern. If that
+ ;; doesn't work, in the case of `misc-error' and
+ ;; `syntax-error' we treat the message as a format string,
+ ;; and format it. This is pretty terrible but it's
+ ;; historical.
+ (or (and (string-match expected-pattern message) #t)
+ (and (memq expected-key '(misc-error syntax-error))
+ (list? rest)
+ (let ((out (apply simple-format #f message (car rest))))
+ (and (string-match expected-pattern out) #t)))
+ (apply throw key proc message rest)))))))))
;;; A short form for tests that expect a certain exception to be thrown.
(define-syntax pass-if-exception
;;;; Turn a test name into a nice human-readable string.
(define (format-test-name name)
- ;; Choose a Unicode-capable encoding so that the string port can contain any
- ;; valid Unicode character.
- (with-fluids ((%default-port-encoding "UTF-8"))
- (call-with-output-string
- (lambda (port)
- (let loop ((name name)
- (separator ""))
- (if (pair? name)
- (begin
- (display separator port)
- (display (car name) port)
- (loop (cdr name) ": "))))))))
+ (call-with-output-string
+ (lambda (port)
+ (let loop ((name name)
+ (separator ""))
+ (if (pair? name)
+ (begin
+ (display separator port)
+ (display (car name) port)
+ (loop (cdr name) ": ")))))))
;;;; For a given test-name, deliver the full name including all prefixes.
(define (full-name name)
(define-syntax c&e
(syntax-rules (pass-if pass-if-equal pass-if-exception)
"Run the given tests both with the evaluator and the compiler/VM."
+ ((_ (pass-if exp))
+ (c&e (pass-if "[unnamed test]" exp)))
((_ (pass-if test-name exp))
(begin (pass-if (string-append test-name " (eval)")
(primitive-eval 'exp))
-;;;; socket.test --- test socket functions -*- scheme -*-
+;;;; 00-socket.test --- test socket functions -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-;;;; 2011, 2013, 2014 Free Software Foundation, Inc.
+;;;; 2011, 2012, 2013, 2014 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 along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;; This test runs early, so that we can fork before any threads are
+;; created in other tests.
+
(define-module (test-suite test-socket)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-26)
-;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
+;;;; arrays.test --- tests guile's uniform arrays -*- scheme -*-
;;;;
;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
;;;;
;;;; 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
(pass-if (eq? #f (typed-array? float #t)))
(pass-if (eq? #f (typed-array? double #t)))
(pass-if (eq? #f (typed-array? complex #t)))
- (pass-if (eq? #t (typed-array? scm #t))))))
+ (pass-if (eq? #t (typed-array? scm #t))))
+
+ (with-test-prefix "typed-array? returns #f"
+ (pass-if (eq? #f (typed-array? '(1 2 3) 'c64)))
+ (pass-if (eq? #f (typed-array? '(1 2 3) #t)))
+ (pass-if (eq? #f (typed-array? 99 'c64)))
+ (pass-if (eq? #f (typed-array? 99 #t))))))
;;;
;;; array-equal?
;;;
-(with-test-prefix "array-equal?"
+(with-test-prefix/c&e "array-equal?"
(pass-if "#s16(...)"
(array-equal? #s16(1 2 3) #s16(1 2 3))))
+;;;
+;;; make-shared-array
+;;;
+
+(define exception:mapping-out-of-range
+ (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
+
+(with-test-prefix/c&e "make-shared-array"
+
+ ;; this failed in guile 1.8.0
+ (pass-if "vector unchanged"
+ (let* ((a (make-array #f '(0 7)))
+ (s (make-shared-array a list '(0 7))))
+ (array-equal? a s)))
+
+ (pass-if-exception "vector, high too big" exception:mapping-out-of-range
+ (let* ((a (make-array #f '(0 7))))
+ (make-shared-array a list '(0 8))))
+
+ (pass-if-exception "vector, low too big" exception:out-of-range
+ (let* ((a (make-array #f '(0 7))))
+ (make-shared-array a list '(-1 7))))
+
+ (pass-if "truncate columns"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
+ #2((a b) (d e) (g h))))
+
+ (pass-if "pick one column"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i 2))
+ '(0 2))
+ #(c f i)))
+
+ (pass-if "diagonal"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i i))
+ '(0 2))
+ #(a e i)))
+
+ ;; this failed in guile 1.8.0
+ (pass-if "2 dims from 1 dim"
+ (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i j) (list (+ (* i 3) j)))
+ 4 3)
+ #2((a b c) (d e f) (g h i) (j k l))))
+
+ (pass-if "reverse columns"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i j) (list i (- 2 j)))
+ 3 3)
+ #2((c b a) (f e d) (i h g))))
+
+ (pass-if "fixed offset, 0 based becomes 1 based"
+ (let* ((x #2((a b c) (d e f) (g h i)))
+ (y (make-shared-array x
+ (lambda (i j) (list (1- i) (1- j)))
+ '(1 3) '(1 3))))
+ (and (eq? (array-ref x 0 0) 'a)
+ (eq? (array-ref y 1 1) 'a))))
+
+ ;; this failed in guile 1.8.0
+ (pass-if "stride every third element"
+ (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i) (list (* i 3)))
+ 4)
+ #1(a d g j)))
+
+ (pass-if "shared of shared"
+ (let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
+ (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
+ (s2 (make-shared-array s1 list '(1 2))))
+ (and (eqv? 5 (array-ref s2 1))
+ (eqv? 8 (array-ref s2 2))))))
+
+;;;
+;;; array-contents
+;;;
+
+(define (every-two x) (make-shared-array x (lambda (i) (list (* i 2))) 2))
+
+(with-test-prefix/c&e "array-contents"
+
+ (pass-if "simple vector"
+ (let* ((a (make-array 0 4)))
+ (eq? a (array-contents a))))
+
+ (pass-if "offset vector"
+ (let* ((a (make-array 0 '(1 4))))
+ (array-copy! #(1 2 3 4) (array-contents a))
+ (array-equal? #1@1(1 2 3 4) a)))
+
+ (pass-if "offset vector, strict"
+ (let* ((a (make-array 0 '(1 4))))
+ (array-copy! #(1 2 3 4) (array-contents a #t))
+ (array-equal? #1@1(1 2 3 4) a)))
+
+ (pass-if "stepped vector"
+ (let* ((a (make-array 0 4)))
+ (array-copy! #(99 66) (array-contents (every-two a)))
+ (array-equal? #(99 0 66 0) a)))
+
+ ;; this failed in 2.0.9.
+ (pass-if "stepped vector, strict"
+ (let* ((a (make-array 0 4)))
+ (not (array-contents (every-two a) #t))))
+
+ (pass-if "plain rank 2 array"
+ (let* ((a (make-array 0 2 2)))
+ (array-copy! #(1 2 3 4) (array-contents a #t))
+ (array-equal? #2((1 2) (3 4)) a)))
+
+ (pass-if "offset rank 2 array"
+ (let* ((a (make-array 0 '(1 2) '(1 2))))
+ (array-copy! #(1 2 3 4) (array-contents a #t))
+ (array-equal? #2@1@1((1 2) (3 4)) a)))
+
+ (pass-if "transposed rank 2 array"
+ (let* ((a (make-array 0 4 4)))
+ (not (array-contents (transpose-array a 1 0) #t))))
+
+ ;; This is a consequence of (array-contents? a #t) => #t.
+ (pass-if "empty array"
+ (let ((a (make-typed-array 'f64 2 0 0)))
+ (f64vector? (array-contents a))))
+
+ (pass-if "broadcast vector I"
+ (let* ((a (make-array 0 4))
+ (b (make-shared-array a (lambda (i j k) (list k)) 1 1 4)))
+ (array-copy! #(1 2 3 4) (array-contents b #t))
+ (array-equal? #(1 2 3 4) a)))
+
+ (pass-if "broadcast vector II"
+ (let* ((a (make-array 0 4))
+ (b (make-shared-array a (lambda (i j k) (list k)) 2 1 4)))
+ (not (array-contents b))))
+
+ ;; FIXME maybe this should be allowed.
+ ;; (pass-if "broadcast vector -> empty"
+ ;; (let* ((a (make-array 0 4))
+ ;; (b (make-shared-array a (lambda (i j k) (list k)) 0 1 4)))
+ ;; (if #f #f)))
+
+ (pass-if "broadcast 2-rank I"
+ (let* ((a #2((1 2 3) (4 5 6)))
+ (b (make-shared-array a (lambda (i j) (list 0 j)) 2 3)))
+ (not (array-contents b))))
+
+ (pass-if "broadcast 2-rank II"
+ (let* ((a #2((1 2 3) (4 5 6)))
+ (b (make-shared-array a (lambda (i j) (list i 0)) 2 3)))
+ (not (array-contents b))))
+
+ (pass-if "literal array"
+ (not (not (array-contents #2((1 2 3) (4 5 6)))))))
+
+
+;;;
+;;; shared-array-root
+;;;
+
+(define amap1 (lambda (i) (list (* 2 i))))
+(define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
+
+(with-test-prefix/c&e "shared-array-root"
+
+ (pass-if "plain vector"
+ (let* ((a (make-vector 4 0))
+ (b (make-shared-array a amap1 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "plain array rank 2"
+ (let* ((a (make-array 0 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "uniform array rank 2"
+ (let* ((a (make-typed-array 'c64 0 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "bit array rank 2"
+ (let* ((a (make-typed-array 'b #f 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
+
+;;;
+;;; transpose-array
+;;;
+
+; see strings.test.
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+(with-test-prefix/c&e "transpose-array"
+
+ (pass-if-exception "non array argument" exception:wrong-type-arg
+ (transpose-array 99))
+
+ (pass-if "rank 0"
+ (let* ((a #0(99))
+ (b (transpose-array a)))
+ (and (array-equal? a b)
+ (eq? (shared-array-root a) (shared-array-root b)))))
+
+ (pass-if "rank 1"
+ (let* ((a #(1 2 3))
+ (b (transpose-array a 0)))
+ (and (array-equal? a b)
+ (eq? (shared-array-root a) (shared-array-root b)))))
+
+ (pass-if "rank 2"
+ (let* ((a #2((1 2 3) (4 5 6)))
+ (b (transpose-array a 1 0))
+ (c (transpose-array a 0 1)))
+ (and (array-equal? b #2((1 4) (2 5) (3 6)))
+ (array-equal? c a)
+ (eq? (shared-array-root a)
+ (shared-array-root b)
+ (shared-array-root c)))))
+
+ ; rank > 2 is needed to check against the inverted axis index logic.
+ (pass-if "rank 3"
+ (let* ((a #3(((0 1 2 3) (4 5 6 7) (8 9 10 11))
+ ((12 13 14 15) (16 17 18 19) (20 21 22 23))))
+ (b (transpose-array a 1 2 0)))
+ (and (array-equal? b #3(((0 4 8) (12 16 20)) ((1 5 9) (13 17 21))
+ ((2 6 10) (14 18 22)) ((3 7 11) (15 19 23))))
+ (eq? (shared-array-root a)
+ (shared-array-root b))))))
+
;;;
;;; array->list
;;;
-(with-test-prefix "array->list"
- (pass-if-equal '(1 2 3) (array->list #s16(1 2 3)))
- (pass-if-equal '(1 2 3) (array->list #(1 2 3)))
- (pass-if-equal '((1 2) (3 4) (5 6)) (array->list #2((1 2) (3 4) (5 6))))
- (pass-if-equal '() (array->list #()))
+(with-test-prefix/c&e "array->list"
+ (pass-if-equal "uniform vector" '(1 2 3) (array->list #s16(1 2 3)))
+ (pass-if-equal "vector" '(1 2 3) (array->list #(1 2 3)))
+ (pass-if-equal "rank 2 array" '((1 2) (3 4) (5 6)) (array->list #2((1 2) (3 4) (5 6))))
+ (pass-if-equal "empty vector" '() (array->list #()))
(pass-if-equal "http://bugs.gnu.org/12465 - ok"
'(3 4)
(and (equal? b #(9 9 9))
(equal? a #2((9 0 0) (0 9 0) (0 0 9))))))))
-;;;
-;;; array-copy!
-;;;
-
-(with-test-prefix "array-copy!"
-
- (pass-if "rank 2"
- (let ((a #2((1 2) (3 4)))
- (b (make-array 0 2 2))
- (c (make-array 0 2 2))
- (d (make-array 0 2 2))
- (e (make-array 0 2 2)))
- (array-copy! a b)
- (array-copy! a (transpose-array c 1 0))
- (array-copy! (transpose-array a 1 0) d)
- (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
- (and (equal? a #2((1 2) (3 4)))
- (equal? b #2((1 2) (3 4)))
- (equal? c #2((1 3) (2 4)))
- (equal? d #2((1 3) (2 4)))
- (equal? e #2((1 2) (3 4))))))
-
- (pass-if "rank 1"
- (let* ((a #2((1 2) (3 4)))
- (b (make-shared-array a (lambda (j) (list 1 j)) 2))
- (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
- (d (make-array 0 2))
- (e (make-array 0 2)))
- (array-copy! b d)
- (array-copy! c e)
- (and (equal? d #(3 4))
- (equal? e #(4 2)))))
-
- (pass-if "rank 0"
- (let ((a #0(99))
- (b (make-array 0)))
- (array-copy! a b)
- (equal? b #0(99)))))
-
-
;;;
;;; array-in-bounds?
;;;
-(with-test-prefix "array-in-bounds?"
+(with-test-prefix/c&e "array-in-bounds?"
(pass-if (let ((a (make-array #f '(425 425))))
(eq? #f (array-in-bounds? a 0)))))
(with-test-prefix "array-type"
- (with-test-prefix "on make-foo-vector"
+ (with-test-prefix/c&e "on make-foo-vector"
(pass-if "bool"
(eq? 'b (array-type (make-bitvector 1))))
(for-each (lambda (type)
(pass-if (symbol->string type)
(eq? type
- (array-type (make-typed-array type
- *unspecified*
+ (array-type (make-typed-array type
+ *unspecified*
'(5 6))))))
types))))
(array-set! a 'y 4 8 0)))))
;;;
-;;; make-shared-array
+;;; uniform-vector
;;;
-(define exception:mapping-out-of-range
- (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
-
-(with-test-prefix "make-shared-array"
-
- ;; this failed in guile 1.8.0
- (pass-if "vector unchanged"
- (let* ((a (make-array #f '(0 7)))
- (s (make-shared-array a list '(0 7))))
- (array-equal? a s)))
-
- (pass-if-exception "vector, high too big" exception:mapping-out-of-range
- (let* ((a (make-array #f '(0 7))))
- (make-shared-array a list '(0 8))))
-
- (pass-if-exception "vector, low too big" exception:out-of-range
- (let* ((a (make-array #f '(0 7))))
- (make-shared-array a list '(-1 7))))
+(with-test-prefix "typed arrays"
- (pass-if "truncate columns"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
- #2((a b) (d e) (g h))))
-
- (pass-if "pick one column"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i) (list i 2))
- '(0 2))
- #(c f i)))
-
- (pass-if "diagonal"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i) (list i i))
- '(0 2))
- #(a e i)))
-
- ;; this failed in guile 1.8.0
- (pass-if "2 dims from 1 dim"
- (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
- (lambda (i j) (list (+ (* i 3) j)))
- 4 3)
- #2((a b c) (d e f) (g h i) (j k l))))
-
- (pass-if "reverse columns"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i j) (list i (- 2 j)))
- 3 3)
- #2((c b a) (f e d) (i h g))))
-
- (pass-if "fixed offset, 0 based becomes 1 based"
- (let* ((x #2((a b c) (d e f) (g h i)))
- (y (make-shared-array x
- (lambda (i j) (list (1- i) (1- j)))
- '(1 3) '(1 3))))
- (and (eq? (array-ref x 0 0) 'a)
- (eq? (array-ref y 1 1) 'a))))
-
- ;; this failed in guile 1.8.0
- (pass-if "stride every third element"
- (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
- (lambda (i) (list (* i 3)))
- 4)
- #1(a d g j)))
-
- (pass-if "shared of shared"
- (let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
- (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
- (s2 (make-shared-array s1 list '(1 2))))
- (and (eqv? 5 (array-ref s2 1))
- (eqv? 8 (array-ref s2 2))))))
-
-;;;
-;;; typed array-ref
-;;;
-
-(with-test-prefix "typed array-ref"
-
- (with-test-prefix "byte"
+ (with-test-prefix "array-ref byte"
(let ((a (make-s8vector 1)))
(pass-if "-128"
(begin
(array-set! a -128 0)
- (= -128 (array-ref a 0)))))))
+ (= -128 (array-ref a 0))))))
+
+ (with-test-prefix "shared with rank 1 equality"
+
+ (let ((a #f64(1 2 3 4)))
+
+ (pass-if "change offset"
+ (let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3)))
+ (and (eq? (array-type b) (array-type a))
+ (= 3 (array-length b))
+ (array-equal? b #f64(2 3 4)))))
+
+ (pass-if "change stride"
+ (let ((c (make-shared-array a (lambda (i) (list (* i 2))) 2)))
+ (and (eq? (array-type c) (array-type a))
+ (= 2 (array-length c))
+ (array-equal? c #f64(1 3))))))))
;;;
;;; syntax
;;;
-(with-test-prefix "syntax"
+(with-test-prefix/c&e "syntax"
(pass-if "rank and lower bounds"
;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8.
(with-input-from-string "'#1:-3(#t #t)" read))
(pass-if "bitvector is self-evaluating"
- (equal? (compile (bitvector)) (bitvector))))
+ (equal? (compile (bitvector)) (bitvector)))
+
+ ; this failed in 2.0.9.
+ (pass-if "typed arrays that are not uniform arrays"
+ (let ((a #2b((#t #f) (#f #t)))
+ (b (make-typed-array 'b #f 2 2)))
+ (array-set! b #t 0 0)
+ (array-set! b #t 1 1)
+ (array-equal? a b))))
;;;
;;; equal? with vector and one-dimensional array
;;;
-(with-test-prefix "equal?"
+(with-test-prefix/c&e "equal?"
(pass-if "array and non-array"
(not (equal? #2f64((0 1) (2 3)) 100)))
;;; slices as generalized vectors
;;;
-(let ((array #2u32((0 1) (2 3))))
- (define (array-row a i)
- (make-shared-array a (lambda (j) (list i j))
- (cadr (array-dimensions a))))
- (with-test-prefix "generalized vector slices"
- (pass-if (equal? (array-row array 1)
- #u32(2 3)))
- (pass-if (equal? (array-ref (array-row array 1) 0)
- 2))))
+(define (array-row a i)
+ (make-shared-array a (lambda (j) (list i j))
+ (cadr (array-dimensions a))))
+
+(with-test-prefix/c&e "generalized vector slices"
+ (pass-if (equal? (array-row #2u32((0 1) (2 3)) 1)
+ #u32(2 3)))
+ (pass-if (equal? (array-ref (array-row #2u32((0 1) (2 3)) 1) 0)
+ 2)))
+++ /dev/null
-;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
-;;;;
-;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 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 (tests asm-to-bytecode)
- #:use-module (rnrs bytevectors)
- #:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
- #:use-module (test-suite lib)
- #:use-module (system vm instruction)
- #:use-module (system vm objcode)
- #:use-module (system base target)
- #:use-module (language assembly)
- #:use-module (language assembly compile-bytecode))
-
-(define (->u8-list sym val)
- (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
- (uint32 4 ,bytevector-u32-native-set!))
- sym)))
- (or entry (error "unknown sym" sym))
- (let ((bv (make-bytevector (car entry))))
- ((cadr entry) bv 0 val)
- (bytevector->u8-list bv))))
-
-(define (munge-bytecode v)
- (let lp ((i 0) (out '()))
- (if (= i (vector-length v))
- (u8-list->bytevector (reverse out))
- (let ((x (vector-ref v i)))
- (cond
- ((symbol? x)
- (lp (1+ i) (cons (instruction->opcode x) out)))
- ((integer? x)
- (lp (1+ i) (cons x out)))
- ((pair? x)
- (lp (1+ i) (append (reverse (apply ->u8-list x)) out)))
- (else (error "bad test bytecode" x)))))))
-
-(define (comp-test x y)
- (let* ((y (munge-bytecode y))
- (len (bytevector-length y))
- (v #f))
-
- (run-test `(length ,x) #t
- (lambda ()
- (let* ((wrapped `(load-program () ,(byte-length x) #f ,x))
- (bv (compile-bytecode wrapped '())))
- (set! v (make-bytevector (- (bytevector-length bv) 8)))
- (bytevector-copy! bv 8 v 0 (bytevector-length v))
- (= (bytevector-length v) len))))
- (run-test `(compile-equal? ,x ,y) #t
- (lambda ()
- (equal? v y)))))
-
-\f
-(with-test-prefix "compiler"
- (with-test-prefix "asm-to-bytecode"
-
- (comp-test '(make-int8 3)
- #(make-int8 3))
-
- (comp-test '(load-number "3.14")
- (vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.)
- (char->integer #\1) (char->integer #\4)))
-
- (comp-test '(load-string "foo")
- (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o)
- (char->integer #\o)))
-
- (comp-test '(load-symbol "foo")
- (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o)
- (char->integer #\o)))
-
- (comp-test '(load-string "æ") ;; a non-ASCII Latin-1 string
- (vector 'load-string 0 0 1 230))
-
- (comp-test '(load-wide-string "λ")
- (apply vector 'load-wide-string 0 0 4
- (if (eq? (native-endianness) (endianness little))
- '(187 3 0 0)
- '(0 0 3 187))))
-
- (comp-test '(load-program () 3 #f (make-int8 3) (return))
- #(load-program
- (uint32 3) ;; len
- (uint32 0) ;; metalen
- 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 () 8
- (load-program () 3
- #f
- (make-int8 3) (return))
- (make-int8 3) (return)
- (nop) (nop) (nop) (nop) (nop))
- #(load-program
- (uint32 8) ;; len
- (uint32 11) ;; metalen
- make-int8 3
- return
- nop nop nop nop nop
- (uint32 3) ;; len
- (uint32 0) ;; metalen
- make-int8 3
- return))))
-
-\f
-(define (test-triplet cpu vendor os)
- (let ((triplet (string-append cpu "-" vendor "-" os)))
- (pass-if (format #f "triplet ~a" triplet)
- (with-target triplet
- (lambda ()
- (and (string=? (target-cpu) cpu)
- (string=? (target-vendor) vendor)
- (string=? (target-os) os)))))))
-
-(define (native-cpu)
- (with-target %host-type target-cpu))
-
-(define (native-os)
- (with-target %host-type target-os))
-
-(define (native-word-size)
- ((@ (system foreign) sizeof) '*))
-
-(define %objcode-cookie-size
- (string-length "GOOF----LE-8-2.0"))
-
-(define (test-target triplet endian word-size)
- (pass-if (format #f "target `~a' honored" triplet)
- (call-with-values (lambda ()
- (open-bytevector-output-port))
- (lambda (p get-objcode)
- (with-target triplet
- (lambda ()
- (let ((word-size
- ;; When the target is the native CPU, rather trust
- ;; the native CPU's word size. This is because
- ;; Debian's `sparc64-linux-gnu' port, for instance,
- ;; actually has a 32-bit user-land, for instance (see
- ;; <http://www.debian.org/ports/sparc/#sparc64bit>
- ;; for details.)
- (if (and (string=? (native-cpu) (target-cpu))
- (string=? (native-os) (target-os)))
- (native-word-size)
- word-size))
- (b (compile-bytecode
- '(load-program () 16 #f
- (assert-nargs-ee/locals 1)
- (make-int8 77)
- (toplevel-ref 1)
- (local-ref 0)
- (mul)
- (add)
- (return)
- (nop) (nop) (nop)
- (nop) (nop))
- #f)))
- (write-objcode (bytecode->objcode b) p)
- (let ((cookie (make-bytevector %objcode-cookie-size))
- (expected (format #f "GOOF----~a-~a-~a"
- (cond ((eq? endian (endianness little))
- "LE")
- ((eq? endian (endianness big))
- "BE")
- (else
- (error "unknown endianness"
- endian)))
- word-size
- (effective-version))))
- (bytevector-copy! (get-objcode) 0 cookie 0
- %objcode-cookie-size)
- (string=? (utf8->string cookie) expected)))))))))
-
-(with-test-prefix "cross-compilation"
-
- (test-triplet "i586" "pc" "gnu0.3")
- (test-triplet "x86_64" "unknown" "linux-gnu")
- (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
-
- (test-target "i586-pc-gnu0.3" (endianness little) 4)
- (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
- (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
- (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
-
- (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI
- (endianness little) 4)
- (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet)
- (endianness little) 8)
- (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet)
- (endianness little) 4)
-
- (test-target "arm-unknown-linux-androideabi"
- (endianness little) 4)
- (test-target "armeb-unknown-linux-gnu"
- (endianness big) 4)
- (test-target "aarch64-linux-gnu"
- (endianness little) 8)
- (test-target "aarch64_be-linux-gnu"
- (endianness big) 8)
-
- (pass-if-exception "unknown target"
- exception:miscellaneous-error
- (call-with-values (lambda ()
- (open-bytevector-output-port))
- (lambda (p get-objcode)
- (let* ((b (compile-bytecode '(load-program () 3 #f
- (make-int8 77)
- (return))
- #f))
- (o (bytecode->objcode b)))
- (with-target "fcpu-unknown-gnu1.0"
- (lambda ()
- (write-objcode o p))))))))
-
-;; Local Variables:
-;; eval: (put 'with-target 'scheme-indent-function 1)
-;; End:
(let ((b (make-bytevector 0)))
(null? (bytevector->uint-list b (endianness big) 2))))
- (pass-if "bytevector->sint-list [length < word size]"
- (let ((b (make-bytevector 1)))
- (null? (bytevector->sint-list b (endianness big) 2))))
-
(pass-if-exception "bytevector->sint-list [out-of-range]"
exception:out-of-range
(bytevector->sint-list (make-bytevector 6) (endianness little) -1))
exception:out-of-range
(bytevector->uint-list (make-bytevector 6) (endianness little) 0))
- (pass-if "bytevector->sint-list [off-by-one]"
- (equal? (bytevector->sint-list (make-bytevector 31 #xff)
- (endianness little) 8)
- '(-1 -1 -1)))
+ (pass-if-exception "bytevector->uint-list [word size doesn't divide length]"
+ exception:wrong-type-arg
+ (bytevector->uint-list (make-bytevector 6) (endianness little) 4))
(pass-if "{sint,uint}-list->bytevector"
(let ((b1 (sint-list->bytevector '(513 -253 513 513)
(pass-if "bitvector < 8"
(let ((bv (uniform-array->bytevector (make-bitvector 4 #t))))
- (= (bytevector-length bv) 1)))
+ (= (bytevector-length bv) 4)))
(pass-if "bitvector == 8"
(let ((bv (uniform-array->bytevector (make-bitvector 8 #t))))
- (= (bytevector-length bv) 1)))
+ (= (bytevector-length bv) 4)))
(pass-if "bitvector > 8"
(let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
- (= (bytevector-length bv) 2))))
+ (= (bytevector-length bv) 4)))
+
+ (pass-if "bitvector == 32"
+ (let ((bv (uniform-array->bytevector (make-bitvector 32 #t))))
+ (= (bytevector-length bv) 4)))
+
+ (pass-if "bitvector > 32"
+ (let ((bv (uniform-array->bytevector (make-bitvector 33 #t))))
+ (= (bytevector-length bv) 8))))
\f
(with-test-prefix "srfi-4 homogeneous numeric vectors as bytevectors"
;;;; chars.test --- Characters. -*- coding: utf-8; mode: scheme; -*-
;;;; Greg J. Badros <gjb@cs.washington.edu>
;;;;
-;;;; Copyright (C) 2000, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2006, 2009, 2010, 2013 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 "combining accent is pretty-printed"
(let ((accent (integer->char #x030f))) ; COMBINING DOUBLE GRAVE ACCENT
(string=?
- (with-fluids ((%default-port-encoding "UTF-8"))
- (with-output-to-string (lambda () (write accent))))
+ (with-output-to-string (lambda () (write accent)))
"#\\◌̏")))
(pass-if "combining X is pretty-printed"
(let ((x (integer->char #x0353))) ; COMBINING X BELOW
(string=?
- (with-fluids ((%default-port-encoding "UTF-8"))
- (with-output-to-string (lambda () (write x))))
+ (with-output-to-string (lambda () (write x)))
"#\\◌͓")))))
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014 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 (test-suite guile-test)
#:use-module (system base compile)
- #:use-module ((system vm program) #:select (make-program
- program-sources source:addr)))
+ #:use-module ((system vm loader) #:select (load-thunk-from-memory))
+ #:use-module ((system vm program) #:select (program-sources source:addr)))
(define read-and-compile
(@@ (system base compile) read-and-compile))
#f)
(install-reader!)
this-should-be-ignored")))
- (and (eq? ((make-program (read-and-compile input)))
+ (and (eq? ((load-thunk-from-memory (read-and-compile input)))
'ok)
(eq? r (fluid-ref current-reader)))))
(list x y))))
(display (t 'x)))))
"(x y)(x y)")))
+
+(with-test-prefix "limits"
+ (define (arg n)
+ (string->symbol (format #f "arg~a" n)))
+
+ ;; Cons and vector-set! take uint8 arguments, so this triggers the
+ ;; shuffling case. Also there is the case where more than 252
+ ;; arguments causes shuffling.
+
+ (pass-if "300 arguments"
+ (equal? (apply (compile `(lambda ,(map arg (iota 300))
+ 'foo))
+ (iota 300))
+ 'foo))
+
+ (pass-if "300 arguments with list"
+ (equal? (apply (compile `(lambda ,(map arg (iota 300))
+ (list ,@(reverse (map arg (iota 300))))))
+ (iota 300))
+ (reverse (iota 300))))
+
+ (pass-if "300 arguments with vector"
+ (equal? (apply (compile `(lambda ,(map arg (iota 300))
+ (vector ,@(reverse (map arg (iota 300))))))
+ (iota 300))
+ (list->vector (reverse (iota 300)))))
+
+ (pass-if "0 arguments with list of 300 elements"
+ (equal? ((compile `(lambda ()
+ (list ,@(map (lambda (n) `(identity ,n))
+ (iota 300))))))
+ (iota 300)))
+
+ (pass-if "0 arguments with vector of 300 elements"
+ (equal? ((compile `(lambda ()
+ (vector ,@(map (lambda (n) `(identity ,n))
+ (iota 300))))))
+ (list->vector (iota 300)))))
(pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
(abort-to-prompt 'does-not-exist)))
-(with-test-prefix/c&e "the-vm"
+(with-test-prefix/c&e "unwind"
- (pass-if "unwind changes VMs"
- (let ((new-vm (make-vm))
- (prev-vm (the-vm))
- (proc (lambda (x y)
+ (pass-if "unwind through call-with-vm"
+ (let ((proc (lambda (x y)
(expt x y)))
(call (lambda (p x y)
(p x y))))
(catch 'foo
(lambda ()
- (call-with-vm new-vm (lambda () (throw 'foo (the-vm)))))
- (lambda (key vm)
- (and (eq? key 'foo)
- (eq? vm new-vm)
- (eq? (the-vm) prev-vm))))))
-
- (pass-if "stack overflow reinstates stack reserve"
- ;; In Guile <= 2.0.9, only the first overflow would be gracefully
- ;; handle; subsequent overflows would lead to an abort. See
- ;; <http://lists.gnu.org/archive/html/guile-user/2013-12/msg00017.html>.
- (letrec ((foo (lambda () (+ 1 (foo)))))
- (define (overflows?)
- (catch 'vm-error foo
- (lambda (key proc msg . rest)
- (and (eq? 'vm-run proc)
- (->bool (string-contains msg "overflow"))))))
-
- (and (overflows?) (overflows?) (overflows?)))))
+ (call-with-vm (lambda () (throw 'foo))))
+ (lambda (key)
+ (eq? key 'foo))))))
;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
;; http://okmij.org/ftp/Scheme/delim-control-n.scm. Public domain.
;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 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
(read-enable 'positions)
(compile (read input))))))
-(define %test-vm (make-vm))
-
(define test-procedure
(compile '(lambda (x)
(if (> x 2)
(let ((proc (code "foo.scm" "(lambda (x y) ;; 0
(+ x y)) ;; 1")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(and (coverage-data? data)
(= 3 result)
(display x) ;; 3
(+ x y)))) ;; 4")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(and (coverage-data? data)
(let-values (((instr exec)
(+ (/ x y) ;; 1
(* x y))) ;; 2")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(let ((counts (line-execution-counts data "bar.scm")))
(and (pair? counts)
((= x 0) #t) ;; 7
((< x 0) 'never))))")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 77)))))
(let ((counts (line-execution-counts data "fooz.scm")))
(and (pair? counts)
(every (lambda (line+count)
(let ((line (car line+count))
(count (cdr line+count)))
+ ;; The actual line counts for aliasing
+ ;; operations, like the loop header that
+ ;; initializes "x" to "x", are sensitive to
+ ;; whether there is an associated "mov"
+ ;; instruction, or whether the value is left
+ ;; in place. Currently there are no
+ ;; instructions for line 2, but we allow 1 as
+ ;; well.
(case line
((0 1) (= count 1))
- ((2 3) (= count 78))
+ ((2) (<= 0 count 1))
+ ((3) (= count 78))
((4 5 6) (= count 77))
((7) (= count 1))
((8) (= count 0))
(+ x y)) ;; 4
(+ x y))) ;; 5")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(let ((counts (line-execution-counts data "baz.scm")))
(and (pair? counts)
(not (even? (1- x)))))) ;; 4
even?)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 0)))))
(let ((counts (line-execution-counts data "baz.scm")))
(and (pair? counts)
(let ((line (car line+count))
(count (cdr line+count)))
(case line
- ((0 1) (= count 1))
- ((2 3 4) (= count 0))
- ((5) (= count 1))
- (else #f))))
+ ((0 1) (= count 1))
+ ((2 3 4 5) (= count 0))
+ (else #f))))
counts))))))
(pass-if "case-lambda"
((x) (+ x 3)) ;; 1
((x y) (+ x y))) ;; 2")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(+ (proc 1) (proc 2 3))))))
(let ((counts (line-execution-counts data "cl.scm")))
(let ((proc (code "one-liner.scm"
"(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 451 1884)))))
(let ((counts (line-execution-counts data "one-liner.scm")))
(equal? counts '((0 . 1))))))))
(pass-if "several times"
(let ((proc (code "foo.scm" "(lambda (x y) x)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (+ (proc 1 2) (proc 2 3))))))
(and (coverage-data? data)
(= 3 result)
(pass-if "case-lambda"
(let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(+ (proc 1) (proc 2 3))))))
(and (coverage-data? data)
(pass-if "never"
(let ((proc (code "foo.scm" "(lambda (x y) x)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (+ 1 2)))))
(and (coverage-data? data)
(= 3 result)
- (not (procedure-execution-count data proc))))))
+ (zero? (procedure-execution-count data proc))))))
(pass-if "applicable struct"
(let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw))
(proc (lambda args (length args)))
(b (make-struct <box> 0 proc)))
(let-values (((data result)
- (with-code-coverage %test-vm b)))
+ (with-code-coverage b)))
(and (coverage-data? data)
(= 0 result)
(= (procedure-execution-count data proc) 1)))))
(pass-if "called from C"
;; The `scm_call_N' functions use the VM returned by `the-vm'. This
- ;; test makes sure that they get to use %TEST-VM.
+ ;; test makes sure that their calls are traced.
(let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
(call (false-if-exception ; can we resolve `scm_call_2'?
(pointer->procedure '*
'(* * *)))))
(if call
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(call (make-pointer (object-address proc))
(make-pointer (object-address 1))
(pass-if "called from eval"
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(eval '(test-procedure 123) (current-module))))))
(and (coverage-data? data)
(pass-if "source files are listed as expected"
(let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(let ((files (map basename (instrumented-source-files data))))
(and (member "boot-9.scm" files)
(member "chbouib.scm" files)
- (not (member "foo.scm" files))))))))
+ #t))))))
--- /dev/null
+;;;; Cross compilation -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010-2014 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 (tests cross-compilation)
+ #:use-module (test-suite lib)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system vm elf)
+ #:use-module (system base compile)
+ #:use-module (system base target))
+
+(define (test-triplet cpu vendor os)
+ (let ((triplet (string-append cpu "-" vendor "-" os)))
+ (pass-if (format #f "triplet ~a" triplet)
+ (with-target triplet
+ (lambda ()
+ (and (string=? (target-cpu) cpu)
+ (string=? (target-vendor) vendor)
+ (string=? (target-os) os)))))))
+
+(define (native-cpu)
+ (with-target %host-type target-cpu))
+
+(define (native-os)
+ (with-target %host-type target-os))
+
+(define (native-word-size)
+ ((@ (system foreign) sizeof) '*))
+
+(define (test-target triplet endian word-size)
+ (pass-if (format #f "target `~a' honored" triplet)
+ (with-target triplet
+ (lambda ()
+ (let ((word-size
+ ;; When the target is the native CPU, rather trust
+ ;; the native CPU's word size. This is because
+ ;; Debian's `sparc64-linux-gnu' port, for instance,
+ ;; actually has a 32-bit user-land, for instance (see
+ ;; <http://www.debian.org/ports/sparc/#sparc64bit>
+ ;; for details.)
+ (if (and (string=? (native-cpu) (target-cpu))
+ (string=? (native-os) (target-os)))
+ (native-word-size)
+ word-size))
+ (bv (compile '(hello-world) #:to 'bytecode)))
+ (and=> (parse-elf bv)
+ (lambda (elf)
+ (and (equal? (elf-byte-order elf) endian)
+ (equal? (elf-word-size elf) word-size)))))))))
+
+(with-test-prefix "cross-compilation"
+
+ (test-triplet "i586" "pc" "gnu0.3")
+ (test-triplet "x86_64" "unknown" "linux-gnu")
+ (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
+
+ (test-target "i586-pc-gnu0.3" (endianness little) 4)
+ (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
+ (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
+ (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
+
+ (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI
+ (endianness little) 4)
+ (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet)
+ (endianness little) 8)
+ (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet)
+ (endianness little) 4)
+ (test-target "arm-unknown-linux-androideabi"
+ (endianness little) 4)
+ (test-target "armeb-unknown-linux-gnu"
+ (endianness big) 4)
+ (test-target "aarch64-linux-gnu"
+ (endianness little) 8)
+ (test-target "aarch64_be-linux-gnu"
+ (endianness big) 8)
+
+ (pass-if-exception "unknown target" exception:miscellaneous-error
+ (with-target "fcpu-unknown-gnu1.0"
+ (lambda ()
+ (compile '(ohai) #:to 'bytecode)))))
+
+;; Local Variables:
+;; eval: (put 'with-target 'scheme-indent-function 1)
+;; End:
+++ /dev/null
-;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
-;;;; Andy Wingo <wingo@pobox.com> --- May 2009
-;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; 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 tree-il)
- #:use-module (test-suite lib)
- #:use-module (system base compile)
- #:use-module (system base pmatch)
- #:use-module (system base message)
- #:use-module (language tree-il)
- #:use-module (language tree-il canonicalize)
- #:use-module (language tree-il primitives)
- #:use-module (language tree-il fix-letrec)
- #:use-module (language tree-il cse)
- #:use-module (language tree-il peval)
- #:use-module (language glil)
- #:use-module (srfi srfi-13))
-
-(define-syntax pass-if-cse
- (syntax-rules ()
- ((_ in pat)
- (pass-if 'in
- (let ((evaled (unparse-tree-il
- (canonicalize!
- (fix-letrec!
- (cse
- (peval
- (expand-primitives!
- (resolve-primitives!
- (compile 'in #:from 'scheme #:to 'tree-il)
- (current-module))))))))))
- (pmatch evaled
- (pat #t)
- (_ (pk 'cse-mismatch)
- ((@ (ice-9 pretty-print) pretty-print)
- 'in)
- (newline)
- ((@ (ice-9 pretty-print) pretty-print)
- evaled)
- (newline)
- ((@ (ice-9 pretty-print) pretty-print)
- 'pat)
- (newline)
- #f)))))))
-
-\f
-(with-test-prefix "cse"
-
- ;; The eq? propagates, and (if TEST #t #f) folds to TEST if TEST is
- ;; boolean-valued.
- (pass-if-cse
- (lambda (x y)
- (and (eq? x y)
- (eq? x y)))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (primitive eq?) (lexical x _) (lexical y _))))))
-
- ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
- (pass-if-cse
- (lambda (x y)
- (if (eq? x y) #f #t))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (primitive not)
- (apply (primitive eq?) (lexical x _) (lexical y _)))))))
-
- ;; (if TEST (not TEST) #f)
- ;; => (if TEST #f #f)
- ;; => (begin TEST #f)
- ;; => #f
- (pass-if-cse
- (lambda (x y)
- (and (eq? x y) (not (eq? x y))))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (const #f)))))
-
- ;; (if TEST #f TEST) => (if TEST #f #f) => ...
- (pass-if-cse
- (lambda (x y)
- (if (eq? x y) #f (eq? x y)))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (const #f)))))
-
- ;; The same, but side-effecting primitives do not propagate.
- (pass-if-cse
- (lambda (x y)
- (and (set-car! x y) (not (set-car! x y))))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (if (apply (primitive set-car!)
- (lexical x _)
- (lexical y _))
- (apply (primitive not)
- (apply (primitive set-car!)
- (lexical x _)
- (lexical y _)))
- (const #f))))))
-
- ;; Primitives that access mutable memory can propagate, as long as
- ;; there is no intervening mutation.
- (pass-if-cse
- (lambda (x y)
- (and (string-ref x y)
- (begin
- (string-ref x y)
- (not (string-ref x y)))))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (begin
- (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
- (const #f))))))
-
- ;; However, expressions with dependencies on effects do not propagate
- ;; through a lambda.
- (pass-if-cse
- (lambda (x y)
- (and (string-ref x y)
- (lambda ()
- (and (string-ref x y) #t))))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (if (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
- (lambda _
- (lambda-case
- ((() #f #f #f () ())
- (if (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
- (const #t)
- (const #f)))))
- (const #f))))))
-
- ;; A mutation stops the propagation.
- (pass-if-cse
- (lambda (x y)
- (and (string-ref x y)
- (begin
- (string-set! x #\!)
- (not (string-ref x y)))))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (if (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
- (begin
- (apply (primitive string-set!)
- (lexical x _)
- (const #\!))
- (apply (primitive not)
- (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))))
- (const #f))))))
-
- ;; Predicates are only added to the database if they are in a
- ;; predicate context.
- (pass-if-cse
- (lambda (x y)
- (begin (eq? x y) (eq? x y)))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (apply (primitive eq?) (lexical x _) (lexical y _))))))
-
- ;; Conditional bailouts do cause primitives to be added to the DB.
- (pass-if-cse
- (lambda (x y)
- (begin (unless (eq? x y) (throw 'foo)) (eq? x y)))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (begin
- (if (apply (primitive eq?)
- (lexical x _) (lexical y _))
- (void)
- (apply (primitive 'throw) (const 'foo)))
- (const #t))))))
-
- ;; A chain of tests in a conditional bailout add data to the DB
- ;; correctly.
- (pass-if-cse
- (lambda (x y)
- (begin
- (unless (and (struct? x) (eq? (struct-vtable x) x-vtable))
- (throw 'foo))
- (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
- (struct-ref x y)
- (throw 'bar))))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (begin
- (fix (failure) (_)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (apply (primitive throw) (const foo))))))
- (if (apply (primitive struct?) (lexical x _))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable)
- (lexical x _))
- (toplevel x-vtable))
- (void)
- (apply (lexical failure _)))
- (apply (lexical failure _))))
- (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
-
- ;; Strict argument evaluation also adds info to the DB.
- (pass-if-cse
- (lambda (x)
- ((lambda (z)
- (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
- (struct-ref x 2)
- (throw 'bar))))
- (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
- (struct-ref x 1)
- (throw 'foo))))
-
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (let (z) (_)
- ((fix (failure) (_)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (apply (primitive throw) (const foo))))))
- (if (apply (primitive struct?) (lexical x _))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable)
- (lexical x _))
- (toplevel x-vtable))
- (apply (primitive struct-ref) (lexical x _) (const 1))
- (apply (lexical failure _)))
- (apply (lexical failure _)))))
- (apply (primitive +) (lexical z _)
- (apply (primitive struct-ref) (lexical x _) (const 2))))))))
-
- ;; Replacing named expressions with lexicals.
- (pass-if-cse
- (let ((x (car y)))
- (cons x (car y)))
- (let (x) (_) ((apply (primitive car) (toplevel y)))
- (apply (primitive cons) (lexical x _) (lexical x _))))
-
- ;; Dominating expressions only provide predicates when evaluated in
- ;; test context.
- (pass-if-cse
- (let ((t (car x)))
- (if (car x)
- 'one
- 'two))
- ;; Actually this one should reduce in other ways, but this is the
- ;; current reduction:
- (begin
- (apply (primitive car) (toplevel x))
- (if (apply (primitive car) (toplevel x))
- (const one)
- (const two))))
-
- (pass-if-cse
- (begin (cons 1 2 3) 4)
- (begin
- (apply (primitive cons) (const 1) (const 2) (const 3))
- (const 4)))
-
- (pass-if "http://bugs.gnu.org/12883"
- ;; In 2.0.6, compiling this code would trigger an out-of-bounds
- ;; vlist access in CSE's traversal of its "database".
- (glil-program?
- (compile '(define (proc v)
- (let ((failure (lambda () (bail-out 'match))))
- (if (and (pair? v)
- (null? (cdr v)))
- (let ((w foo)
- (x (cdr w)))
- (if (and (pair? x) (null? w))
- #t
- (failure)))
- (failure))))
- #:from 'scheme
- #:to 'glil))))
--- /dev/null
+;;;; dwarf.test -*- scheme -*-
+;;;;
+;;;; Copyright 2013 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-dwarf)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 match)
+ #:use-module (system base compile)
+ #:use-module (system vm debug)
+ #:use-module (system vm program)
+ #:use-module (system vm loader))
+
+(define prog
+ (string-concatenate
+ ;; Every open parenthesis is a possible source location.
+ '("(define (qux f)\n"
+ ;^ 0:0
+ " (+ 32 (f)))\n"
+ ; ^1:2 ^1:8
+ "\n"
+ "(define bar\n"
+ ;^ 3;0
+ " (lambda (a)\n"
+ ; ^ 4:2
+ " 13))\n"
+ "'success\n")
+ ))
+
+(let* ((port (open-input-string prog))
+ (bv (begin
+ (set-port-filename! port "foo.scm")
+ (read-and-compile port #:to 'bytecode))))
+ (pass-if-equal 'success
+ ((load-thunk-from-memory bv)))
+
+ (pass-if-equal 13 (bar 10))
+
+ (let ((source (find-source-for-addr (program-code qux))))
+ (pass-if-equal "foo.scm" (source-file source))
+ (pass-if-equal 0 (source-line source))
+ (pass-if-equal 1 (source-line-for-user source))
+ (pass-if-equal 0 (source-column source)))
+
+ (let ((source (find-source-for-addr (program-code bar))))
+ (pass-if-equal "foo.scm" (source-file source))
+ (pass-if-equal 4 (source-line source))
+ (pass-if-equal 5 (source-line-for-user source))
+ (pass-if-equal 2 (source-column source)))
+
+ (match (find-program-sources (program-code qux))
+ ((s1 s2 s3)
+ (pass-if-equal "foo.scm" (source-file s1))
+ (pass-if-equal 0 (source-line s1))
+ (pass-if-equal 1 (source-line-for-user s1))
+ (pass-if-equal 0 (source-column s1))
+
+ (pass-if-equal "foo.scm" (source-file s2))
+ (pass-if-equal 1 (source-line s2))
+ (pass-if-equal 2 (source-line-for-user s2))
+ (pass-if-equal 8 (source-column s2))
+
+ (pass-if-equal "foo.scm" (source-file s3))
+ (pass-if-equal 1 (source-line s3))
+ (pass-if-equal 2 (source-line-for-user s3))
+ (pass-if-equal 2 (source-column s3)))
+ (sources
+ (error "unexpected sources" sources)))
+
+ (match (find-program-sources (program-code bar))
+ ((source)
+ (pass-if-equal "foo.scm" (source-file source))
+ (pass-if-equal 4 (source-line source))
+ (pass-if-equal 5 (source-line-for-user source))
+ (pass-if-equal 2 (source-column source)))
+ (sources
+ (error "unexpected sources" sources))))
; Test control structures.
; ========================
+(compile '(%set-lexical-binding-mode #nil) #:from 'elisp #:to 'value)
+
(with-test-prefix/compile "Sequencing"
(pass-if-equal "progn" 1
(setq a (1+ a))
a))
+ (pass-if-equal "empty progn" #nil
+ (progn))
+
(pass-if "prog1"
(progn (setq a 0)
(setq b (prog1 a (setq a (1+ a))))
3)
(equal (if nil 1) nil)))
- (pass-if-equal "failing when" nil-value
- (when nil 1 2 3))
- (pass-if-equal "succeeding when" 42
- (progn (setq a 0)
- (when t (setq a 42) a)))
-
- (pass-if-equal "failing unless" nil-value
- (unless t 1 2 3))
- (pass-if-equal "succeeding unless" 42
- (progn (setq a 0)
- (unless nil (setq a 42) a)))
+ (pass-if-equal "if with no else" #nil
+ (if nil t))
(pass-if-equal "empty cond" nil-value
(cond))
(while (<= i 5)
(setq prod (* i prod))
(setq i (1+ i)))
- prod))
-
- (pass-if "dotimes"
- (progn (setq a 0)
- (setq count 100)
- (setq b (dotimes (i count)
- (setq j (1+ i))
- (setq a (+ a j))))
- (setq c (dotimes (i 10 42) nil))
- (and (= a 5050) (equal b nil) (= c 42))))
-
- (pass-if "dolist"
- (let ((mylist '(7 2 5)))
- (setq sum 0)
- (setq a (dolist (i mylist)
- (setq sum (+ sum i))))
- (setq b (dolist (i mylist 5) 0))
- (and (= sum (+ 7 2 5))
- (equal a nil)
- (equal mylist '(7 2 5))
- (equal b 5)))))
+ prod)))
(with-test-prefix/compile "Exceptions"
(= (catch 'abc (throw 'abc 2) 1) 2)
(= (catch 'abc (catch 'def (throw 'abc (1+ 0)) 2) 3) 1)
(= (catch 'abc (catch 'def (throw 'def 1) 2) 3) 3)
- (= (catch mylist (catch '(1 2) (throw mylist 1) 2) 3) 1)))
+ (= (catch mylist (catch (list 1 2) (throw mylist 1) 2) 3) 1)))
(pass-if "unwind-protect"
(progn (setq a 0 b 1 c 1)
(b a))
b)))
+ (pass-if-equal "empty let" #nil (let ()))
+
(pass-if "let*"
(progn (setq a 0)
(and (let* ((a 1)
(= a 0)
(not (boundp 'b)))))
+ (pass-if-equal "empty let*" #nil
+ (let* ()))
+
(pass-if "local scope"
(progn (setq a 0)
(setq b (let (a)
(lexical-let ((a 2))
(and (= a 2) (equal (dynvals) '(1 . 1))
(let ((a 3) (b a))
+ (declare (lexical a))
(and (= a 3) (= b 2)
(equal (dynvals) '(1 . 2))))
(let* ((a 4) (b a))
+ (declare (lexical a))
(and (= a 4) (= b 4)
(equal (dynvals) '(1 . 4))))
(= a 2)))
(defun dyna () a)
(lexical-let ((a 2) (b 42))
(and (= a 2) (= (dyna) 1)
- ((lambda (a) (and (= a 3) (= b 42) (= (dyna) 3))) 3)
+ ((lambda (a)
+ (declare (lexical a))
+ (and (= a 3) (= b 42) (= (dyna) 1))) 3)
((lambda () (let ((a 3))
+ (declare (lexical a))
(and (= a 3) (= (dyna) 1)))))
(= a 2) (= (dyna) 1)))
(= a 1)))
(= (funcall c1) 4)
(= (funcall c2) 3)))
- (pass-if "always lexical option (all)"
- (progn (setq a 0)
- (defun dyna () a)
- (let ((a 1))
- (and (= a 1) (= (dyna) 0))))
- #:opts '(#:always-lexical all))
- (pass-if "always lexical option (list)"
- (progn (setq a 0 b 0)
- (defun dyna () a)
- (defun dynb () b)
- (let ((a 1)
- (b 1))
- (and (= a 1) (= (dyna) 0)
- (= b 1) (= (dynb) 1))))
- #:opts '(#:always-lexical (a)))
- (pass-if "with-always-lexical"
- (progn (setq a 0)
- (defun dyna () a)
- (with-always-lexical (a)
- (let ((a 1))
- (and (= a 1) (= (dyna) 0))))))
-
(pass-if "lexical lambda args"
(progn (setq a 1 b 1)
(defun dyna () a)
(defun dynb () b)
- (with-always-lexical (a c)
+ (lexical-let (a c)
((lambda (a b &optional c)
+ (declare (lexical a c))
(and (= a 3) (= (dyna) 1)
(= b 2) (= (dynb) 2)
(= c 1)))
; is tail-optimized by doing a deep recursion that would otherwise overflow
; the stack.
(pass-if "lexical lambda tail-recursion"
- (with-always-lexical (i)
+ (lexical-let (i)
(setq to 1000000)
(defun iteration-1 (i)
+ (declare (lexical i))
(if (< i to)
(iteration-1 (1+ i))))
(iteration-1 0)
((lambda (a b c) c) 1 2 3))
(pass-if-equal "optional argument" 3
- ((function (lambda (a &optional b c) c)) 1 2 3))
+ ((lambda (a &optional b c) c) 1 2 3))
(pass-if-equal "optional missing" nil-value
((lambda (&optional a) a)))
(pass-if-equal "rest argument" '(3 4 5)
((lambda (a b &rest c) c) 1 2 3 4 5))
- (pass-if-equal "rest missing" nil-value
- ((lambda (a b &rest c) c) 1 2)))
+ (pass-if "rest missing"
+ (null ((lambda (a b &rest c) c) 1 2)))
+
+ (pass-if-equal "empty lambda" #nil
+ ((lambda ()))))
(with-test-prefix/compile "Function Definitions"
(not (fboundp 'a))
(= a 1))))
- (pass-if "flet and flet*"
+ (pass-if "flet"
(progn (defun foobar () 42)
(defun test () (foobar))
(and (= (test) 42)
- (flet ((foobar (lambda () 0))
- (myfoo (symbol-function 'foobar)))
+ (flet ((foobar () 0)
+ (myfoo ()
+ (funcall (symbol-function 'foobar))))
(and (= (myfoo) 42)
(= (test) 42)))
- (flet* ((foobar (lambda () 0))
- (myfoo (symbol-function 'foobar)))
- (= (myfoo) 42))
- (flet (foobar)
+ (flet ((foobar () nil))
(defun foobar () 0)
(= (test) 42))
(= (test) 42)))))
(setq some-string "abc")
(and (eq 2 2) (not (eq 1 2))
(eq 'abc 'abc) (not (eq 'abc 'def))
- (eq some-string some-string) (not (eq some-string "abc"))
- (eq some-list some-list) (not (eq some-list '(1 2)))))))
+ (eq some-string some-string) (not (eq some-string (string 97 98 99)))
+ (eq some-list some-list) (not (eq some-list (list 1 2)))))))
(with-test-prefix/compile "Number Built-Ins"
(with-test-prefix/compile "List Built-Ins"
- (pass-if "consp and atomp"
+ (pass-if "consp and atom"
(and (consp '(1 2 3)) (consp '(1 2 . 3)) (consp '(a . b))
(not (consp '())) (not (consp 1)) (not (consp "abc"))
- (atomp 'a) (atomp '()) (atomp -1.5) (atomp "abc")
- (not (atomp '(1 . 2))) (not (atomp '(1)))))
+ (atom 'a) (atom '()) (atom -1.5) (atom "abc")
+ (not (atom '(1 . 2))) (not (atom '(1)))))
(pass-if "listp and nlistp"
(and (listp '(1 2 3)) (listp '(1)) (listp '()) (listp '(1 . 2))
(not (listp 'a)) (not (listp 42)) (nlistp 42)
(and (equal (car-safe '(1 2)) 1) (equal (cdr-safe '(1 2)) '(2))
(equal (car-safe 5) nil) (equal (cdr-safe 5) nil)))
- (pass-if "pop"
- (progn (setq mylist '(a b c))
- (setq value (pop mylist))
- (and (equal value 'a)
- (equal mylist '(b c)))))
- (pass-if-equal "push" '(a b c)
- (progn (setq mylist '(b c))
- (push 'a mylist)))
-
(pass-if "nth and nthcdr"
(and (equal (nth -5 '(1 2 3)) 1) (equal (nth 3 '(1 2 3)) nil)
(equal (nth 0 '(1 2 3)) 1) (equal (nth 2 '(1 2 3)) 3)
(pass-if "reverse"
(and (equal (reverse '(5 4 3 2 1)) '(1 2 3 4 5))
(equal (reverse '()) '())))
- (pass-if "copy-tree"
- (progn (setq mylist '(1 2 (3 4)))
- (and (not (eq mylist (copy-tree mylist)))
- (equal mylist (copy-tree mylist)))))
-
- (pass-if "number-sequence"
- (and (equal (number-sequence 5) '(5))
- (equal (number-sequence 5 9) '(5 6 7 8 9))
- (equal (number-sequence 5 9 3) '(5 8))
- (equal (number-sequence 5 1 -2) '(5 3 1))
- (equal (number-sequence 5 8 -1) '())
- (equal (number-sequence 5 1) '())
- (equal (number-sequence 5 5 0) '(5))))
-
(pass-if "setcar and setcdr"
(progn (setq pair '(1 . 2))
(setq copy pair)
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012, 2013, 2014 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-eval)
:use-module (test-suite lib)
:use-module ((srfi srfi-1) :select (unfold count))
- :use-module ((system vm vm) :select (make-vm call-with-vm))
+ :use-module ((system vm vm) :select (call-with-stack-overflow-handler))
+ :use-module ((system vm frame) :select (frame-call-representation))
:use-module (ice-9 documentation)
:use-module (ice-9 local-eval))
(map + '(1 2) '(3)))
)))
+(with-test-prefix "for-each"
+
+ (pass-if-exception "1 arg, non-list, even number of elements"
+ exception:not-a-list
+ (for-each values '(1 2 3 4 . 5)))
+
+ (pass-if-exception "1 arg, non-list, odd number of elements"
+ exception:not-a-list
+ (for-each values '(1 2 3 . 4))))
+
;;;
;;; define with procedure-name
;;;
1+
0))
+(define (make-tagged-trimmed-stack tag spec)
+ (catch 'result
+ (lambda ()
+ (call-with-prompt
+ tag
+ (lambda ()
+ (with-throw-handler 'wrong-type-arg
+ (lambda () (substring 'wrong 'type 'arg))
+ (lambda _ (throw 'result (apply make-stack spec)))))
+ (lambda () (throw 'make-stack-failed))))
+ (lambda (key result) result)))
+
+(define tag (make-prompt-tag "foo"))
+
(with-test-prefix "stacks"
(pass-if "stack involving a primitive"
;; The primitive involving the error must appear exactly once on the
;; stack.
- (catch 'result
- (lambda ()
- (start-stack 'foo
- (with-throw-handler 'wrong-type-arg
- (lambda ()
- ;; Trigger a `wrong-type-arg' exception.
- (hashq-ref 'wrong 'type 'arg))
- (lambda _
- (let* ((stack (make-stack #t))
- (frames (stack->frames stack)))
- (throw 'result
- (count (lambda (frame)
- (eq? (frame-procedure frame)
- hashq-ref))
- frames)))))))
- (lambda (key result)
- (= 1 result))))
+ (let* ((stack (make-tagged-trimmed-stack tag '(#t)))
+ (frames (stack->frames stack))
+ (num (count (lambda (frame) (eq? (frame-procedure frame)
+ substring))
+ frames)))
+ (= num 1)))
(pass-if "arguments of a primitive stack frame"
;; Create a stack with two primitive frames and make sure the
;; arguments are correct.
- (catch 'result
- (lambda ()
- (start-stack 'foo
- (with-throw-handler '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))))))))
+ (let* ((stack (make-tagged-trimmed-stack tag '(#t)))
+ (call-list (map frame-call-representation (stack->frames stack))))
+ (and (equal? (car call-list) '(make-stack #t))
+ (pair? (member '(substring wrong type arg)
+ (cdr call-list))))))
+
+ (pass-if "inner trim with prompt tag"
+ (let* ((stack (make-tagged-trimmed-stack tag `(#t ,tag)))
+ (frames (stack->frames stack)))
+ ;; the top frame on the stack is the lambda inside the 'catch, and the
+ ;; next frame is the (catch 'result ...)
+ (and (eq? (car (frame-call-representation (cadr frames)))
+ 'catch)
+ (eq? (car (frame-arguments (cadr frames)))
+ 'result))))
+
+ (pass-if "outer trim with prompt tag"
+ (let* ((stack (make-tagged-trimmed-stack tag `(#t 0 ,tag)))
+ (frames (stack->frames stack)))
+ ;; the top frame on the stack is the make-stack call, and the last
+ ;; frame is the (with-throw-handler 'wrong-type-arg ...)
+ (and (eq? (car (frame-call-representation (car frames)))
+ 'make-stack)
+ (eq? (car (frame-call-representation (car (last-pair frames))))
+ 'with-throw-handler)))))
;;;
;;; letrec init evaluation
;;; stack overflow handling
;;;
-(with-test-prefix "stack overflow"
+(with-test-prefix "stack overflow handlers"
+ (define (trigger-overflow)
+ (trigger-overflow)
+ (error "not reached"))
- ;; FIXME: this test does not test what it is intending to test
- (pass-if-exception "exception raised"
- exception:vm-error
- (let ((vm (make-vm))
- (thunk (let loop () (cons 's (loop)))))
- (call-with-vm vm thunk))))
+ (define (dynwind-test n)
+ (catch 'foo
+ (lambda ()
+ (call-with-stack-overflow-handler n
+ (lambda ()
+ (dynamic-wind (lambda () #t)
+ trigger-overflow
+ trigger-overflow))
+ (lambda ()
+ (throw 'foo))))
+ (lambda _ #t)))
+
+ (pass-if-exception "limit should be number"
+ exception:wrong-type-arg
+ (call-with-stack-overflow-handler #t
+ trigger-overflow trigger-overflow))
+
+ (pass-if-exception "limit should be exact integer"
+ exception:wrong-type-arg
+ (call-with-stack-overflow-handler 2.0
+ trigger-overflow trigger-overflow))
+
+ (pass-if-exception "limit should be nonnegative"
+ exception:out-of-range
+ (call-with-stack-overflow-handler -1
+ trigger-overflow trigger-overflow))
+
+ (pass-if-exception "limit should be positive"
+ exception:out-of-range
+ (call-with-stack-overflow-handler 0
+ trigger-overflow trigger-overflow))
+
+ (pass-if-exception "limit should be within address space"
+ exception:out-of-range
+ (call-with-stack-overflow-handler (ash 1 64)
+ trigger-overflow trigger-overflow))
+
+ (pass-if "exception on overflow"
+ (catch 'foo
+ (lambda ()
+ (call-with-stack-overflow-handler 10000
+ trigger-overflow
+ (lambda ()
+ (throw 'foo))))
+ (lambda _ #t)))
+
+ (pass-if "exception on overflow with dynwind"
+ ;; Try all limits between 1 and 200 words.
+ (let lp ((n 1))
+ (or (= n 200)
+ (and (dynwind-test n)
+ (lp (1+ n))))))
+
+ (pass-if-exception "overflow handler should return number"
+ exception:wrong-type-arg
+ (call-with-stack-overflow-handler 1000
+ trigger-overflow
+ (lambda () #t)))
+ (pass-if-exception "overflow handler should return exact integer"
+ exception:wrong-type-arg
+ (call-with-stack-overflow-handler 1000
+ trigger-overflow
+ (lambda () 2.0)))
+ (pass-if-exception "overflow handler should be nonnegative"
+ exception:out-of-range
+ (call-with-stack-overflow-handler 1000
+ trigger-overflow
+ (lambda () -1)))
+ (pass-if-exception "overflow handler should be positive"
+ exception:out-of-range
+ (call-with-stack-overflow-handler 1000
+ trigger-overflow
+ (lambda () 0)))
+
+ (letrec ((fac (lambda (n)
+ (if (zero? n) 1 (* n (fac (1- n)))))))
+ (pass-if-equal "overflow handler can allow recursion to continue"
+ (fac 10)
+ (call-with-stack-overflow-handler 1
+ (lambda () (fac 10))
+ (lambda () 1)))))
;;;
;;; docstrings
(gc) (gc) (gc)
(every (cut = <> 9)
(map (lambda (f) (f 2)) procs)))
+ (throw 'unresolved)))
+
+ (pass-if "arity"
+ (if (and qsort (defined? 'procedure->pointer))
+ (equal? '(4 0 #f) (procedure-minimum-arity qsort))
(throw 'unresolved))))
\f
(= (sizeof (list int8 double))
(+ (alignof double) (sizeof double))))
+ (pass-if "sizeof { double, int8 }"
+ (= (sizeof (list double int8))
+ (+ (alignof double) (sizeof double))))
+
(pass-if "sizeof { short, int, long, pointer }"
(let ((layout (list short int long '*)))
(>= (sizeof layout)
(pass-if-exception "misparse latin1 as utf8" exception:decoding-error
(bytevector->string (string->bytevector s "latin1") "utf-8"))
+ (pass-if "misparse latin1 as utf8 with substitutions"
+ (equal? (bytevector->string (string->bytevector s "latin1")
+ "utf-8" 'substitute)
+ "?t?"))
+
(pass-if-exception "misparse latin1 as ascii" exception:decoding-error
(bytevector->string (string->bytevector s "latin1") "ascii"))))
--- /dev/null
+;;;; linker.test -*- scheme -*-
+;;;;
+;;;; Copyright 2013 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-linker)
+ #:use-module (test-suite lib)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system base target)
+ #:use-module (system vm elf)
+ #:use-module (system vm linker))
+
+(define (link-elf-with-one-main-section name bytes)
+ (let ((strtab (make-string-table)))
+ (define (make-object index name bv relocs . kwargs)
+ (let ((name-idx (string-table-intern! strtab (symbol->string name))))
+ (make-linker-object (apply make-elf-section
+ #:index index
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (list (make-linker-symbol name 0)))))
+ (define (make-shstrtab)
+ (string-table-intern! strtab ".shstrtab")
+ (make-object 2 '.shstrtab (link-string-table! strtab) '()
+ #:type SHT_STRTAB #:flags 0))
+ (let* ((word-size (target-word-size))
+ (endianness (target-endianness))
+ (sec (make-object 1 name bytes '()))
+ ;; This needs to be linked last, because linking other
+ ;; sections adds entries to the string table.
+ (shstrtab (make-shstrtab)))
+ (link-elf (list sec shstrtab)
+ #:endianness endianness #:word-size word-size))))
+
+(with-test-prefix "simple"
+ (define foo-bytes #vu8(0 1 2 3 4 5))
+ (define bytes #f)
+ (define elf #f)
+
+ (define (bytevectors-equal? bv-a bv-b start-a start-b size)
+ (or (zero? size)
+ (and (equal? (bytevector-u8-ref bv-a start-a)
+ (bytevector-u8-ref bv-b start-b))
+ (bytevectors-equal? bv-a bv-b (1+ start-a) (1+ start-b)
+ (1- size)))))
+
+ (pass-if "linking succeeds"
+ (begin
+ (set! bytes (link-elf-with-one-main-section '.foo foo-bytes))
+ #t))
+
+ (pass-if "parsing succeeds"
+ (begin
+ (set! elf (parse-elf bytes))
+ (elf? elf)))
+
+ ;; 5 sections: the initial NULL section, .foo, .shstrtab, the initial
+ ;; header with segment table, and the section table.
+ (pass-if-equal 5 (elf-shnum elf))
+
+ (pass-if ".foo section checks out"
+ (let ((sec (assoc-ref (elf-sections-by-name elf) ".foo")))
+ (and sec
+ (= (elf-section-size sec) (bytevector-length foo-bytes))
+ (bytevectors-equal? bytes foo-bytes
+ (elf-section-offset sec) 0
+ (bytevector-length foo-bytes))))))
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
-;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009-2011, 2014 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-modules)
#:use-module (srfi srfi-1)
- #:use-module ((ice-9 streams) ;; for test purposes
- #:renamer (symbol-prefix-proc 's:))
+ #:use-module ((ice-9 streams) #:prefix s:) ; for test purposes
#:use-module (test-suite lib))
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PEG benchmark suite (minimal right now).
+;; Parses very long equations several times; outputs the average time
+;; it took and the standard deviation of times.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(use-modules (ice-9 pretty-print))
+(use-modules (srfi srfi-1))
+(use-modules (ice-9 peg))
+(use-modules (ice-9 popen))
+
+;; Generate random equations.
+(define (gen-rand-eq len)
+ (if (= len 0)
+ (random 1000)
+ (let ((len (if (even? len) (+ len 1) len)))
+ (map (lambda (x)
+ (if (odd? x)
+ (gen-rand len 'op)
+ (gen-rand len 'number)))
+ (iota len)))))
+(define (gen-rand len type)
+ (cond ((eq? type 'number)
+ (cond
+ ((= (random 5) 0) (gen-rand-eq (floor (/ len 5))))
+ (#t (random 1000))))
+ (#t (list-ref '(+ - * /) (random 4)))))
+
+;; Generates a random equation string (len is a rough indicator of the
+;; resulting length).
+(define (gen-str len)
+ (with-output-to-string (lambda () (write (gen-rand-eq len)))))
+
+;; Generates a left-associative parser (see tutorial).
+(define (make-left-parser next-func)
+ (lambda (sum first . rest)
+ (if (null? rest)
+ (apply next-func first)
+ (if (string? (cadr first))
+ (list (string->symbol (cadr first))
+ (apply next-func (car first))
+ (apply next-func (car rest)))
+ (car
+ (reduce
+ (lambda (l r)
+ (list (list (cadr r) (car r) (apply next-func (car l)))
+ (string->symbol (cadr l))))
+ 'ignore
+ (append
+ (list (list (apply next-func (caar first))
+ (string->symbol (cadar first))))
+ (cdr first)
+ (list (append rest '("done"))))))))))
+
+;; Functions for parsing equations (see tutorial).
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+(define parse-product (make-left-parser parse-value))
+(define parse-sum (make-left-parser parse-product))
+(define parse-expr parse-sum)
+(define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str))))
+
+;; PEG for parsing equations (see tutorial).
+(define-peg-string-patterns
+ "expr <- sum
+sum <-- (product ('+' / '-'))* product
+product <-- (value ('*' / '/'))* value
+value <-- sp number sp / sp '(' expr ')' sp
+number <-- [0-9]+
+sp < [ \t\n]*")
+
+;; gets the time in seconds (with a fractional part)
+(define (canon-time)
+ (let ((pair (gettimeofday)))
+ (+ (+ (car pair) (* (cdr pair) (expt 10 -6))) 0.0)))
+
+;; Times how long it takes for FUNC to complete when called on ARGS.
+;; **SIDE EFFECT** Writes the time FUNC took to stdout.
+;; Returns the return value of FUNC.
+(define (time-func func . args)
+ (let ((start (canon-time)))
+ (let ((res (apply func args)))
+ (pretty-print `(took ,(- (canon-time) start) seconds))
+ res)))
+;; Times how long it takes for FUNC to complete when called on ARGS.
+;; Returns the time FUNC took to complete.
+(define (time-ret-func func . args)
+ (let ((start (canon-time)))
+ (let ((res (apply func args)))
+ (- (canon-time) start))))
+
+;; test string (randomly generated)
+(define tst1 "(621 - 746 * 945 - 194 * (204 * (965 - 738 + (846)) - 450 / (116 * 293 * 543) + 858 / 693 - (890 * (260) - 855) + 875 - 684 / (749 - (846) + 127) / 670) - 293 - 815 - 628 * 93 - 662 + 561 / 645 + 112 - 71 - (286 - ((324) / 424 + 956) / 190 + ((848) / 132 * 602) + 5 + 765 * 220 - ((801) / 191 - 299) * 708 + 151 * 682) + (943 + 847 - 145 - 816 / 550 - 217 / 9 / 969 * 524 * 447 / 323) * 991 - 283 * 915 / 733 / 478 / (680 + 343 * 186 / 341 * ((571) * 848 - 47) - (492 + 398 * (616)) + 270 - 539 * 34 / 47 / 458) * 417 / 406 / 354 * 678 + 524 + 40 / 282 - 792 * 570 - 305 * 14 + (248 - 678 * 8 - 53 - 215 / 677 - 665 / 216 - 275 - 462 / 502) - 24 - 780 + (967 / (636 / 400 * 823) + 933 - 361 - 620 - 255 / 372 + 394 * 869 / 839 * 727) + (436 + 993 - 668 + 772 - 33 + 64 - 252 * 957 * 320 + 540 / (23 * 74 / (422))) + (516 / (348 * 219 * 986) * 85 * 149 * 957 * 602 / 141 / 80 / 456 / 92 / (443 * 468 * 466)) * 568 / (271 - 42 + 271 + 592 + 71 * (766 + (11) * 946) / 728 / 137 / 111 + 557 / 962) * 179 - 936 / 821 * 101 - 206 / (267 - (11 / 906 * 290) / 722 / 98 - 987 / 989 - 470 * 833 - (720 / 34 - 280) + 638 / 940) - 889 * 84 * 630 + ((214 - 888 + (46)) / 540 + 941 * 724 / 759 * (679 / 527 - 764) * 413 + 831 / 559 - (308 / 796 / 737) / 20))")
+
+;; appends two equations (adds them together)
+(define (eq-append . eqs)
+ (if (null? eqs)
+ "0"
+ (if (null? (cdr eqs))
+ (car eqs)
+ (string-append
+ (car eqs)
+ " + "
+ (apply eq-append (cdr eqs))))))
+
+;; concatenates an equation onto itself n times using eq-append
+(define (string-n str n)
+ (if (<= n 0)
+ "0"
+ (if (= n 1)
+ str
+ (eq-append str (string-n str (- n 1))))))
+
+;; standard deviation (no bias-correction)
+;; (also called population standard deviation)
+(define (stddev . lst)
+ (let ((llen (length lst)))
+ (if (<= llen 0)
+ 0
+ (let* ((avg (/ (reduce + 0 lst) llen))
+ (mapfun (lambda (x) (real-part (expt (- x avg) 2)))))
+ (sqrt (/ (reduce + 0 (map mapfun lst)) llen))))))
+
+;; average
+(define (avg . lst)
+ (if (null? lst)
+ 0
+ (/ (reduce + 0 lst) (length lst))))
+
+(pretty-print "Parsing equations (see PEG in tutorial). Sample size of 10 for each test.")
+(pretty-print
+ (let ((lst
+ (map
+ (lambda (ignore)
+ (reduce-right
+ append
+ 0
+ (map
+ (lambda (x)
+ (let* ((mstr (string-n tst1 x))
+ (strlen (string-length mstr)))
+ (let ((func (lambda () (begin (match-pattern expr mstr)
+ 'done))))
+ `(((string of length ,strlen first pass)
+ ,(time-ret-func func))
+ ((string of length ,strlen second pass)
+ ,(time-ret-func func))))))
+ (filter (lambda (x) (= (modulo x 25) 0)) (iota 100)))))
+ (iota 10))))
+ (let ((compacted
+ (reduce-right
+ (lambda (accum conc)
+ (map (lambda (l r) (append l (cdr r))) accum conc))
+ 0
+ lst)))
+ (map
+ (lambda (els)
+ `(,(car els)
+ (average time in seconds ,(apply avg (cdr els)))
+ (standard deviation ,(apply stddev (cdr els)))))
+ compacted))))
+
+(define (sys-calc str)
+ (let* ((pipe (open-input-pipe (string-append "echo \"" str "\" | bc -l")))
+ (str (read pipe)))
+ (close-pipe pipe)
+ str))
+(define (lisp-calc str)
+ (+ (eval (eq-parse str) (interaction-environment)) 0.0))
+
+;; (pretty-print `(,(sys-calc tst1) ,(lisp-calc tst1)))
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PEG test suite.
+;; Tests the parsing capabilities of (ice-9 peg). Could use more
+;; tests for edge cases.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-module (test-suite test-peg)
+ :use-module (test-suite lib)
+ :use-module (ice-9 peg)
+ :use-module (ice-9 pretty-print)
+ :use-module (srfi srfi-1))
+
+;; Doubled up for pasting into REPL.
+(use-modules (test-suite lib))
+(use-modules (ice-9 peg))
+(use-modules (ice-9 pretty-print))
+(use-modules (srfi srfi-1))
+
+;; Evaluates an expression at the toplevel. Not the prettiest
+;; solution to runtime issues ever, but m3h. Runs at toplevel so that
+;; symbols are bound globally instead of in the scope of the pass-if
+;; expression.
+(define (eeval exp)
+ (eval exp (interaction-environment)))
+(define make-prec (@@ (ice-9 peg) make-prec))
+
+;; Maps the nonterminals defined in the PEG parser written as a PEG to
+;; the nonterminals defined in the PEG parser written with
+;; S-expressions.
+(define grammar-mapping
+ '((grammar peg-grammar)
+ (pattern peg-pattern)
+ (alternative peg-alternative)
+ (suffix peg-suffix)
+ (primary peg-primary)
+ (literal peg-literal)
+ (charclass peg-charclass)
+ (CCrange charclass-range)
+ (CCsingle charclass-single)
+ (nonterminal peg-nonterminal)
+ (sp peg-sp)))
+
+;; Transforms the nonterminals defined in the PEG parser written as a PEG to the nonterminals defined in the PEG parser written with S-expressions.
+(define (grammar-transform x)
+ (let ((res (assoc x grammar-mapping)))
+ (if res (cadr res) x)))
+
+;; Maps a function onto a tree (recurses until it finds atoms, then calls the function on the atoms).
+(define (tree-map fn lst)
+ (if (list? lst)
+ (if (null? lst)
+ lst
+ (cons (tree-map fn (car lst))
+ (tree-map fn (cdr lst))))
+ (fn lst)))
+
+;; Tests to make sure that we can parse a PEG defining a grammar for
+;; PEGs, then uses that grammar to parse the same PEG again to make
+;; sure we get the same result (i.e. make sure our PEG grammar
+;; expressed as a PEG is equivalent to our PEG grammar expressed with
+;; S-expressions).
+(with-test-prefix "PEG Grammar"
+ (pass-if
+ "defining PEGs with PEG"
+ (and (eeval `(define-peg-string-patterns ,(@@ (ice-9 peg) peg-as-peg))) #t))
+ (pass-if
+ "equivalence of definitions"
+ (equal?
+ (peg:tree (match-pattern (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg)))
+ (tree-map
+ grammar-transform
+ (peg:tree (match-pattern grammar (@@ (ice-9 peg) peg-as-peg)))))))
+
+;; A grammar for pascal-style comments from Wikipedia.
+(define comment-grammar
+ "Begin <-- '(*'
+End <-- '*)'
+C <- Begin N* End
+N <- C / (!Begin !End Z)
+Z <- .")
+
+;; A short /etc/passwd file.
+(define *etc-passwd*
+ "root:x:0:0:root:/root:/bin/bash
+daemon:x:1:1:daemon:/usr/sbin:/bin/sh
+bin:x:2:2:bin:/bin:/bin/sh
+sys:x:3:3:sys:/dev:/bin/sh
+nobody:x:65534:65534:nobody:/nonexistent:/bin/sh
+messagebus:x:103:107::/var/run/dbus:/bin/false
+")
+
+;; A grammar for parsing /etc/passwd files.
+(define-peg-string-patterns
+ "passwd <-- entry* !.
+entry <-- login CO pass CO uid CO gid CO nameORcomment CO homedir CO shell NL*
+login <-- text
+pass <-- text
+uid <-- [0-9]*
+gid <-- [0-9]*
+nameORcomment <-- text
+homedir <-- path
+shell <-- path
+path <-- (SLASH pathELEMENT)*
+pathELEMENT <-- (!NL !CO !'/' .)*
+text <- (!NL !CO .)*
+CO < ':'
+NL < '\n'
+SLASH < '/'")
+
+;; Tests some actual parsing using PEGs.
+(with-test-prefix "Parsing"
+ (eeval `(define-peg-string-patterns ,comment-grammar))
+ (pass-if
+ ;; Pascal-style comment parsing
+ "simple comment"
+ (equal?
+ (match-pattern C "(*blah*)")
+ (make-prec 0 8 "(*blah*)"
+ '((Begin "(*") "blah" (End "*)")))))
+ (pass-if
+ "simple comment padded"
+ (equal?
+ (match-pattern C "(*blah*)abc")
+ (make-prec 0 8 "(*blah*)abc"
+ '((Begin "(*") "blah" (End "*)")))))
+ (pass-if
+ "nested comment"
+ (equal?
+ (match-pattern C "(*1(*2*)*)")
+ (make-prec 0 10 "(*1(*2*)*)"
+ '((Begin "(*") ("1" ((Begin "(*") "2" (End "*)"))) (End "*)")))))
+ (pass-if
+ "early termination"
+ (not (match-pattern C "(*blah")))
+ (pass-if
+ "never starts"
+ (not (match-pattern C "blah")))
+ ;; /etc/passwd parsing
+ (pass-if
+ "/etc/passwd"
+ (equal?
+ (match-pattern passwd *etc-passwd*)
+ (make-prec 0 220 *etc-passwd*
+ '(passwd (entry (login "root") (pass "x") (uid "0") (gid "0") (nameORcomment "root") (homedir (path (pathELEMENT "root"))) (shell (path (pathELEMENT "bin") (pathELEMENT "bash")))) (entry (login "daemon") (pass "x") (uid "1") (gid "1") (nameORcomment "daemon") (homedir (path (pathELEMENT "usr") (pathELEMENT "sbin"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "bin") (pass "x") (uid "2") (gid "2") (nameORcomment "bin") (homedir (path (pathELEMENT "bin"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "sys") (pass "x") (uid "3") (gid "3") (nameORcomment "sys") (homedir (path (pathELEMENT "dev"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "nobody") (pass "x") (uid "65534") (gid "65534") (nameORcomment "nobody") (homedir (path (pathELEMENT "nonexistent"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "messagebus") (pass "x") (uid "103") (gid "107") nameORcomment (homedir (path (pathELEMENT "var") (pathELEMENT "run") (pathELEMENT "dbus"))) (shell (path (pathELEMENT "bin") (pathELEMENT "false")))))))))
+
+;; Tests the functions for pulling data out of PEG Match Records.
+(with-test-prefix "PEG Match Records"
+ (define-peg-pattern bs all (peg "'b'+"))
+ (pass-if
+ "basic parameter extraction"
+ (equal?
+ (let ((pm (search-for-pattern bs "aabbcc")))
+ `((string ,(peg:string pm))
+ (start ,(peg:start pm))
+ (end ,(peg:end pm))
+ (substring ,(peg:substring pm))
+ (tree ,(peg:tree pm))
+ (record? ,(peg-record? pm))))
+ '((string "aabbcc")
+ (start 2)
+ (end 4)
+ (substring "bb")
+ (tree (bs "bb"))
+ (record? #t)))))
+
+;; PEG for parsing right-associative equations.
+(define-peg-string-patterns
+ "expr <- sum
+sum <-- (product ('+' / '-') sum) / product
+product <-- (value ('*' / '/') product) / value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+
+;; Functions to actually evaluate the equations parsed with the PEG.
+(define (parse-sum sum left . rest)
+ (if (null? rest)
+ (apply parse-product left)
+ (list (string->symbol (car rest))
+ (apply parse-product left)
+ (apply parse-sum (cadr rest)))))
+
+(define (parse-product product left . rest)
+ (if (null? rest)
+ (apply parse-value left)
+ (list (string->symbol (car rest))
+ (apply parse-value left)
+ (apply parse-product (cadr rest)))))
+
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+
+(define parse-expr parse-sum)
+(define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str))))
+
+(with-test-prefix "Parsing right-associative equations"
+ (pass-if
+ "1"
+ (equal? (eq-parse "1") 1))
+ (pass-if
+ "1+2"
+ (equal? (eq-parse "1+2") '(+ 1 2)))
+ (pass-if
+ "1+2+3"
+ (equal? (eq-parse "1+2+3") '(+ 1 (+ 2 3))))
+ (pass-if
+ "1+2*3+4"
+ (equal? (eq-parse "1+2*3+4") '(+ 1 (+ (* 2 3) 4))))
+ (pass-if
+ "1+2/3*(4+5)/6-7-8"
+ (equal? (eq-parse "1+2/3*(4+5)/6-7-8")
+ '(+ 1 (- (/ 2 (* 3 (/ (+ 4 5) 6))) (- 7 8)))))
+ (pass-if
+ "1+1/2*3+(1+1)/2"
+ (equal? (eq-parse "1+1/2*3+(1+1)/2")
+ '(+ 1 (+ (/ 1 (* 2 3)) (/ (+ 1 1) 2))))))
+
+;; PEG for parsing left-associative equations (normal ones).
+(define-peg-string-patterns
+ "expr <- sum
+sum <-- (product ('+' / '-'))* product
+product <-- (value ('*' / '/'))* value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+
+;; Functions to actually evaluate the equations parsed with the PEG.
+(define (make-left-parser next-func)
+ (lambda (sum first . rest)
+ (if (null? rest)
+ (apply next-func first)
+ (if (string? (cadr first))
+ (list (string->symbol (cadr first))
+ (apply next-func (car first))
+ (apply next-func (car rest)))
+ (car
+ (reduce
+ (lambda (l r)
+ (list (list (cadr r) (car r) (apply next-func (car l)))
+ (string->symbol (cadr l))))
+ 'ignore
+ (append
+ (list (list (apply next-func (caar first))
+ (string->symbol (cadar first))))
+ (cdr first)
+ (list (append rest '("done"))))))))))
+
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+(define parse-product (make-left-parser parse-value))
+(define parse-sum (make-left-parser parse-product))
+(define parse-expr parse-sum)
+(define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str))))
+
+(with-test-prefix "Parsing left-associative equations"
+ (pass-if
+ "1"
+ (equal? (eq-parse "1") 1))
+ (pass-if
+ "1+2"
+ (equal? (eq-parse "1+2") '(+ 1 2)))
+ (pass-if
+ "1+2+3"
+ (equal? (eq-parse "1+2+3") '(+ (+ 1 2) 3)))
+ (pass-if
+ "1+2*3+4"
+ (equal? (eq-parse "1+2*3+4") '(+ (+ 1 (* 2 3)) 4)))
+ (pass-if
+ "1+2/3*(4+5)/6-7-8"
+ (equal? (eq-parse "1+2/3*(4+5)/6-7-8")
+ '(- (- (+ 1 (/ (* (/ 2 3) (+ 4 5)) 6)) 7) 8)))
+ (pass-if
+ "1+1/2*3+(1+1)/2"
+ (equal? (eq-parse "1+1/2*3+(1+1)/2")
+ '(+ (+ 1 (* (/ 1 2) 3)) (/ (+ 1 1) 2)))))
+
#:use-module (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
- #:use-module (language glil)
#:use-module (rnrs bytevectors) ;; for the bytevector primitives
#:use-module (srfi srfi-13))
(@@ (language tree-il optimize) peval))
(define-syntax pass-if-peval
- (syntax-rules (resolve-primitives)
+ (syntax-rules ()
((_ in pat)
(pass-if-peval in pat
- (compile 'in #:from 'scheme #:to 'tree-il)))
- ((_ resolve-primitives in pat)
- (pass-if-peval in pat
- (expand-primitives!
- (resolve-primitives!
+ (expand-primitives
+ (resolve-primitives
(compile 'in #:from 'scheme #:to 'tree-il)
(current-module)))))
((_ in pat code)
(f)))
(const 3))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, let-values (requires primitive expansion for
;; `call-with-values'.)
(let ((x 0))
(+ a b))))
(const 3))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values.
(let ((x 1) (y 2))
(values x y))
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values truncated.
(let ((x (values 1 'a)) (y 2))
(values x y))
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values truncated.
(or (values 1 2) 3)
(const 1))
(pass-if-peval
;; First order, coalesced, mutability preserved.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+ (primcall list
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
;; First order, coalesced, immutability preserved.
(cons 0 (cons 1 (cons 2 '(3 4 5))))
- (apply (primitive cons) (const 0)
- (apply (primitive cons) (const 1)
- (apply (primitive cons) (const 2)
- (const (3 4 5))))))
+ (primcall cons (const 0)
+ (primcall cons (const 1)
+ (primcall cons (const 2)
+ (const (3 4 5))))))
;; These two tests doesn't work any more because we changed the way we
;; deal with constants -- now the algorithm will see a construction as
(if (zero? i)
r
(loop (1- i) (cons (cons i i) r))))
- (apply (primitive list)
- (apply (primitive cons) (const 1) (const 1))
- (apply (primitive cons) (const 2) (const 2))
- (apply (primitive cons) (const 3) (const 3))))
+ (primcall list
+ (primcall cons (const 1) (const 1))
+ (primcall cons (const 2) (const 2))
+ (primcall cons (const 3) (const 3))))
;;
;; See above.
#;
r
(loop (1- i) (cons (cons i i) r))))
(let (r) (_)
- ((apply (primitive list)
- (apply (primitive cons) (const 3) (const 3))))
+ ((primcall list
+ (primcall cons (const 3) (const 3))))
(let (r) (_)
- ((apply (primitive cons)
- (apply (primitive cons) (const 2) (const 2))
- (lexical r _)))
- (apply (primitive cons)
- (apply (primitive cons) (const 1) (const 1))
- (lexical r _)))))
+ ((primcall cons
+ (primcall cons (const 2) (const 2))
+ (lexical r _)))
+ (primcall cons
+ (primcall cons (const 1) (const 1))
+ (lexical r _)))))
;; See above.
(pass-if-peval
(car r)
(loop (1- i) (cons i r))))
(let (r) (_)
- ((apply (primitive list) (const 4)))
+ ((primcall list (const 4)))
(let (r) (_)
- ((apply (primitive cons)
- (const 3)
- (lexical r _)))
+ ((primcall cons
+ (const 3)
+ (lexical r _)))
(let (r) (_)
- ((apply (primitive cons)
- (const 2)
- (lexical r _)))
+ ((primcall cons
+ (const 2)
+ (lexical r _)))
(let (r) (_)
- ((apply (primitive cons)
- (const 1)
- (lexical r _)))
- (apply (primitive car)
- (lexical r _)))))))
+ ((primcall cons
+ (const 1)
+ (lexical r _)))
+ (primcall car
+ (lexical r _)))))))
;; Static sums.
(pass-if-peval
(loop (cdr l) (+ sum (car l)))))
(const 10))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(let ((string->chars
(lambda (s)
(define (char-at n)
(loop (1+ i)))
'())))))
(string->chars "yo"))
- (apply (primitive list) (const #\y) (const #\o)))
+ (primcall list (const #\y) (const #\o)))
(pass-if-peval
;; Primitives in module-refs are resolved (the expansion of `pmatch'
(pmatch '(a b c d)
((a b . _)
#t)))
- (begin
- (apply . _)
- (const #t)))
+ (seq (call . _)
+ (const #t)))
(pass-if-peval
;; Mutability preserved.
((lambda (x y z) (list x y z)) 1 2 3)
- (apply (primitive list) (const 1) (const 2) (const 3)))
+ (primcall list (const 1) (const 2) (const 3)))
(pass-if-peval
;; Don't propagate effect-free expressions that operate on mutable
(y (car x)))
(set-car! x 0)
y)
- (let (x) (_) ((apply (primitive list) (const 1)))
- (let (y) (_) ((apply (primitive car) (lexical x _)))
- (begin
- (apply (toplevel set-car!) (lexical x _) (const 0))
+ (let (x) (_) ((primcall list (const 1)))
+ (let (y) (_) ((primcall car (lexical x _)))
+ (seq
+ (primcall set-car! (lexical x _) (const 0))
(lexical y _)))))
(pass-if-peval
(let ((y (car x)))
(set-car! x 0)
y)
- (let (y) (_) ((apply (primitive car) (toplevel x)))
- (begin
- (apply (toplevel set-car!) (toplevel x) (const 0))
+ (let (y) (_) ((primcall car (toplevel x)))
+ (seq
+ (primcall set-car! (toplevel x) (const 0))
(lexical y _))))
(pass-if-peval
((lambda _
(lambda-case
(((x) _ _ _ _ _)
- (apply (lexical x _) (lexical x _))))))
- (apply (lexical x _) (lexical x _))))
+ (call (lexical x _) (lexical x _))))))
+ (call (lexical x _) (lexical x _))))
(pass-if-peval
;; First order, aliased primitive.
(begin
(define (+ x y) (pk x y))
(+ 1 2))
- (begin
+ (seq
(define +
(lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
- (apply (toplevel pk) (lexical x _) (lexical y _))))))
- (apply (toplevel +) (const 1) (const 2))))
+ (call (toplevel pk) (lexical x _) (lexical y _))))))
+ (call (toplevel +) (const 1) (const 2))))
(pass-if-peval
;; First-order, effects preserved.
(let ((x 2))
(do-something!)
x)
- (begin
- (apply (toplevel do-something!))
+ (seq
+ (call (toplevel do-something!))
(const 2)))
(pass-if-peval
;; First order, residual bindings removed.
(let ((x 2) (y 3))
(* (+ x y) z))
- (apply (primitive *) (const 5) (toplevel z)))
+ (primcall * (const 5) (toplevel z)))
(pass-if-peval
;; First order, with lambda.
(lambda (_)
(lambda-case
(((x) #f #f #f () (_))
- (apply (primitive +) (lexical x _) (const 9)))))))
+ (primcall + (lexical x _) (const 9)))))))
(pass-if-peval
;; First order, with lambda inlined & specialized twice.
(y 3))
(+ (* x (f x y))
(f something x)))
- (apply (primitive +)
- (apply (primitive *)
- (const 2)
- (apply (primitive +) ; (f 2 3)
- (apply (primitive *)
- (const 2)
- (toplevel top))
- (const 3)))
- (let (x) (_) ((toplevel something)) ; (f something 2)
- ;; `something' is not const, so preserve order of
- ;; effects with a lexical binding.
- (apply (primitive +)
- (apply (primitive *)
- (lexical x _)
- (toplevel top))
- (const 2)))))
+ (primcall +
+ (primcall *
+ (const 2)
+ (primcall + ; (f 2 3)
+ (primcall *
+ (const 2)
+ (toplevel top))
+ (const 3)))
+ (let (x) (_) ((toplevel something)) ; (f something 2)
+ ;; `something' is not const, so preserve order of
+ ;; effects with a lexical binding.
+ (primcall +
+ (primcall *
+ (lexical x _)
+ (toplevel top))
+ (const 2)))))
(pass-if-peval
;; First order, with lambda inlined & specialized 3 times.
(f -1 y)
(f 2 y)
(f z y)))
- (apply (primitive +)
- (const -1) ; (f -1 0)
- (const 0) ; (f 1 0)
- (begin (toplevel y) (const -1)) ; (f -1 y)
- (toplevel y) ; (f 2 y)
- (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
- (if (apply (primitive >) (lexical x _) (const 0))
- (lexical y _)
- (lexical x _)))))
+ (primcall
+ +
+ (primcall
+ +
+ (primcall
+ +
+ (const -1) ; (f -1 0)
+ (seq (toplevel y) (const -1))) ; (f -1 y)
+ (toplevel y)) ; (f 2 y)
+ (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
+ (if (primcall > (lexical x _) (const 0))
+ (lexical y _)
+ (lexical x _)))))
(pass-if-peval
;; First order, conditional.
(lambda ()
(lambda-case
(((x) #f #f #f () (_))
- (apply (toplevel display) (lexical x _))))))
+ (call (toplevel display) (lexical x _))))))
(pass-if-peval
;; First order, recursive procedure.
(foo)
x)
(let (x) (_) ((toplevel top))
- (begin
- (apply (toplevel foo))
+ (seq
+ (call (toplevel foo))
(lexical x _))))
(pass-if-peval
(+ x 1))
'(2 3)
-3)
- (apply (primitive list) (const ()) (const 4)))
+ (primcall list (const ()) (const 4)))
(pass-if-peval
;; Higher order with optional and rest arguments
'(2 3)
-3
17)
- (apply (primitive list) (const ()) (const 21)))
+ (primcall list (const ()) (const 21)))
(pass-if-peval
;; Higher order with optional and rest arguments
17
8
3)
- (let (r) (_) ((apply (primitive list) (const 8) (const 3)))
- (apply (primitive list) (lexical r _) (const 21))))
+ (let (r) (_) ((primcall list (const 8) (const 3)))
+ (primcall list (lexical r _) (const 21))))
(pass-if-peval
;; Higher order with optional argument (caller-supplied value).
(lambda (x)
(+ x 1))
'(2 3))
- (let (y) (_) ((apply (toplevel foo)))
- (apply (primitive +) (lexical y _) (const 7))))
+ (let (y) (_) ((call (toplevel foo)))
+ (primcall + (lexical y _) (const 7))))
(pass-if-peval
;; Higher order with optional argument (caller-supplied value).
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
(let ((fold (lambda (f g) (f (g top)))))
(fold 1+ (lambda (x) x)))
- (apply (primitive 1+) (toplevel top)))
+ (primcall 1+ (toplevel top)))
(pass-if-peval
;; Procedure not inlined when residual code contains recursive calls.
(f (car x3) (fold f (cdr x3) b null? car cdr))))))
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
(letrec (fold) (_) (_)
- (apply (lexical fold _)
+ (call (lexical fold _)
(primitive *)
(toplevel x)
(const 1)
(lambda ()
(lambda-case
(((x2) #f #f #f () (_))
- (apply (primitive -) (lexical x2 _) (const 1))))))))
+ (primcall 1- (lexical x2 _))))))))
(pass-if "inlined lambdas are alpha-renamed"
;; In this example, `make-adder' is inlined more than once; thus,
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
(pmatch (unparse-tree-il
- (peval (compile
- '(let ((make-adder
- (lambda (x) (lambda (y) (+ x y)))))
- (cons (make-adder 1) (make-adder 2)))
- #:to 'tree-il)))
- ((apply (primitive cons)
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym1))
- (apply (primitive +)
- (const 1)
- (lexical y ,ref1)))))
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym2))
- (apply (primitive +)
- (const 2)
- (lexical y ,ref2))))))
+ (peval (expand-primitives
+ (resolve-primitives
+ (compile
+ '(let ((make-adder
+ (lambda (x) (lambda (y) (+ x y)))))
+ (cons (make-adder 1) (make-adder 2)))
+ #:to 'tree-il)
+ (current-module)))))
+ ((primcall cons
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym1))
+ (primcall +
+ (const 1)
+ (lexical y ,ref1)))))
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym2))
+ (primcall +
+ (const 2)
+ (lexical y ,ref2))))))
(and (eq? gensym1 ref1)
(eq? gensym2 ref2)
(not (eq? gensym1 gensym2))))
(b (lambda () (a)))
(c (lambda (x) x)))
(c 10))
- (begin (apply (toplevel foo!))
- (const 10)))
+ (seq (call (toplevel foo!))
+ (const 10)))
(pass-if-peval
;; Higher order, mutually recursive procedures.
;; Memv with non-constant list. It could fold but doesn't
;; currently.
(memv 1 (list 3 2 1))
- (apply (primitive memv)
- (const 1)
- (apply (primitive list) (const 3) (const 2) (const 1))))
+ (primcall memv
+ (const 1)
+ (primcall list (const 3) (const 2) (const 1))))
(pass-if-peval
;; Memv with non-constant key, constant list, test context
((3 2 1) 'a)
(else 'b))
(let (key) (_) ((toplevel foo))
- (if (if (apply (primitive eqv?) (lexical key _) (const 3))
+ (if (if (primcall eqv? (lexical key _) (const 3))
(const #t)
- (if (apply (primitive eqv?) (lexical key _) (const 2))
+ (if (primcall eqv? (lexical key _) (const 2))
(const #t)
- (apply (primitive eqv?) (lexical key _) (const 1))))
+ (primcall eqv? (lexical key _) (const 1))))
(const a)
(const b))))
(pass-if-peval
- ;; Memv with non-constant key, empty list, test context. Currently
- ;; doesn't fold entirely.
+ ;; Memv with non-constant key, empty list, test context.
(case foo
(() 'a)
(else 'b))
- (begin (toplevel foo) (const b)))
+ (seq (toplevel foo) (const 'b)))
;;
;; Below are cases where constant propagation should bail out.
(lambda (n)
(vector-set! v n n)))
(let (v) (_)
- ((apply (toplevel make-vector) (const 6) (const #f)))
+ ((primcall make-vector (const 6) (const #f)))
(lambda ()
(lambda-case
(((n) #f #f #f () (_))
- (apply (toplevel vector-set!)
- (lexical v _) (lexical n _) (lexical n _)))))))
+ (primcall vector-set!
+ (lexical v _) (lexical n _) (lexical n _)))))))
(pass-if-peval
;; Mutable lexical is not propagated.
(lambda ()
v))
(let (v) (_)
- ((apply (primitive vector) (const 1) (const 2) (const 3)))
+ ((primcall vector (const 1) (const 2) (const 3)))
(lambda ()
(lambda-case
((() #f #f #f () ())
(let* ((x (if (> p q) (frob!) (display 'chbouib)))
(y (* x 2)))
(+ x x y))
- (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
- (apply (toplevel frob!))
- (apply (toplevel display) (const chbouib))))
- (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
- (apply (primitive +)
- (lexical x _) (lexical x _) (lexical y _)))))
+ (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
+ (call (toplevel frob!))
+ (call (toplevel display) (const chbouib))))
+ (let (y) (_) ((primcall * (lexical x _) (const 2)))
+ (primcall +
+ (primcall + (lexical x _) (lexical x _))
+ (lexical y _)))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.
(make-list 10)
(list 1 2 3))
(let (x y z) (_ _ _)
- ((apply (primitive vector) (const 1) (const 2) (const 3))
- (apply (toplevel make-list) (const 10))
- (apply (primitive list) (const 1) (const 2) (const 3)))
- (begin
- (apply (toplevel vector-set!)
- (lexical x _) (const 0) (const 0))
- (apply (toplevel set-car!)
- (lexical y _) (const 0))
- (apply (toplevel set-cdr!)
- (lexical z _) (const ())))))
+ ((primcall vector (const 1) (const 2) (const 3))
+ (call (toplevel make-list) (const 10))
+ (primcall list (const 1) (const 2) (const 3)))
+ (seq
+ (primcall vector-set!
+ (lexical x _) (const 0) (const 0))
+ (seq (primcall set-car!
+ (lexical y _) (const 0))
+ (primcall set-cdr!
+ (lexical z _) (const ()))))))
(pass-if-peval
(let ((foo top-foo) (bar top-bar))
(f (lambda (g x) (g x x))))
(+ (f g foo) (f g bar))))
(let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
- (apply (primitive +)
- (apply (primitive +) (lexical foo _) (lexical foo _))
- (apply (primitive +) (lexical bar _) (lexical bar _)))))
+ (primcall +
+ (primcall + (lexical foo _) (lexical foo _))
+ (primcall + (lexical bar _) (lexical bar _)))))
(pass-if-peval
;; Fresh objects are not turned into constants, nor are constants
(x (cons 1 c))
(y (cons 0 x)))
y)
- (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
- (apply (primitive cons) (const 0) (lexical x _))))
+ (let (x) (_) ((primcall cons (const 1) (const (2 3))))
+ (primcall cons (const 0) (lexical x _))))
(pass-if-peval
;; Bindings mutated.
(set! x 3)
x)
(let (x) (_) ((const 2))
- (begin
+ (seq
(set! (lexical x _) (const 3))
(lexical x _))))
(frob f) ; may mutate `x'
x)
(letrec (x) (_) ((const 0))
- (begin
- (apply (toplevel frob) (lambda _ _))
+ (seq
+ (call (toplevel frob) (lambda _ _))
(lexical x _))))
(pass-if-peval
(let ((x (make-foo)))
(frob! x) ; may mutate `x'
x)
- (let (x) (_) ((apply (toplevel make-foo)))
- (begin
- (apply (toplevel frob!) (lexical x _))
+ (let (x) (_) ((call (toplevel make-foo)))
+ (seq
+ (call (toplevel frob!) (lexical x _))
(lexical x _))))
(pass-if-peval
(lambda-case
(((x) #f #f #f () (_))
(if _ _
- (apply (lexical loop _)
- (apply (primitive 1-)
- (lexical x _))))))))
- (apply (lexical loop _) (toplevel x))))
+ (call (lexical loop _)
+ (primcall 1-
+ (lexical x _))))))))
+ (call (lexical loop _) (toplevel x))))
(pass-if-peval
;; Recursion on the 2nd argument is fully evaluated.
(if (> y 0)
(loop x (1- y))
(foo x y))))
- (let (x) (_) ((apply (toplevel top)))
- (apply (toplevel foo) (lexical x _) (const 0))))
+ (let (x) (_) ((call (toplevel top)))
+ (call (toplevel foo) (lexical x _) (const 0))))
(pass-if-peval
;; Inlining aborted when residual code contains recursive calls.
(letrec (loop) (_) ((lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
- (if (apply (primitive >)
- (lexical y _) (const 0))
+ (if (primcall >
+ (lexical y _) (const 0))
_ _)))))
- (apply (lexical loop _) (toplevel x) (const 0))))
+ (call (lexical loop _) (toplevel x) (const 0))))
(pass-if-peval
;; Infinite recursion: `peval' gives up and leaves it as is.
(and (< x top)
(loop (1+ x))))
(letrec (loop) (_) ((lambda . _))
- (apply (lexical loop _) (const 0))))
+ (call (lexical loop _) (const 0))))
(pass-if-peval
;; This test checks that the `start' binding is indeed residualized.
(here)))
(let (pos) (_) ((const 0))
(let (here) (_) (_)
- (begin
- (set! (lexical pos _) (const 1))
- (apply (lexical here _))))))
-
+ (seq
+ (set! (lexical pos _) (const 1))
+ (call (lexical here _))))))
+
(pass-if-peval
;; FIXME: should this one residualize the binding?
(letrec ((a a))
;; "b c a" is the current order that we get with unordered letrec,
;; but it's not important to this test, so if it changes, just adapt
;; the test.
- (letrec (b c a) (_ _ _)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (apply (lexical a _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (lexical x _))))
- (lambda _
- (lambda-case
- ((() #f #f #f () ())
- (apply (lexical a _))))))
- (let (d)
- (_)
- ((apply (toplevel foo) (lexical b _)))
- (apply (lexical c _)
- (lexical d _)))))
+ (letrec (b a) (_ _)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (call (lexical a _)))))
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (call (lexical a _))))))
+ (call (toplevel foo) (lexical b _))))
(pass-if-peval
;; In this case, we can prune the bindings. `a' ends up being copied
(letrec* ((a (lambda (x) (top x)))
(b (lambda () a)))
(foo (b) (b)))
- (apply (toplevel foo)
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))))
+ (call (toplevel foo)
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; The inliner sees through a `let'.
((let ((a 10)) (lambda (b) (* b 2))) 30)
(const 60))
((lambda (x y . z)
(list x y z))
1 2 3 4)
- (let (z) (_) ((apply (primitive list) (const 3) (const 4)))
- (apply (primitive list) (const 1) (const 2) (lexical z _))))
+ (let (z) (_) ((primcall list (const 3) (const 4)))
+ (primcall list (const 1) (const 2) (lexical z _))))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; Unmutated lists can get inlined.
(let ((args (list 2 3)))
(apply (lambda (x y z w)
(list x y z w))
0 1 args))
- (apply (primitive list) (const 0) (const 1) (const 2) (const 3)))
+ (primcall list (const 0) (const 1) (const 2) (const 3)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; However if the list might have been mutated, it doesn't propagate.
(let ((args (list 2 3)))
(foo! args)
(apply (lambda (x y z w)
(list x y z w))
0 1 args))
- (let (args) (_) ((apply (primitive list) (const 2) (const 3)))
- (begin
- (apply (toplevel foo!) (lexical args _))
- (apply (primitive @apply)
- (lambda ()
- (lambda-case
- (((x y z w) #f #f #f () (_ _ _ _))
- (apply (primitive list)
- (lexical x _) (lexical y _)
- (lexical z _) (lexical w _)))))
- (const 0)
- (const 1)
- (lexical args _)))))
-
- (pass-if-peval resolve-primitives
+ (let (args) (_) ((primcall list (const 2) (const 3)))
+ (seq
+ (call (toplevel foo!) (lexical args _))
+ (primcall apply
+ (lambda ()
+ (lambda-case
+ (((x y z w) #f #f #f () (_ _ _ _))
+ (primcall list
+ (lexical x _) (lexical y _)
+ (lexical z _) (lexical w _)))))
+ (const 0)
+ (const 1)
+ (lexical args _)))))
+
+ (pass-if-peval
;; Here the `args' that gets built by the application of the lambda
;; takes more than effort "10" to visit. Test that we fall back to
;; the source expression of the operand, which is still a call to
bv
(+ offset 4))))
(let ((args (list x y)))
- (@apply
+ (apply
(lambda (bv offset x y)
(bytevector-ieee-single-native-set!
bv
(lambda ()
(lambda-case
(((bv offset n) #f #f #f () (_ _ _))
- (let (x y) (_ _) ((apply (primitive bytevector-ieee-single-native-ref)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 0)))
- (apply (primitive bytevector-ieee-single-native-ref)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 4))))
- (begin
- (apply (primitive bytevector-ieee-single-native-set!)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 0))
- (lexical x _))
- (apply (primitive bytevector-ieee-single-native-set!)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 4))
- (lexical y _))))))))
-
- (pass-if-peval resolve-primitives
+ (let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 0)))
+ (primcall bytevector-ieee-single-native-ref
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 4))))
+ (seq
+ (primcall bytevector-ieee-single-native-set!
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 0))
+ (lexical x _))
+ (primcall bytevector-ieee-single-native-set!
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 4))
+ (lexical y _))))))))
+
+ (pass-if-peval
;; Here we ensure that non-constant expressions are not copied.
(lambda ()
(let ((args (list (foo!))))
- (@apply
+ (apply
(lambda (z x)
(list z x))
;; This toplevel ref might raise an unbound variable exception.
(lambda ()
(lambda-case
((() #f #f #f () ())
- (let (_) (_) ((apply (toplevel foo!)))
+ (let (_) (_) ((call (toplevel foo!)))
(let (z) (_) ((toplevel z))
- (apply (primitive 'list)
- (lexical z _)
- (lexical _ _))))))))
+ (primcall 'list
+ (lexical z _)
+ (lexical _ _))))))))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; Rest args referenced more than once are not destructured.
(lambda ()
(let ((args (list 'foo)))
(set-car! args 'bar)
- (@apply
+ (apply
(lambda (z x)
(list z x))
z
(lambda-case
((() #f #f #f () ())
(let (args) (_)
- ((apply (primitive list) (const foo)))
- (begin
- (apply (primitive set-car!) (lexical args _) (const bar))
- (apply (primitive @apply)
- (lambda . _)
- (toplevel z)
- (lexical args _))))))))
-
- (pass-if-peval resolve-primitives
+ ((primcall list (const foo)))
+ (seq
+ (primcall set-car! (lexical args _) (const bar))
+ (primcall apply
+ (lambda . _)
+ (toplevel z)
+ (lexical args _))))))))
+
+ (pass-if-peval
;; Let-values inlining, even with consumers with rest args.
(call-with-values (lambda () (values 1 2))
(lambda args
(apply list args)))
- (apply (primitive list) (const 1) (const 2)))
+ (primcall list (const 1) (const 2)))
+
+ (pass-if-peval
+ ;; When we can't inline let-values but can prove that the producer
+ ;; has just one value, reduce to "let" (which can then fold
+ ;; further).
+ (call-with-values (lambda () (if foo 1 2))
+ (lambda args
+ (apply values args)))
+ (if (toplevel foo) (const 1) (const 2)))
(pass-if-peval
;; Constant folding: cons of #nil does not make list
(cons 1 #nil)
- (apply (primitive cons) (const 1) (const '#nil)))
+ (primcall cons (const 1) (const '#nil)))
(pass-if-peval
;; Constant folding: cons
(pass-if-peval
;; Constant folding: cons
(begin (cons (foo) 2) #f)
- (begin (apply (toplevel foo)) (const #f)))
+ (seq (call (toplevel foo)) (const #f)))
(pass-if-peval
;; Constant folding: cons
(pass-if-peval
;; Constant folding: car+cons, impure
(car (cons 1 (bar)))
- (begin (apply (toplevel bar)) (const 1)))
+ (seq (call (toplevel bar)) (const 1)))
(pass-if-peval
;; Constant folding: cdr+cons, impure
(cdr (cons (bar) 0))
- (begin (apply (toplevel bar)) (const 0)))
+ (seq (call (toplevel bar)) (const 0)))
(pass-if-peval
;; Constant folding: car+list
(pass-if-peval
;; Constant folding: cdr+list
(cdr (list 1 0))
- (apply (primitive list) (const 0)))
+ (primcall list (const 0)))
(pass-if-peval
;; Constant folding: car+list, impure
(car (list 1 (bar)))
- (begin (apply (toplevel bar)) (const 1)))
+ (seq (call (toplevel bar)) (const 1)))
(pass-if-peval
;; Constant folding: cdr+list, impure
(cdr (list (bar) 0))
- (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
+ (seq (call (toplevel bar)) (primcall list (const 0))))
+
+ (pass-if-peval
+ ;; Equality primitive: same lexical
+ (let ((x (random))) (eq? x x))
+ (seq (call (toplevel random)) (const #t)))
+
+ (pass-if-peval
+ ;; Equality primitive: merge lexical identities
+ (let* ((x (random)) (y x)) (eq? x y))
+ (seq (call (toplevel random)) (const #t)))
(pass-if-peval
- resolve-primitives
- ;; Non-constant guards get lexical bindings.
+ ;; Non-constant guards get lexical bindings, invocation of winder and
+ ;; unwinder lifted out. Unfortunately both have the generic variable
+ ;; name "tmp", so we can't distinguish them in this test, and they
+ ;; also collide in generic names with the single-value result from
+ ;; the dynwind; alack.
(dynamic-wind foo (lambda () bar) baz)
- (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
- (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+ (let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
+ (seq (seq (if (primcall thunk? (lexical tmp _))
+ (call (lexical tmp _))
+ (primcall scm-error . _))
+ (primcall wind (lexical tmp _) (lexical tmp _)))
+ (let (tmp) (_) ((toplevel bar))
+ (seq (seq (primcall unwind)
+ (call (lexical tmp _)))
+ (lexical tmp _))))))
(pass-if-peval
- resolve-primitives
- ;; Constant guards don't need lexical bindings.
+ ;; Constant guards don't need lexical bindings or thunk? checks.
(dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
- (dynwind
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel foo))))
- (toplevel bar)
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel baz))))))
+ (seq (seq (toplevel foo)
+ (primcall wind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+ (let (tmp) (_) ((toplevel bar))
+ (seq (seq (primcall unwind)
+ (toplevel baz))
+ (lexical tmp _)))))
+
+ (pass-if-peval
+ ;; Dynwind bodies that return an unknown number of values need a
+ ;; let-values.
+ (dynamic-wind (lambda () foo) (lambda () (bar)) (lambda () baz))
+ (seq (seq (toplevel foo)
+ (primcall wind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+ (let-values (call (toplevel bar))
+ (lambda-case
+ ((() #f vals #f () (_))
+ (seq (seq (primcall unwind)
+ (toplevel baz))
+ (primcall apply (primitive values) (lexical vals _))))))))
(pass-if-peval
- resolve-primitives
;; Prompt is removed if tag is unreferenced
(let ((tag (make-prompt-tag)))
(call-with-prompt tag
(const 1))
(pass-if-peval
- resolve-primitives
;; Prompt is removed if tag is unreferenced, with explicit stem
(let ((tag (make-prompt-tag "foo")))
(call-with-prompt tag
;; Handler lambda inlined
(pass-if-peval
- resolve-primitives
(call-with-prompt tag
(lambda () 1)
(lambda (k x) x))
- (prompt (toplevel tag)
+ (prompt #t
+ (toplevel tag)
(const 1)
- (lambda-case
- (((k x) #f #f #f () (_ _))
- (lexical x _)))))
+ (lambda _
+ (lambda-case
+ (((k x) #f #f #f () (_ _))
+ (lexical x _))))))
;; Handler toplevel not inlined
(pass-if-peval
- resolve-primitives
- (call-with-prompt tag
- (lambda () 1)
- handler)
- (let (handler) (_) ((toplevel handler))
- (prompt (toplevel tag)
- (const 1)
- (lambda-case
- ((() #f args #f () (_))
- (apply (primitive @apply)
- (lexical handler _)
- (lexical args _)))))))
-
- (pass-if-peval
- resolve-primitives
+ (call-with-prompt tag
+ (lambda () 1)
+ handler)
+ (prompt #f
+ (toplevel tag)
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (const 1))))
+ (toplevel handler)))
+
+ (pass-if-peval
;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get
;; elided, and the continuation tag stays around. (The continue tag
;; twice before aborting. The abort doesn't unroll the recursive
;; reference.)
(while #t #t)
- (let (_) (_) ((apply (primitive make-prompt-tag) . _))
+ (let (_) (_) ((primcall make-prompt-tag . _))
(letrec (lp) (_)
((lambda _
(lambda-case
((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical loop _))))))
- (apply (lexical loop _)))))))
- (apply (lexical lp _)))))
+ (call (lexical loop _))))))
+ (call (lexical loop _)))))))
+ (call (lexical lp _)))))
(pass-if-peval
- resolve-primitives
(lambda (a . rest)
(apply (lambda (x y) (+ x y))
a rest))
(((x y) #f #f #f () (_ _))
_))))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(car '(1 2))
(const 1))
;; residualizing a reference to the leaf identifier. The bailout is
;; driven by the recursive-effort-limit, which is currently 100. We
;; make sure to trip it with this recursive sum thing.
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(let ((x (let sum ((n 0) (out 0))
(if (< n 10000)
(sum (1+ n) (+ out n))
out))))
((lambda (y) (list y)) x))
(let (x) (_) (_)
- (apply (primitive list) (lexical x _))))
+ (primcall list (lexical x _))))
;; Here we test that a common test in a chain of ifs gets lifted.
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(if (and (struct? x) (eq? (struct-vtable x) A))
(foo x)
(if (and (struct? x) (eq? (struct-vtable x) B))
(let (failure) (_) ((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (toplevel qux) (toplevel x))))))
- (if (apply (primitive struct?) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel A))
- (apply (toplevel foo) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel B))
- (apply (toplevel bar) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel C))
- (apply (toplevel baz) (toplevel x))
- (apply (lexical failure _)))))
- (apply (lexical failure _)))))
+ (call (toplevel qux) (toplevel x))))))
+ (if (primcall struct? (toplevel x))
+ (if (primcall eq?
+ (primcall struct-vtable (toplevel x))
+ (toplevel A))
+ (call (toplevel foo) (toplevel x))
+ (if (primcall eq?
+ (primcall struct-vtable (toplevel x))
+ (toplevel B))
+ (call (toplevel bar) (toplevel x))
+ (if (primcall eq?
+ (primcall struct-vtable (toplevel x))
+ (toplevel C))
+ (call (toplevel baz) (toplevel x))
+ (call (lexical failure _)))))
+ (call (lexical failure _)))))
;; Multiple common tests should get lifted as well.
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(if (and (struct? x) (eq? (struct-vtable x) A) B)
(foo x)
(if (and (struct? x) (eq? (struct-vtable x) A) C)
(let (failure) (_) ((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (toplevel qux) (toplevel x))))))
- (if (apply (primitive struct?) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel A))
+ (call (toplevel qux) (toplevel x))))))
+ (if (primcall struct? (toplevel x))
+ (if (primcall eq?
+ (primcall struct-vtable (toplevel x))
+ (toplevel A))
(if (toplevel B)
- (apply (toplevel foo) (toplevel x))
+ (call (toplevel foo) (toplevel x))
(if (toplevel C)
- (apply (toplevel bar) (toplevel x))
+ (call (toplevel bar) (toplevel x))
(if (toplevel D)
- (apply (toplevel baz) (toplevel x))
- (apply (lexical failure _)))))
- (apply (lexical failure _)))
- (apply (lexical failure _)))))
+ (call (toplevel baz) (toplevel x))
+ (call (lexical failure _)))))
+ (call (lexical failure _)))
+ (call (lexical failure _)))))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(apply (lambda (x y) (cons x y)) '(1 2))
- (apply (primitive cons) (const 1) (const 2)))
+ (primcall cons (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(apply (lambda (x y) (cons x y)) (list 1 2))
- (apply (primitive cons) (const 1) (const 2)))
+ (primcall cons (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ ;; Disable after removal of abort-in-tail-position optimization, in
+ ;; hopes that CPS does a uniformly better job.
+ #;
+ (pass-if-peval
(let ((t (make-prompt-tag)))
(call-with-prompt t
(lambda () (abort-to-prompt t 1 2 3))
(lambda (k x y z) (list x y z))))
- (apply (primitive 'list) (const 1) (const 2) (const 3)))
-
- (pass-if-peval resolve-primitives
- ;; Should not inline tail list to apply if it is mutable.
- ;; <http://debbugs.gnu.org/15533>
- (let ((l '()))
- (if (pair? arg)
- (set! l arg))
- (apply f l))
- (let (l) (_) ((const ()))
- (begin
- (if (apply (primitive pair?) (toplevel arg))
- (set! (lexical l _) (toplevel arg))
- (void))
- (apply (primitive @apply) (toplevel f) (lexical l _))))))
+ (primcall list (const 1) (const 2) (const 3)))
+
+ (pass-if-peval
+ (call-with-values foo (lambda (x) (bar x)))
+ (let (x) (_) ((call (toplevel foo)))
+ (call (toplevel bar) (lexical x _))))
+
+ (pass-if-peval
+ ((lambda (foo)
+ (define* (bar a #:optional (b (1+ a)))
+ (list a b))
+ (bar 1))
+ 1)
+ (primcall list (const 1) (const 2)))
+
+ (pass-if-peval
+ ;; Should not inline tail list to apply if it is mutable.
+ ;; <http://debbugs.gnu.org/15533>
+ (let ((l '()))
+ (if (pair? arg)
+ (set! l arg))
+ (apply f l))
+ (let (l) (_) ((const ()))
+ (seq
+ (if (primcall pair? (toplevel arg))
+ (set! (lexical l _) (toplevel arg))
+ (void))
+ (primcall apply (toplevel f) (lexical l _))))))
(pass-if "output check"
(string=? text result)))
- (pass-if "encoding failure leads to exception"
- ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'.
- ;; See the discussion at <http://bugs.gnu.org/11197>, for details.
- (catch 'encoding-error
- (lambda ()
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (let ((p (open-input-string "λ"))) ; raise an exception
- #f)))
- (lambda (key . rest)
- #t)
- (lambda (key . rest)
- ;; At this point, the port-table mutex used to be still held,
- ;; hence the deadlock. This situation would occur when trying
- ;; to print a backtrace, for instance.
- (input-port? (open-input-string "foo")))))
-
- (pass-if "%default-port-encoding is honored"
- (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
- (equal? (map (lambda (e)
- (with-fluids ((%default-port-encoding e))
- (call-with-output-string
- (lambda (p)
- (and (string=? e (port-encoding p))
- (display (port-encoding p) p))))))
- encodings)
- encodings)))
+ (pass-if "%default-port-encoding is ignored"
+ (let ((str "ĉu bone?"))
+ ;; Latin-1 cannot represent ‘ĉ’.
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (string=? (call-with-output-string
+ (lambda (p)
+ (set-port-conversion-strategy! p 'substitute)
+ (display str p)))
+ "ĉu bone?"))))
(pass-if "%default-port-conversion-strategy is honored"
(let ((strategies '(error substitute escape)))
(map symbol->string strategies))))
(pass-if "suitable encoding [latin-1]"
- (let ((str "hello, world"))
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (equal? str
- (with-output-to-string
- (lambda ()
- (display str)))))))
+ (let ((str "hello, world")
+ (encoding "ISO-8859-1"))
+ (equal? str
+ (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p encoding)
+ (display str p))))))
(pass-if "suitable encoding [latin-3]"
- (let ((str "ĉu bone?"))
- (with-fluids ((%default-port-encoding "ISO-8859-3"))
- (equal? str
- (with-output-to-string
- (lambda ()
- (display str)))))))
+ (let ((str "ĉu bone?")
+ (encoding "ISO-8859-3"))
+ (equal? str
+ (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p encoding)
+ (display str p))))))
(pass-if "wrong encoding, error"
(let ((str "ĉu bone?"))
(catch 'encoding-error
(lambda ()
- ;; Latin-1 cannot represent ‘ĉ’.
- (with-fluids ((%default-port-encoding "ISO-8859-1")
- (%default-port-conversion-strategy 'error))
- (with-output-to-string
- (lambda ()
- (display str))))
- #f) ; so the test really fails here
+ (with-fluids ((%default-port-conversion-strategy 'error))
+ (call-with-output-string
+ (lambda (p)
+ ;; Latin-1 cannot represent ‘ĉ’.
+ (set-port-encoding! p "ISO-8859-1")
+ (display str p))))
+ #f) ; so the test really fails here
(lambda (key subr message errno port chr)
(and (eqv? chr #\ĉ)
(string? (strerror errno)))))))
(pass-if "wrong encoding, substitute"
(let ((str "ĉu bone?"))
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (string=? (with-output-to-string
- (lambda ()
- (set-port-conversion-strategy! (current-output-port)
- 'substitute)
- (display str)))
- "?u bone?"))))
+ (string=? (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p "ISO-8859-1")
+ (set-port-conversion-strategy! p 'substitute)
+ (display str p)))
+ "?u bone?")))
(pass-if "wrong encoding, escape"
(let ((str "ĉu bone?"))
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (string=? (with-output-to-string
- (lambda ()
- (set-port-conversion-strategy! (current-output-port)
- 'escape)
- (display str)))
- "\\u0109u bone?"))))
-
- (pass-if "peek-char [latin-1]"
- (let ((p (with-fluids ((%default-port-encoding #f))
- (open-input-string "hello, world"))))
- (and (char=? (peek-char p) #\h)
- (char=? (peek-char p) #\h)
- (char=? (peek-char p) #\h)
- (= (port-line p) 0)
- (= (port-column p) 0))))
-
- (pass-if "peek-char [utf-8]"
- (let ((p (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "안녕하세요"))))
- (and (char=? (peek-char p) #\안)
- (char=? (peek-char p) #\안)
- (char=? (peek-char p) #\안)
- (= (port-line p) 0)
- (= (port-column p) 0))))
-
- (pass-if "peek-char [utf-16]"
- (let ((p (with-fluids ((%default-port-encoding "UTF-16BE"))
- (open-input-string "안녕하세요"))))
+ (string=? (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p "ISO-8859-1")
+ (set-port-conversion-strategy! p 'escape)
+ (display str p)))
+ "\\u0109u bone?")))
+
+ (pass-if "peek-char"
+ (let ((p (open-input-string "안녕하세요")))
(and (char=? (peek-char p) #\안)
(char=? (peek-char p) #\안)
(char=? (peek-char p) #\안)
(set-port-encoding! p "does-not-exist")
(read p)))
- (pass-if-exception "%default-port-encoding, wrong encoding"
- exception:miscellaneous-error
- (read (with-fluids ((%default-port-encoding "does-not-exist"))
- (open-input-string "")))))
+ (let ((filename (test-file)))
+ (with-output-to-file filename (lambda () (write 'test)))
+
+ (pass-if-exception "%default-port-encoding, wrong encoding"
+ exception:miscellaneous-error
+ (read (with-fluids ((%default-port-encoding "does-not-exist"))
+ (open-input-file filename))))
+
+ (delete-file filename)))
;;;
;;; port-for-each
(pass-if-equal "BOM not discarded unless at start of UTF-32 stream"
"a\uFEFFb"
(bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61
- #x00 #x00 #xFE #xFF
- #x00 #x00 #x00 #x62)))
+ #x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x62)))
(pass-if-equal "BOM discarded from start of UTF-32 stream (LE)"
"a"
;;;; -*- coding: utf-8; mode: scheme; -*-
;;;;
-;;;; Copyright (C) 2010, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2013, 2014 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 exp '(a b #(c d e) f . g))
(define (tprint x width encoding)
- (with-fluids ((%default-port-encoding encoding))
- (with-output-to-string
- (lambda ()
- (truncated-print x #:width width)))))
+ (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p encoding)
+ (truncated-print x p #:width width))))
- (pass-if (equal? (tprint exp 10 "ISO-8859-1")
- "(a b . #)"))
+ (pass-if-equal "(a b . #)"
+ (tprint exp 10 "ISO-8859-1"))
- (pass-if (equal? (tprint exp 15 "ISO-8859-1")
- "(a b # f . g)"))
+ (pass-if-equal "(a b # f . g)"
+ (tprint exp 15 "ISO-8859-1"))
- (pass-if (equal? (tprint exp 18 "ISO-8859-1")
- "(a b #(c ...) . #)"))
+ (pass-if-equal "(a b #(c ...) . #)"
+ (tprint exp 18 "ISO-8859-1"))
- (pass-if (equal? (tprint exp 20 "ISO-8859-1")
- "(a b #(c d e) f . g)"))
+ (pass-if-equal "(a b #(c d e) f . g)"
+ (tprint exp 20 "ISO-8859-1"))
- (pass-if (equal? (tprint "The quick brown fox" 20 "ISO-8859-1")
- "\"The quick brown...\""))
+ (pass-if-equal "\"The quick brown...\""
+ (tprint "The quick brown fox" 20 "ISO-8859-1"))
- (pass-if (equal? (tprint "The quick brown fox" 20 "UTF-8")
- "\"The quick brown f…\""))
+ (pass-if-equal "\"The quick brown f…\""
+ (tprint "The quick brown fox" 20 "UTF-8"))
- (pass-if (equal? (tprint (current-module) 20 "ISO-8859-1")
- "#<directory (tes...>"))
+ (pass-if-equal "#<directory (tes...>"
+ (tprint (current-module) 20 "ISO-8859-1"))
- (pass-if (equal? (tprint (current-module) 20 "UTF-8")
- "#<directory (test-…>")))
+ (pass-if-equal "#<directory (test-…>"
+ (tprint (current-module) 20 "UTF-8")))
;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8; -*-
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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 "apply"
(equal? (procedure-minimum-arity apply)
- '(1 0 #t)))
+ '(2 0 #t)))
(pass-if "cons*"
(equal? (procedure-minimum-arity cons*)
(pass-if "opt, eval"
(equal? (procedure-minimum-arity (eval '(lambda* (a b #:optional c) #t)
(current-module)))
- '(2 1 #f)))
-
- (if (include-deprecated-features)
- (pass-if-exception "set-procedure-properties! arity"
- '(misc-error . "arity is a read-only property")
- (set-procedure-properties! (lambda x x) '((arity . 3))))
- #t))
+ '(2 1 #f))))
;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS -*- scheme -*-
-;;;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2004, 2006, 2014 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
;;Not really an error to fail this (Matthias Radestock)
;;If this returns (0 1 0), your map isn't call/cc safe, but is probably
;;tail-recursive. If its (0 0 0), the opposite is true.
-(should-be 8.3 '(0 1 0)
+(should-be 8.3 '(0 0 0)
(let ()
(define executed-k #f)
(define cont #f)
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009-2012, 2014-2015 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2012, 2013-2015 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
(eof-object? (get-u8 port)))))
(pass-if "lookahead-u8 non-ASCII"
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "λ"))))
+ (let ((port (open-input-string "λ")))
(and (= 206 (lookahead-u8 port))
(= 206 (lookahead-u8 port))
(= 206 (get-u8 port))
(let* ((str "hello, world")
(bv (string->utf16 str)))
(equal? str
- (with-fluids ((%default-port-encoding "UTF-16BE"))
- (call-with-output-string
- (lambda (port)
- (put-bytevector port bv)))))))
+ (call-with-output-string
+ (lambda (port)
+ (set-port-encoding! port "UTF-16BE")
+ (put-bytevector port bv))))))
(pass-if "put-bytevector with wrong-encoding string port"
(let* ((str "hello, world")
(bv (string->utf16 str)))
(catch 'decoding-error
(lambda ()
- (with-fluids ((%default-port-encoding "UTF-32")
- (%default-port-conversion-strategy 'error))
+ (with-fluids ((%default-port-conversion-strategy 'error))
(call-with-output-string
- (lambda (port)
- (put-bytevector port bv)))
+ (lambda (port)
+ (set-port-encoding! port "UTF-32")
+ (put-bytevector port bv)))
#f)) ; fail if we reach this point
(lambda (key subr message errno port)
(string? (strerror errno)))))))
(put-string tp "The letter λ cannot be represented in Latin-1.")
#f))))
- (pass-if "port-transcoder [binary port]"
- (not (port-transcoder (open-bytevector-input-port #vu8()))))
-
(pass-if "port-transcoder [transcoded port]"
(let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
(make-transcoder (utf-8-codec))))
(define-record-type simple-rtd)
(define-record-type
(specified-rtd specified-rtd-constructor specified-rtd-predicate))
-(define-record-type parent-rtd (fields x y))
+;; Can't be named as `parent-rtd', as that shadows the `parent-rtd'
+;; literal.
+(define-record-type *parent-rtd (fields x y))
(define-record-type child-parent-rtd-rtd
- (parent-rtd (record-type-descriptor parent-rtd)
- (record-constructor-descriptor parent-rtd))
+ (parent-rtd (record-type-descriptor *parent-rtd)
+ (record-constructor-descriptor *parent-rtd))
(fields z))
-(define-record-type child-parent-rtd (parent parent-rtd) (fields z))
+(define-record-type child-parent-rtd (parent *parent-rtd) (fields z))
(define-record-type mutable-fields-rtd
(fields (mutable mutable-bar)
(mutable mutable-baz mutable-baz-accessor mutable-baz-mutator)))
(defined? 'specified-rtd-constructor)))
(pass-if "parent-rtd clause includes specified parent"
- (eq? (record-type-parent child-parent-rtd-rtd) parent-rtd))
+ (eq? (record-type-parent child-parent-rtd-rtd) *parent-rtd))
(pass-if "parent clause includes specified parent"
- (eq? (record-type-parent child-parent-rtd) parent-rtd))
+ (eq? (record-type-parent child-parent-rtd) *parent-rtd))
(pass-if "protocol clause includes specified protocol"
(let ((protocol-record (make-protocol-rtd 1 2)))
(define-module (test-suite test-ramap)
#:use-module (test-suite lib))
+(define exception:shape-mismatch
+ (cons 'misc-error ".*shape mismatch.*"))
+
(define (array-row a i)
(make-shared-array a (lambda (j) (list i j))
(cadr (array-dimensions a))))
(with-test-prefix "array-index-map!"
- (pass-if (let ((nlst '()))
- (array-index-map! (make-array #f '(1 1))
- (lambda (n)
- (set! nlst (cons n nlst))))
- (equal? nlst '(1)))))
+ (pass-if "basic test"
+ (let ((nlst '()))
+ (array-index-map! (make-array #f '(1 1))
+ (lambda (n)
+ (set! nlst (cons n nlst))))
+ (equal? nlst '(1))))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "all axes empty"
+ (array-index-map! (make-typed-array 'f64 0 0 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 0) (const 0))
+ #t)
+
+ (pass-if "last axis empty"
+ (array-index-map! (make-typed-array 'f64 0 2 0) (const 0))
+ (array-index-map! (make-typed-array 'b #t 2 0) (const #t))
+ (array-index-map! (make-typed-array #t 0 2 0) (const 0))
+ #t)
+
+ ; the 'f64 cases fail in 2.0.9 with out-of-range.
+ (pass-if "axis empty, other than last"
+ (array-index-map! (make-typed-array 'f64 0 0 2) (const 0))
+ (array-index-map! (make-typed-array 'b #t 0 2) (const #t))
+ (array-index-map! (make-typed-array #t 0 0 2) (const 0))
+ #t))
+
+ (pass-if "rank 2"
+ (let ((a (make-array 0 2 2))
+ (b (make-array 0 2 2)))
+ (array-index-map! a (lambda (i j) i))
+ (array-index-map! b (lambda (i j) j))
+ (and (array-equal? a #2((0 0) (1 1)))
+ (array-equal? b #2((0 1) (0 1)))))))
+
+;;;
+;;; array-copy!
+;;;
+
+(with-test-prefix "array-copy!"
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t"
+ (let* ((b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2:0:2() c)))
+
+ (pass-if "empty other than last, 'f64"
+ (let* ((b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2f64:0:2() c)))
+
+ ;; FIXME add empty, type 'b cases.
+
+ )
+
+ ;; note that it is the opposite of array-map!. This is, unfortunately,
+ ;; documented in the manual.
+
+ (pass-if "matching behavior I"
+ (let ((a #(1 2))
+ (b (make-array 0 3)))
+ (array-copy! a b)
+ (equal? b #(1 2 0))))
+
+ (pass-if-exception "matching behavior II" exception:shape-mismatch
+ (let ((a #(1 2 3))
+ (b (make-array 0 2)))
+ (array-copy! a b)
+ (equal? b #(1 2))))
+
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4)) ((5 6) (7 8))))
+ (b (make-array 0 2 3 2)))
+ (array-copy! a b)
+ (array-equal? b #3(((1 2) (3 4) (0 0)) ((5 6) (7 8) (0 0))))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-copy! a b)
+ (equal? b #0(99))))
+
+ (pass-if "rank 1"
+ (let* ((a #2((1 2) (3 4)))
+ (b (make-shared-array a (lambda (j) (list 1 j)) 2))
+ (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
+ (d (make-array 0 2))
+ (e (make-array 0 2)))
+ (array-copy! b d)
+ (array-copy! c e)
+ (and (equal? d #(3 4))
+ (equal? e #(4 2)))))
+
+ (pass-if "rank 2"
+ (let ((a #2((1 2) (3 4)))
+ (b (make-array 0 2 2))
+ (c (make-array 0 2 2))
+ (d (make-array 0 2 2))
+ (e (make-array 0 2 2)))
+ (array-copy! a b)
+ (array-copy! a (transpose-array c 1 0))
+ (array-copy! (transpose-array a 1 0) d)
+ (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
+ (and (equal? a #2((1 2) (3 4)))
+ (equal? b #2((1 2) (3 4)))
+ (equal? c #2((1 3) (2 4)))
+ (equal? d #2((1 3) (2 4)))
+ (equal? e #2((1 2) (3 4))))))
+
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-copy! A (piece X 2 0))
+ (array-copy! B (piece X 2 2))
+ (array-copy! C (piece X 1 4))
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-copy! (make-shared-array #0(1) (lambda x '()) 2 2) a)
+ (array-equal? #2((1 1) (1 1))))))
;;;
;;; array-map!
(pass-if-exception "closure 0" exception:wrong-num-args
(array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5)))
+ (make-array #f 5)))
(pass-if "closure 1"
(let ((a (make-array #f 5)))
(pass-if-exception "closure 2" exception:wrong-num-args
(array-map! (make-array #f 5) (lambda (x y) #f)
- (make-array #f 5)))
+ (make-array #f 5)))
(pass-if "subr_1"
(let ((a (make-array #f 5)))
- (array-map! a length (make-array '(x y z) 5))
- (equal? a (make-array 3 5))))
+ (array-map! a length (make-array '(x y z) 5))
+ (equal? a (make-array 3 5))))
(pass-if-exception "subr_2" exception:wrong-num-args
(array-map! (make-array #f 5) logtest
- (make-array 999 5)))
+ (make-array 999 5)))
(pass-if "subr_2o"
(let ((a (make-array #f 5)))
(pass-if "1+"
(let ((a (make-array #f 5)))
(array-map! a 1+ (make-array 123 5))
- (equal? a (make-array 124 5)))))
+ (equal? a (make-array 124 5))))
+
+ (pass-if "rank 0"
+ (let ((a #0(99))
+ (b (make-array 0)))
+ (array-map! b values a)
+ (equal? b #0(99))))
+
+ (pass-if "rank 2, discontinuous"
+ (let ((A #2((0 1) (2 3) (4 5)))
+ (B #2((10 11) (12 13) (14 15)))
+ (C #2((20) (21) (22)))
+ (X (make-array 0 3 5))
+ (piece (lambda (X w s)
+ (make-shared-array
+ X (lambda (i j) (list i (+ j s))) 3 w))))
+ (array-map! (piece X 2 0) values A)
+ (array-map! (piece X 2 2) values B)
+ (array-map! (piece X 1 4) values C)
+ (and (array-equal? X #2((0 1 10 11 20) (2 3 12 13 21) (4 5 14 15 22))))))
+
+ (pass-if "null increments, not empty"
+ (let ((a (make-array 0 2 2)))
+ (array-map! a values (make-shared-array #0(1) (lambda x '()) 2 2))
+ (array-equal? a #2((1 1) (1 1))))))
(with-test-prefix "two sources"
(pass-if-exception "closure 0" exception:wrong-num-args
(array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5) (make-array #f 5)))
+ (make-array #f 5) (make-array #f 5)))
(pass-if-exception "closure 1" exception:wrong-num-args
(array-map! (make-array #f 5) (lambda (x) #f)
- (make-array #f 5) (make-array #f 5)))
+ (make-array #f 5) (make-array #f 5)))
(pass-if "closure 2"
(let ((a (make-array #f 5)))
- (array-map! a (lambda (x y) 'foo)
- (make-array #f 5) (make-array #f 5))
- (equal? a (make-array 'foo 5))))
+ (array-map! a (lambda (x y) 'foo)
+ (make-array #f 5) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
(pass-if-exception "subr_1" exception:wrong-num-args
(array-map! (make-array #f 5) length
(let ((a (make-array #f 4)))
(array-map! a + #(1 2 3 4) #(5 6 7 8))
(equal? a #(6 8 10 12))))
-
+
(pass-if "noncompact arrays 1"
(let ((a #2((0 1) (2 3)))
- (c #(0 0)))
+ (c (make-array 0 2)))
(begin
(array-map! c + (array-row a 1) (array-row a 1))
(array-equal? c #(4 6)))))
-
+
(pass-if "noncompact arrays 2"
(let ((a #2((0 1) (2 3)))
- (c #(0 0)))
+ (c (make-array 0 2)))
(begin
(array-map! c + (array-col a 1) (array-col a 1))
(array-equal? c #(2 6)))))
-
+
(pass-if "noncompact arrays 3"
(let ((a #2((0 1) (2 3)))
- (c #(0 0)))
+ (c (make-array 0 2)))
(begin
(array-map! c + (array-col a 1) (array-row a 1))
(array-equal? c #(3 6)))))
-
+
(pass-if "noncompact arrays 4"
(let ((a #2((0 1) (2 3)))
- (c #(0 0)))
+ (c (make-array 0 2)))
(begin
(array-map! c + (array-col a 1) (array-row a 1))
- (array-equal? c #(3 6)))))))
+ (array-equal? c #(3 6)))))
+
+ (pass-if "offset arrays 1"
+ (let ((a #2@1@-3((0 1) (2 3)))
+ (c (make-array 0 '(1 2) '(-3 -2))))
+ (begin
+ (array-map! c + a a)
+ (array-equal? c #2@1@-3((0 2) (4 6)))))))
+
+ ;; note that array-copy! has the opposite behavior.
+
+ (pass-if-exception "matching behavior I" exception:shape-mismatch
+ (let ((a #(1 2))
+ (b (make-array 0 3)))
+ (array-map! b values a)
+ (equal? b #(1 2 0))))
+
+ (pass-if "matching behavior II"
+ (let ((a #(1 2 3))
+ (b (make-array 0 2)))
+ (array-map! b values a)
+ (equal? b #(1 2))))
+
+ ;; here both a & b are are unrollable down to the first axis, but the
+ ;; size mismatch limits unrolling to the last axis only.
+
+ (pass-if "matching behavior III"
+ (let ((a #3(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))))
+ (b (make-array 0 2 2 2)))
+ (array-map! b values a)
+ (array-equal? b #3(((1 2) (3 4)) ((7 8) (9 10)))))))
;;;
;;; array-for-each
(with-test-prefix "array-for-each"
(with-test-prefix "1 source"
+ (pass-if-equal "rank 0"
+ '(99)
+ (let* ((a #0(99))
+ (l '())
+ (p (lambda (x) (set! l (cons x l)))))
+ (array-for-each p a)
+ l))
+
(pass-if-equal "noncompact array"
'(3 2 1 0)
(let* ((a #2((0 1) (2 3)))
(l '())
(rec (lambda args (set! l (cons args l)))))
(array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
- l))))
+ l)))
+
+ (with-test-prefix "empty arrays"
+
+ (pass-if "empty other than last, #t" ; fails in 2.0.9 with bad a.
+ (let* ((a (list))
+ (b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ (pass-if "empty other than last, f64" ; fails in 2.0.9 with out of range.
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-for-each (lambda (c) (set! a (cons c a))) c)
+ (equal? a '())))
+
+ ;; FIXME add type 'b cases.
+
+ (pass-if-exception "empty arrays shape check" exception:shape-mismatch
+ (let* ((a (list))
+ (b (make-typed-array 'f64 0 0 2))
+ (c (make-typed-array 'f64 0 2 0)))
+ (array-for-each (lambda (b c) (set! a (cons* b c a))) b c)))))
--- /dev/null
+;;;; random.test --- tests guile's uniform arrays -*- scheme -*-
+;;;;
+;;;; Copyright 2013 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-random)
+ #:use-module ((system base compile) #:select (compile))
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-4 gnu))
+
+; see strings.test, arrays.test.
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+;;;
+;;; random:normal-vector!
+;;;
+
+(with-test-prefix "random:normal-vector!"
+
+ ;; FIXME need proper function test.
+
+ (pass-if "non uniform"
+ (let ((a (make-vector 4 0))
+ (b (make-vector 4 0))
+ (c (make-shared-array (make-vector 8 0)
+ (lambda (i) (list (+ 1 (* 2 i)))) 4)))
+ (begin
+ (random:normal-vector! b (random-state-from-platform))
+ (random:normal-vector! c (random-state-from-platform))
+ (and (not (equal? a b)) (not (equal? a c))))))
+
+ (pass-if "uniform (f64)"
+ (let ((a (make-f64vector 4 0))
+ (b (make-f64vector 4 0))
+ (c (make-shared-array (make-f64vector 8 0)
+ (lambda (i) (list (+ 1 (* 2 i)))) 4)))
+ (begin
+ (random:normal-vector! b (random-state-from-platform))
+ (random:normal-vector! c (random-state-from-platform))
+ (and (not (equal? a b)) (not (equal? a c)))))))
-;;;; rdelim.test --- Delimited I/O. -*- mode: scheme; coding: utf-8; -*-
-;;;; Ludovic Courtès <ludo@gnu.org>
-;;;;
-;;;; Copyright (C) 2011, 2013, 2014 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-rdelim)
- #:use-module (ice-9 rdelim)
- #:use-module ((rnrs io ports) #:select (open-bytevector-input-port))
- #:use-module (test-suite lib))
-
-(with-fluids ((%default-port-encoding "UTF-8"))
-
- (with-test-prefix "read-line"
-
- (pass-if "one line"
- (let* ((s "hello, world")
- (p (open-input-string s)))
- (and (string=? s (read-line p))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, trim"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? (string-tokenize s)
- (list (read-line p) (read-line p)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, concat"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '("foo\n" "bar\n")
- (list (read-line p 'concat)
- (read-line p 'concat)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, peek"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '("foo" #\newline "bar" #\newline)
- (list (read-line p 'peek) (read-char p)
- (read-line p 'peek) (read-char p)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, split"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '(("foo" . #\newline)
- ("bar" . #\newline))
- (list (read-line p 'split)
- (read-line p 'split)))
- (eof-object? (read-line p)))))
-
- (pass-if "two Greek lines, trim"
- (let* ((s "λαμβδα\nμυ\n")
- (p (open-input-string s)))
- (and (equal? (string-tokenize s)
- (list (read-line p) (read-line p)))
- (eof-object? (read-line p)))))
-
- (pass-if "decoding error"
- (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'error)
- (catch 'decoding-error
- (lambda ()
- (read-line p)
- #f)
- (lambda (key subr message err port)
- (and (eq? port p)
-
- ;; PORT should now point past the error.
- (string=? (read-line p) "BCD")
- (eof-object? (read-line p)))))))
-
- (pass-if "decoding error, substitute"
- (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'substitute)
- (and (string=? (read-line p) "A?BCD")
- (eof-object? (read-line p))))))
-
-\f
- (with-test-prefix "read-delimited"
-
- (pass-if "delimiter hit"
- (let ((p (open-input-string "hello, world!")))
- (and (string=? "hello" (read-delimited ",.;" p))
- (string=? " world!" (read-delimited ",.;" p))
- (eof-object? (read-delimited ",.;" p)))))
-
- (pass-if "delimiter hit, split"
- (equal? '("hello" . #\,)
- (read-delimited ",.;"
- (open-input-string "hello, world!")
- 'split)))
-
- (pass-if "delimiter hit, concat"
- (equal? '"hello,"
- (read-delimited ",.;" (open-input-string "hello, world!")
- 'concat)))
-
- (pass-if "delimiter hit, peek"
- (let ((p (open-input-string "hello, world!")))
- (and (string=? "hello" (read-delimited ",.;" p 'peek))
- (char=? #\, (peek-char p)))))
-
- (pass-if "eof"
- (eof-object? (read-delimited "}{" (open-input-string "")))))
-
-\f
- (with-test-prefix "read-delimited!"
-
- (pass-if "delimiter hit"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p))
- (string=? (substring s 0 5) "hello")
- (= 7 (read-delimited! ",.;" s p))
- (string=? (substring s 0 7) " world!")
- (eof-object? (read-delimited! ",.;" s p)))))
-
- (pass-if "delimiter hit, start+end"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p 'trim 10 30))
- (string=? (substring s 10 15) "hello"))))
-
- (pass-if "delimiter hit, split"
- (let ((s (make-string 123)))
- (and (equal? '(5 . #\,)
- (read-delimited! ",.;" s
- (open-input-string "hello, world!")
- 'split))
- (string=? (substring s 0 5) "hello"))))
-
- (pass-if "delimiter hit, concat"
- (let ((s (make-string 123)))
- (and (= 6 (read-delimited! ",.;" s
- (open-input-string "hello, world!")
- 'concat))
- (string=? (substring s 0 6) "hello,"))))
-
- (pass-if "delimiter hit, peek"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p 'peek))
- (string=? (substring s 0 5) "hello")
- (char=? #\, (peek-char p)))))
-
- (pass-if "string too small"
- (let ((s (make-string 7)))
- (and (= 7 (read-delimited! "}{" s
- (open-input-string "hello, world!")))
- (string=? s "hello, "))))
-
- (pass-if "string too small, start+end"
- (let ((s (make-string 123)))
- (and (= 7 (read-delimited! "}{" s
- (open-input-string "hello, world!")
- 'trim
- 70 77))
- (string=? (substring s 70 77) "hello, "))))
-
- (pass-if "string too small, split"
- (let ((s (make-string 7)))
- (and (equal? '(7 . #f)
- (read-delimited! "}{" s
- (open-input-string "hello, world!")
- 'split))
- (string=? s "hello, "))))
-
- (pass-if "eof"
- (eof-object? (read-delimited! ":" (make-string 7)
- (open-input-string ""))))
-
- (pass-if "eof, split"
- (eof-object? (read-delimited! ":" (make-string 7)
- (open-input-string "")))))
-
- (with-test-prefix "read-string"
-
- (pass-if "short string"
- (let* ((s "hello, world!")
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) ""))))
-
- (pass-if "100 chars"
- (let* ((s (make-string 100 #\space))
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) ""))))
-
- (pass-if "longer than 100 chars"
- (let* ((s (string-concatenate (make-list 20 "hello, world!")))
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) ""))))
-
- (pass-if-equal "longer than 100 chars, with limit"
- "hello, world!"
- (let* ((s (string-concatenate (make-list 20 "hello, world!")))
- (p (open-input-string s)))
- (read-string p 13))))
-
- (with-test-prefix "read-string!"
-
- (pass-if "buf smaller"
- (let* ((s "hello, world!")
- (len (1- (string-length s)))
- (buf (make-string len #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? buf (substring s 0 len))
- (= (read-string! buf p) 1)
- (string=? (substring buf 0 1) (substring s len)))))
-
- (pass-if "buf right size"
- (let* ((s "hello, world!")
- (len (string-length s))
- (buf (make-string len #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? buf (substring s 0 len))
- (= (read-string! buf p) 0)
- (string=? buf (substring s 0 len)))))
-
- (pass-if "buf bigger"
- (let* ((s "hello, world!")
- (len (string-length s))
- (buf (make-string (1+ len) #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? (substring buf 0 len) s)
- (= (read-string! buf p) 0)
- (string=? (substring buf 0 len) s)
- (string=? (substring buf len) "."))))))
-
-;;; Local Variables:
-;;; eval: (put 'with-test-prefix 'scheme-indent-function 1)
-;;; eval: (put 'pass-if 'scheme-indent-function 1)
-;;; End:
+;;;; rdelim.test --- Delimited I/O. -*- mode: scheme; coding: utf-8; -*-
+;;;; Ludovic Courtès <ludo@gnu.org>
+;;;;
+;;;; Copyright (C) 2011, 2013, 2014 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-rdelim)
+ #:use-module (ice-9 rdelim)
+ #:use-module ((rnrs io ports) #:select (open-bytevector-input-port))
+ #:use-module (test-suite lib))
+
+(with-test-prefix "read-line"
+
+ (pass-if "one line"
+ (let* ((s "hello, world")
+ (p (open-input-string s)))
+ (and (string=? s (read-line p))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, trim"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? (string-tokenize s)
+ (list (read-line p) (read-line p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, concat"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '("foo\n" "bar\n")
+ (list (read-line p 'concat)
+ (read-line p 'concat)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, peek"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '("foo" #\newline "bar" #\newline)
+ (list (read-line p 'peek) (read-char p)
+ (read-line p 'peek) (read-char p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, split"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '(("foo" . #\newline)
+ ("bar" . #\newline))
+ (list (read-line p 'split)
+ (read-line p 'split)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two Greek lines, trim"
+ (let* ((s "λαμβδα\nμυ\n")
+ (p (open-input-string s)))
+ (and (equal? (string-tokenize s)
+ (list (read-line p) (read-line p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "decoding error"
+ (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
+ (set-port-encoding! p "UTF-8")
+ (set-port-conversion-strategy! p 'error)
+ (catch 'decoding-error
+ (lambda ()
+ (read-line p)
+ #f)
+ (lambda (key subr message err port)
+ (and (eq? port p)
+
+ ;; PORT should now point past the error.
+ (string=? (read-line p) "BCD")
+ (eof-object? (read-line p)))))))
+
+ (pass-if "decoding error, substitute"
+ (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
+ (set-port-encoding! p "UTF-8")
+ (set-port-conversion-strategy! p 'substitute)
+ (and (string=? (read-line p) "A?BCD")
+ (eof-object? (read-line p))))))
+
+\f
+(with-test-prefix "read-delimited"
+
+ (pass-if "delimiter hit"
+ (let ((p (open-input-string "hello, world!")))
+ (and (string=? "hello" (read-delimited ",.;" p))
+ (string=? " world!" (read-delimited ",.;" p))
+ (eof-object? (read-delimited ",.;" p)))))
+
+ (pass-if "delimiter hit, split"
+ (equal? '("hello" . #\,)
+ (read-delimited ",.;"
+ (open-input-string "hello, world!")
+ 'split)))
+
+ (pass-if "delimiter hit, concat"
+ (equal? '"hello,"
+ (read-delimited ",.;" (open-input-string "hello, world!")
+ 'concat)))
+
+ (pass-if "delimiter hit, peek"
+ (let ((p (open-input-string "hello, world!")))
+ (and (string=? "hello" (read-delimited ",.;" p 'peek))
+ (char=? #\, (peek-char p)))))
+
+ (pass-if "eof"
+ (eof-object? (read-delimited "}{" (open-input-string "")))))
+
+\f
+(with-test-prefix "read-delimited!"
+
+ (pass-if "delimiter hit"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p))
+ (string=? (substring s 0 5) "hello")
+ (= 7 (read-delimited! ",.;" s p))
+ (string=? (substring s 0 7) " world!")
+ (eof-object? (read-delimited! ",.;" s p)))))
+
+ (pass-if "delimiter hit, start+end"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p 'trim 10 30))
+ (string=? (substring s 10 15) "hello"))))
+
+ (pass-if "delimiter hit, split"
+ (let ((s (make-string 123)))
+ (and (equal? '(5 . #\,)
+ (read-delimited! ",.;" s
+ (open-input-string "hello, world!")
+ 'split))
+ (string=? (substring s 0 5) "hello"))))
+
+ (pass-if "delimiter hit, concat"
+ (let ((s (make-string 123)))
+ (and (= 6 (read-delimited! ",.;" s
+ (open-input-string "hello, world!")
+ 'concat))
+ (string=? (substring s 0 6) "hello,"))))
+
+ (pass-if "delimiter hit, peek"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p 'peek))
+ (string=? (substring s 0 5) "hello")
+ (char=? #\, (peek-char p)))))
+
+ (pass-if "string too small"
+ (let ((s (make-string 7)))
+ (and (= 7 (read-delimited! "}{" s
+ (open-input-string "hello, world!")))
+ (string=? s "hello, "))))
+
+ (pass-if "string too small, start+end"
+ (let ((s (make-string 123)))
+ (and (= 7 (read-delimited! "}{" s
+ (open-input-string "hello, world!")
+ 'trim
+ 70 77))
+ (string=? (substring s 70 77) "hello, "))))
+
+ (pass-if "string too small, split"
+ (let ((s (make-string 7)))
+ (and (equal? '(7 . #f)
+ (read-delimited! "}{" s
+ (open-input-string "hello, world!")
+ 'split))
+ (string=? s "hello, "))))
+
+ (pass-if "eof"
+ (eof-object? (read-delimited! ":" (make-string 7)
+ (open-input-string ""))))
+
+ (pass-if "eof, split"
+ (eof-object? (read-delimited! ":" (make-string 7)
+ (open-input-string "")))))
+
+(with-test-prefix "read-string"
+
+ (pass-if "short string"
+ (let* ((s "hello, world!")
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
+ (string=? (read-string p) ""))))
+
+ (pass-if "100 chars"
+ (let* ((s (make-string 100 #\space))
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
+ (string=? (read-string p) ""))))
+
+ (pass-if "longer than 100 chars"
+ (let* ((s (string-concatenate (make-list 20 "hello, world!")))
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
+ (string=? (read-string p) ""))))
+
+ (pass-if-equal "longer than 100 chars, with limit"
+ "hello, world!"
+ (let* ((s (string-concatenate (make-list 20 "hello, world!")))
+ (p (open-input-string s)))
+ (read-string p 13))))
+
+(with-test-prefix "read-string!"
+
+ (pass-if "buf smaller"
+ (let* ((s "hello, world!")
+ (len (1- (string-length s)))
+ (buf (make-string len #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? buf (substring s 0 len))
+ (= (read-string! buf p) 1)
+ (string=? (substring buf 0 1) (substring s len)))))
+
+ (pass-if "buf right size"
+ (let* ((s "hello, world!")
+ (len (string-length s))
+ (buf (make-string len #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? buf (substring s 0 len))
+ (= (read-string! buf p) 0)
+ (string=? buf (substring s 0 len)))))
+
+ (pass-if "buf bigger"
+ (let* ((s "hello, world!")
+ (len (string-length s))
+ (buf (make-string (1+ len) #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? (substring buf 0 len) s)
+ (= (read-string! buf p) 0)
+ (string=? (substring buf 0 len) s)
+ (string=? (substring buf len) ".")))))
+
+;;; Local Variables:
+;;; eval: (put 'with-test-prefix 'scheme-indent-function 1)
+;;; eval: (put 'pass-if 'scheme-indent-function 1)
+;;; End:
;;;; reader.test --- Reader test. -*- coding: iso-8859-1; mode: scheme -*-
;;;;
-;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2014
+;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015
;;;; Free Software Foundation, Inc.
;;;;
;;;; Jim Blandy <jimb@red-bean.com>
(define (read-string s)
- (with-fluids ((%default-port-encoding #f))
- (with-input-from-string s (lambda () (read)))))
+ (with-input-from-string s (lambda () (read))))
(define (with-read-options opts thunk)
(let ((saved-options (read-options)))
(with-latin1-locale body ...)
(begin body ...)))))
-;; Since `regexp-quote' uses string ports, and since it is used below
-;; with non-ASCII characters, these ports must be Unicode-capable.
-(define-syntax with-unicode
- (syntax-rules ()
- ((_ exp)
- (with-fluids ((%default-port-encoding "UTF-8"))
- exp))))
+(define char-code-limit 256)
(with-test-prefix "regexp-quote"
(s (string c)))
(pass-if (list "char" i (format #f "~s ~s" c s))
(with-ascii-or-latin1-locale i
- (let* ((q (with-unicode (regexp-quote s)))
+ (let* ((q (regexp-quote s))
(m (regexp-exec (make-regexp q flag) s)))
(and (= 0 (match:start m))
(= 1 (match:end m))))))))
((>= i 256))
(let* ((c (integer->char i))
(s (string #\a c))
- (q (with-unicode (regexp-quote s))))
+ (q (regexp-quote s)))
(pass-if (list "string \"aX\"" i (format #f "~s ~s ~s" c s q))
(with-ascii-or-latin1-locale i
(let* ((m (regexp-exec (make-regexp q flag) s)))
(pass-if "string of all chars"
(with-latin1-locale
- (let ((m (regexp-exec (make-regexp (with-unicode
- (regexp-quote allchars))
- flag) allchars)))
+ (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
+ flag)
+ allchars)))
(and (= 0 (match:start m))
(= (string-length allchars) (match:end m)))))))))
lst)))
--- /dev/null
+;;;; rtl-compilation.test --- test suite for compiling via bytecode -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2013 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 bytecode-compilation)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system vm loader))
+
+(define* (compile-via-bytecode exp #:key peval? cse? (env (make-fresh-user-module)))
+ (load-thunk-from-memory
+ (compile exp #:env env #:to 'bytecode
+ #:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
+
+(define* (run-bytecode exp #:key (env (make-fresh-user-module)))
+ (let ((thunk (compile-via-bytecode exp #:env env)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module env)
+ (thunk)))))
+
+(with-test-prefix "tail context"
+ (pass-if-equal 1
+ (run-bytecode '(let ((x 1)) x)))
+
+ (pass-if-equal 1
+ (run-bytecode 1))
+
+ (pass-if-equal (if #f #f)
+ (run-bytecode '(if #f #f)))
+
+ (pass-if-equal "top-level define"
+ (list (if #f #f) 1)
+ (let ((mod (make-fresh-user-module)))
+ (let ((result (run-bytecode '(define v 1) #:env mod)))
+ (list result (module-ref mod 'v)))))
+
+ (pass-if-equal "top-level set!"
+ (list (if #f #f) 1)
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'v #f)
+ (let ((result (run-bytecode '(set! v 1) #:env mod)))
+ (list result (module-ref mod 'v)))))
+
+ (pass-if-equal "top-level apply [single value]"
+ 8
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'args '(2 3))
+ (run-bytecode '(apply expt args) #:env mod)))
+
+ (pass-if-equal "top-level apply [zero values]"
+ '()
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'proc (lambda () (values)))
+ (module-define! mod 'args '())
+ (call-with-values
+ (lambda () (run-bytecode '(apply proc args) #:env mod))
+ list)))
+
+ (pass-if-equal "top-level apply [two values]"
+ '(1 2)
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'proc (lambda (n d) (floor/ n d)))
+ (module-define! mod 'args '(5 3))
+ (call-with-values
+ (lambda () (run-bytecode '(apply proc args) #:env mod))
+ list)))
+
+ (pass-if-equal "call-with-values"
+ '(1 2 3)
+ ((run-bytecode '(lambda (n d)
+ (call-with-values (lambda () (floor/ n d))
+ (lambda (q r) (list q r (+ q r))))))
+ 5 3))
+
+ (pass-if-equal cons
+ (run-bytecode 'cons))
+
+ (pass-if-equal 1
+ ((run-bytecode '(lambda () 1))))
+
+ (pass-if-equal 1
+ ((run-bytecode '(lambda (x) 1)) 2))
+
+ (pass-if-equal 1
+ ((run-bytecode '(lambda (x) x)) 1))
+
+ (pass-if-equal 6
+ ((((run-bytecode '(lambda (x)
+ (lambda (y)
+ (lambda (z)
+ (+ x y z))))) 1) 2) 3))
+
+ (pass-if-equal 1
+ (run-bytecode '(identity 1)))
+
+ (pass-if-equal '(1 . 2)
+ (run-bytecode '(cons 1 2)))
+
+ (pass-if-equal '(1 2)
+ (call-with-values (lambda () (run-bytecode '(values 1 2))) list))
+
+ (pass-if-equal 28
+ ((run-bytecode '(lambda (x y z rest) (apply + x y z rest)))
+ 2 3 5 '(7 11)))
+
+ ;; prompts
+ )
+
+(with-test-prefix "value context"
+ 1
+ )
+
+(with-test-prefix "drop context"
+ 1
+ )
+
+(with-test-prefix "test context"
+ 1
+ )
+
+(with-test-prefix "values context"
+ (pass-if-equal '(3 . 1)
+ (run-bytecode
+ '(let ((rat (lambda (n d)
+ (call-with-values
+ (lambda () (floor/ n d))
+ (lambda (q r)
+ (cons q r))))))
+ (rat 10 3)))))
+
+(with-test-prefix "contification"
+ (pass-if ((run-bytecode '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (even? x)))
+ '(1 2 3 4)))
+
+ (pass-if (not ((run-bytecode '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (even? x)))
+ '(1 2 3))))
+
+ (pass-if-equal '(#t)
+ ((run-bytecode '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (list (even? x))))
+ '(1 2 3 4)))
+
+ ;; An irreducible loop between even? and odd?.
+ (pass-if-equal '#t
+ ((run-bytecode '(lambda (x do-even?)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (if do-even? (even? x) (odd? x))))
+ '(1 2 3 4)
+ #t)))
+
+(with-test-prefix "case-lambda"
+ (pass-if-equal "simple"
+ '(0 3 9 28)
+ (let ((proc (run-bytecode '(case-lambda
+ (() 0)
+ ((x) x)
+ ((x y) (+ x y))
+ ((x y z . rest) (apply + x y z rest))))))
+ (map (lambda (args) (apply proc args))
+ '(() (3) (2 7) (2 3 5 7 11)))))
+
+ (pass-if-exception "no match"
+ exception:wrong-num-args
+ ((run-bytecode '(case-lambda ((x) x) ((x y) (+ x y))))
+ 1 2 3))
+
+ (pass-if-exception "zero clauses called with no args"
+ exception:wrong-num-args
+ ((run-bytecode '(case-lambda))))
+
+ (pass-if-exception "zero clauses called with args"
+ exception:wrong-num-args
+ ((run-bytecode '(case-lambda)) 1)))
+
+(with-test-prefix "mixed contexts"
+ (pass-if-equal "sequences" '(3 4 5)
+ (let* ((pair (cons 1 2))
+ (result ((run-bytecode '(lambda (pair)
+ (set-car! pair 3)
+ (set-cdr! pair 4)
+ 5))
+ pair)))
+ (list (car pair)
+ (cdr pair)
+ result)))
+
+ (pass-if-equal "mutable lexicals" 2
+ (run-bytecode '(let ((n 1)) (set! n 2) n))))
--- /dev/null
+;;;; Low-level tests of the bytecode assembler -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 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 (tests bytecode)
+ #:use-module (test-suite lib)
+ #:use-module (system vm assembler)
+ #:use-module (system vm program)
+ #:use-module (system vm loader)
+ #:use-module (system vm linker)
+ #:use-module (system vm debug))
+
+(define (assemble-program instructions)
+ "Take the sequence of instructions @var{instructions}, assemble them
+into bytecode, link an image, and load that image from memory. Returns
+a procedure."
+ (let ((asm (make-assembler)))
+ (emit-text asm instructions)
+ (load-thunk-from-memory (link-assembly asm #:page-aligned? #f))))
+
+(define-syntax-rule (assert-equal val expr)
+ (let ((x val))
+ (pass-if (object->string x) (equal? expr x))))
+
+(define (return-constant val)
+ (assemble-program `((begin-program foo
+ ((name . foo)))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 ,val)
+ (return 1)
+ (end-arity)
+ (end-program))))
+
+(define-syntax-rule (assert-constants val ...)
+ (begin
+ (assert-equal val ((return-constant val)))
+ ...))
+
+(with-test-prefix "load-constant"
+ (assert-constants
+ 1
+ -1
+ 0
+ most-positive-fixnum
+ most-negative-fixnum
+ #t
+ #\c
+ (integer->char 16000)
+ 3.14
+ "foo"
+ 'foo
+ #:foo
+ "æ" ;; a non-ASCII Latin-1 string
+ "λ" ;; non-ascii, non-latin-1
+ '(1 . 2)
+ '(1 2 3 4)
+ #(1 2 3)
+ #("foo" "bar" 'baz)
+ #vu8()
+ #vu8(1 2 3 4 128 129 130)
+ #u32()
+ #u32(1 2 3 4 128 129 130 255 1000)
+ ;; FIXME: Add more tests for arrays (uniform and otherwise)
+ ))
+
+(with-test-prefix "static procedure"
+ (assert-equal 42
+ (((assemble-program `((begin-program foo
+ ((name . foo)))
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 bar)
+ (return 1)
+ (end-arity)
+ (end-program)
+ (begin-program bar
+ ((name . bar)))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))))
+
+(with-test-prefix "loop"
+ (assert-equal (* 999 500)
+ (let ((sumto
+ (assemble-program
+ ;; 0: limit
+ ;; 1: n
+ ;; 2: accum
+ '((begin-program countdown
+ ((name . countdown)))
+ (begin-standard-arity (x) 4 #f)
+ (definition x 1)
+ (br fix-body)
+ (label loop-head)
+ (br-if-= 2 1 #f out)
+ (add 3 2 3)
+ (add1 2 2)
+ (br loop-head)
+ (label fix-body)
+ (load-constant 2 0)
+ (load-constant 3 0)
+ (br loop-head)
+ (label out)
+ (return 3)
+ (end-arity)
+ (end-program)))))
+ (sumto 1000))))
+
+(with-test-prefix "accum"
+ (assert-equal (+ 1 2 3)
+ (let ((make-accum
+ (assemble-program
+ ;; 0: elt
+ ;; 1: tail
+ ;; 2: head
+ '((begin-program make-accum
+ ((name . make-accum)))
+ (begin-standard-arity () 3 #f)
+ (load-constant 1 0)
+ (box 1 1)
+ (make-closure 2 accum 1)
+ (free-set! 2 1 0)
+ (return 2)
+ (end-arity)
+ (end-program)
+ (begin-program accum
+ ((name . accum)))
+ (begin-standard-arity (x) 4 #f)
+ (definition x 1)
+ (free-ref 2 0 0)
+ (box-ref 3 2)
+ (add 3 3 1)
+ (box-set! 2 3)
+ (return 3)
+ (end-arity)
+ (end-program)))))
+ (let ((accum (make-accum)))
+ (accum 1)
+ (accum 2)
+ (accum 3)))))
+
+(with-test-prefix "call"
+ (assert-equal 42
+ (let ((call ;; (lambda (x) (x))
+ (assemble-program
+ '((begin-program call
+ ((name . call)))
+ (begin-standard-arity (f) 7 #f)
+ (definition f 1)
+ (mov 5 1)
+ (call 5 1)
+ (receive 2 5 7)
+ (return 2)
+ (end-arity)
+ (end-program)))))
+ (call (lambda () 42))))
+
+ (assert-equal 6
+ (let ((call-with-3 ;; (lambda (x) (x 3))
+ (assemble-program
+ '((begin-program call-with-3
+ ((name . call-with-3)))
+ (begin-standard-arity (f) 7 #f)
+ (definition f 1)
+ (mov 5 1)
+ (load-constant 6 3)
+ (call 5 2)
+ (receive 2 5 7)
+ (return 2)
+ (end-arity)
+ (end-program)))))
+ (call-with-3 (lambda (x) (* x 2))))))
+
+(with-test-prefix "tail-call"
+ (assert-equal 3
+ (let ((call ;; (lambda (x) (x))
+ (assemble-program
+ '((begin-program call
+ ((name . call)))
+ (begin-standard-arity (f) 2 #f)
+ (definition f 1)
+ (mov 0 1)
+ (tail-call 1)
+ (end-arity)
+ (end-program)))))
+ (call (lambda () 3))))
+
+ (assert-equal 6
+ (let ((call-with-3 ;; (lambda (x) (x 3))
+ (assemble-program
+ '((begin-program call-with-3
+ ((name . call-with-3)))
+ (begin-standard-arity (f) 2 #f)
+ (definition f 1)
+ (mov 0 1) ;; R0 <- R1
+ (load-constant 1 3) ;; R1 <- 3
+ (tail-call 2)
+ (end-arity)
+ (end-program)))))
+ (call-with-3 (lambda (x) (* x 2))))))
+
+(with-test-prefix "cached-toplevel-ref"
+ (assert-equal 5.0
+ (let ((get-sqrt-trampoline
+ (assemble-program
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
+ (begin-standard-arity () 2 #f)
+ (current-module 1)
+ (cache-current-module! 1 sqrt-scope)
+ (load-static-procedure 1 sqrt-trampoline)
+ (return 1)
+ (end-arity)
+ (end-program)
+
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
+ (begin-standard-arity (x) 3 #f)
+ (definition x 1)
+ (cached-toplevel-box 2 sqrt-scope sqrt #t)
+ (box-ref 0 2)
+ (tail-call 2)
+ (end-arity)
+ (end-program)))))
+ ((get-sqrt-trampoline) 25.0))))
+
+(define *top-val* 0)
+
+(with-test-prefix "cached-toplevel-set!"
+ (let ((prev *top-val*))
+ (assert-equal (1+ prev)
+ (let ((make-top-incrementor
+ (assemble-program
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
+ (begin-standard-arity () 2 #f)
+ (current-module 1)
+ (cache-current-module! 1 top-incrementor)
+ (load-static-procedure 1 top-incrementor)
+ (return 1)
+ (end-arity)
+ (end-program)
+
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
+ (begin-standard-arity () 3 #f)
+ (cached-toplevel-box 1 top-incrementor *top-val* #t)
+ (box-ref 2 1)
+ (add1 2 2)
+ (box-set! 1 2)
+ (reset-frame 1)
+ (return-values)
+ (end-arity)
+ (end-program)))))
+ ((make-top-incrementor))
+ *top-val*))))
+
+(with-test-prefix "cached-module-ref"
+ (assert-equal 5.0
+ (let ((get-sqrt-trampoline
+ (assemble-program
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 sqrt-trampoline)
+ (return 1)
+ (end-arity)
+ (end-program)
+
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
+ (begin-standard-arity (x) 3 #f)
+ (definition x 1)
+ (cached-module-box 2 (guile) sqrt #t #t)
+ (box-ref 0 2)
+ (tail-call 2)
+ (end-arity)
+ (end-program)))))
+ ((get-sqrt-trampoline) 25.0))))
+
+(with-test-prefix "cached-module-set!"
+ (let ((prev *top-val*))
+ (assert-equal (1+ prev)
+ (let ((make-top-incrementor
+ (assemble-program
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 top-incrementor)
+ (return 1)
+ (end-arity)
+ (end-program)
+
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
+ (begin-standard-arity () 3 #f)
+ (cached-module-box 1 (tests bytecode) *top-val* #f #t)
+ (box-ref 2 1)
+ (add1 2 2)
+ (box-set! 1 2)
+ (return 2)
+ (end-arity)
+ (end-program)))))
+ ((make-top-incrementor))
+ *top-val*))))
+
+(with-test-prefix "debug contexts"
+ (let ((return-3 (assemble-program
+ '((begin-program return-3 ((name . return-3)))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 3)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+ (pass-if "program name"
+ (and=> (find-program-debug-info (program-code return-3))
+ (lambda (pdi)
+ (equal? (program-debug-info-name pdi)
+ 'return-3))))
+
+ (pass-if "program address"
+ (and=> (find-program-debug-info (program-code return-3))
+ (lambda (pdi)
+ (equal? (program-debug-info-addr pdi)
+ (program-code return-3)))))))
+
+(with-test-prefix "procedure name"
+ (pass-if-equal 'foo
+ (procedure-name
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "simple procedure arity"
+ (pass-if-equal "#<procedure foo ()>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+ (pass-if-equal "#<procedure foo (x y)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity (x y) 3 #f)
+ (definition x 1)
+ (definition y 2)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ (pass-if-equal "#<procedure foo (x #:optional y . z)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-opt-arity (x) (y) z 4 #f)
+ (definition x 1)
+ (definition y 2)
+ (definition z 3)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "procedure docstrings"
+ (pass-if-equal "qux qux"
+ (procedure-documentation
+ (assemble-program
+ '((begin-program foo ((name . foo) (documentation . "qux qux")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "procedure properties"
+ ;; No properties.
+ (pass-if-equal '()
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ())
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ ;; Name and docstring (which actually don't go out to procprops).
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux"))
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ((name . foo) (documentation . "qux qux")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ ;; A property that actually needs serialization.
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo"))
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ ;; Procedure-name still works in this case.
+ (pass-if-equal 'foo
+ (procedure-name
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program))))))
(pass-if-valid-arguments "lambda* with keywords"
(lambda* (a b #:key (k 42) l) #f)
((required . (a b)) (optional)
- (keyword . ((#:k . 2) (#:l . 3))) (allow-other-keys? . #f)
+ (keyword . ((#:k . 3) (#:l . 4))) (allow-other-keys? . #f)
(rest . #f)))
(pass-if-valid-arguments "lambda* with keywords and a-o-k"
(lambda* (a b #:key (k 42) #:allow-other-keys) #f)
((required . (a b)) (optional)
- (keyword . ((#:k . 2))) (allow-other-keys? . #t)
+ (keyword . ((#:k . 3))) (allow-other-keys? . #t)
(rest . #f)))
(pass-if-valid-arguments "lambda* with optionals, keys, and rest"
(lambda* (a b #:optional o p #:key k l #:rest r) #f)
((required . (a b)) (optional . (o p))
- (keyword . ((#:k . 5) (#:l . 6))) (allow-other-keys? . #f)
+ (keyword . ((#:k . 6) (#:l . 7))) (allow-other-keys? . #f)
(rest . r)))
(pass-if "aok? is preserved"
;;;; signals.test --- test suite for Guile's signal functions -*- scheme -*-
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2014 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
;;;; Boston, MA 02110-1301 USA
(define-module (test-suite test-signals)
+ #:use-module (ice-9 match)
#:use-module (test-suite lib))
(with-test-prefix "sigaction"
(sigaction SIGINT 51))
)
+
+(define (time-pair->secs secs-usecs-pair)
+ (match secs-usecs-pair
+ ((secs . usecs)
+ (+ secs (/ usecs 1e6)))))
+
+(when (defined? 'setitimer)
+ (with-test-prefix "setitimer"
+ (with-test-prefix "current itimers are 0"
+ (pass-if "ITIMER_REAL"
+ (equal? (setitimer ITIMER_REAL 0 0 0 0)
+ '((0 . 0) (0 . 0))))
+ (pass-if "ITIMER_VIRTUAL"
+ (equal? (setitimer ITIMER_VIRTUAL 0 0 0 0)
+ '((0 . 0) (0 . 0))))
+ (pass-if "ITIMER_PROF"
+ (equal? (setitimer ITIMER_PROF 0 0 0 0)
+ '((0 . 0) (0 . 0)))))
+
+ (with-test-prefix "setting values correctly"
+ (pass-if "initial setting"
+ (equal? (setitimer ITIMER_PROF 1 0 3 0)
+ '((0 . 0) (0 . 0))))
+ (pass-if "reset to zero"
+ (match (setitimer ITIMER_PROF 0 0 0 0)
+ ((interval value)
+ ;; We don't presume that the timer is strictly lower than the
+ ;; value at which we set it, given its limited internal
+ ;; precision. Assert instead that the timer is between 2 and
+ ;; 3.5 seconds.
+ (and (<= 0.9 (time-pair->secs interval) 1.1)
+ (<= 2.0 (time-pair->secs value) 3.5))))))
+
+ (with-test-prefix "usecs > 1e6"
+ (pass-if "initial setting"
+ (equal? (setitimer ITIMER_PROF 1 0 0 #e3e6)
+ '((0 . 0) (0 . 0))))
+ (pass-if "reset to zero"
+ (match (setitimer ITIMER_PROF 0 0 0 0)
+ ((interval value)
+ ;; We don't presume that the timer is strictly lower than the
+ ;; value at which we set it, given its limited internal
+ ;; precision. Assert instead that the timer is between 2 and
+ ;; 3.5 seconds.
+ (and (<= 0.9 (time-pair->secs interval) 1.1)
+ (<= 2.0 (time-pair->secs value) 3.5)
+ (match value
+ ((secs . usecs)
+ (<= 0 usecs 999999))))))))))
;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*-
;;;;
-;;;; Copyright (C) 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2012, 2013 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-1))
(define (read-string s)
- (with-fluids ((%default-port-encoding #f))
- (with-input-from-string s read)))
+ (with-input-from-string s read))
(define (with-read-options opts thunk)
(let ((saved-options (read-options)))
;; guile-lib -*- scheme -*-
-;; Copyright (C) 2004, 2009, 2010 Andy Wingo <wingo at pobox dot com>
+;; Copyright (C) 2004, 2009, 2010, 2014 Andy Wingo <wingo at pobox dot com>
;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
;; This library is free software; you can redistribute it and/or
((car funcs) x)
(loop (- x 1) (cdr funcs))))))))
- (let ((num-calls 80000)
+ (let ((num-calls 200000)
(funcs (circular-list (make-func) (make-func) (make-func))))
;; Run test. 20000 us == 200 Hz.
(if (and a-data b-data c-data)
(let* ((samples (map statprof-call-data-cum-samples
(list a-data b-data c-data)))
- (average (/ (apply + samples) 3))
- (max-allowed-drift 0.30) ; 30%
- (diffs (map (lambda (x) (abs (- x average)))
+ (expected (/ (apply + samples) 3.0))
+ (diffs (map (lambda (x) (abs (- x expected)))
samples))
(max-diff (apply max diffs)))
- (let ((drift-fraction (/ max-diff average)))
- (or (< drift-fraction max-allowed-drift)
- ;; don't stop the test suite for what statistically is
- ;; bound to happen.
- (throw 'unresolved (pk average drift-fraction)))))
+ (or (< max-diff (sqrt expected))
+ ;; don't stop the test suite for what statistically is
+ ;; bound to happen.
+ (begin
+ (format (current-warning-port)
+ ";;; warning: max diff ~a > (sqrt ~a)\n"
+ max-diff expected)
+ (throw 'unresolved))))
;; Samples were not collected for at least one of the
;; functions, possibly because NUM-CALLS is too low compared
;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009, 2010,
-;;;; 2011 Free Software Foundation, Inc.
+;;;; 2011, 2013 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 "string"
(pass-if-exception "convert circular list to string"
- exception:wrong-type-arg
- (let ((foo (list #\a #\b #\c)))
- (set-cdr! (cddr foo) (cdr foo))
- (apply string foo))))
+ '(wrong-type-arg . "Apply to non-list")
+ (let ((foo (list #\a #\b #\c)))
+ (set-cdr! (cddr foo) (cdr foo))
+ (apply string foo))))
(with-test-prefix "string-split"
(define-module (test-suite test-syncase)
#:use-module (test-suite lib)
#:use-module (system base compile)
+ #:use-module (ice-9 regex)
#:use-module ((srfi srfi-1) :select (member)))
(define-syntax plus
(parameterize ((current-warning-port (%make-void-port "w")))
(eval '(if #f (baz) #t)
(resolve-module '(test-suite test-syncase-3)))))
+
+(use-modules (system syntax))
+
+(with-test-prefix "syntax-local-binding"
+ (define-syntax syntax-type
+ (lambda (x)
+ (syntax-case x ()
+ ((_ id resolve?)
+ (call-with-values
+ (lambda ()
+ (syntax-local-binding
+ #'id
+ #:resolve-syntax-parameters? (syntax->datum #'resolve?)))
+ (lambda (type value)
+ (with-syntax ((type (datum->syntax #'id type)))
+ #''type)))))))
+
+ (define-syntax-parameter foo
+ (syntax-rules ()))
+
+ (pass-if "syntax-parameters (resolved)"
+ (equal? (syntax-type foo #t) 'macro))
+
+ (pass-if "syntax-parameters (unresolved)"
+ (equal? (syntax-type foo #f) 'syntax-parameter)))
+
+;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
+(define-syntax pass-if-syntax-error
+ (syntax-rules ()
+ ((_ name pat exp)
+ (pass-if name
+ (catch 'syntax-error
+ (lambda () exp (error "expected syntax-error exception"))
+ (lambda (k who what where form . maybe-subform)
+ (if (if (pair? pat)
+ (and (eq? who (car pat))
+ (string-match (cdr pat) what))
+ (string-match pat what))
+ #t
+ (error "unexpected syntax-error exception" what pat))))))))
+
+(with-test-prefix "primitives"
+ (pass-if-syntax-error "primref in default module"
+ "failed to match"
+ (macroexpand '(@@ primitive cons)))
+
+ (pass-if-syntax-error "primcall in default module"
+ "failed to match"
+ (macroexpand '((@@ primitive cons) 1 2)))
+
+ (pass-if-equal "primcall in (guile)"
+ '(1 . 2)
+ (@@ @@ (guile) ((@@ primitive cons) 1 2)))
+
+ (pass-if-syntax-error "primref in (guile)"
+ "not in operator position"
+ (macroexpand '(@@ @@ (guile) (@@ primitive cons)))))
(define exception:too-many-args
"too many arguments")
+(define exception:wrong-number-of-values
+ '(wrong-number-of-args . "number of (values)|(arguments)"))
(define exception:zero-expression-sequence
"sequence of zero expressions")
-(define exception:define-values-wrong-number-of-return-values
- (cons 'wrong-number-of-args "^define-values: wrong number of return values returned by expression"))
-
+(define exception:variable-ref
+ '(misc-error . "Unbound variable"))
;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
(define-syntax pass-if-syntax-error
(with-test-prefix "bindings"
- (pass-if-syntax-error "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))))
+ (pass-if-exception "initial bindings are undefined"
+ exception:variable-ref
+ (eval '(let ((x 1))
+ (letrec ((x 1) (y x)) y))
+ (interaction-environment))))
(with-test-prefix "bad bindings"
(with-test-prefix "bindings"
- (pass-if-syntax-error "initial bindings are undefined"
- exception:used-before-defined
- (begin
- ;; 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 y) (y 1)) y))))
+ (pass-if-exception "initial bindings are undefined"
+ exception:variable-ref
+ (eval '(letrec* ((x y) (y 1)) y)
+ (interaction-environment))))
(with-test-prefix "bad bindings"
(interaction-environment))))
(with-test-prefix "referencing previous values"
- (pass-if (equal? (letrec ((a (cons 'foo 'bar))
- (b a))
+ (pass-if (equal? (letrec* ((a (cons 'foo 'bar))
+ (b a))
b)
'(foo . bar)))
(pass-if (equal? (let ()
(pass-if-syntax-error "(define)"
exception:generic-syncase-error
(eval '(define)
- (interaction-environment)))))
+ (interaction-environment))))
+
+ (pass-if "module scoping"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-1)
+ #:export (define-10))
+ (define-syntax-rule (define-10 name)
+ (begin
+ (define t 10)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-2)
+ #:use-module (top-level-define/module-scoping-1))
+ (define-10 foo)
+ (foo))
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, same symbolic name"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-3))
+ (define a 10)
+ (define-module (top-level-define/module-scoping-4)
+ #:use-module (top-level-define/module-scoping-3))
+ (define a (@@ (top-level-define/module-scoping-3) a))
+ a)
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, introduced names"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-5)
+ #:export (define-constant))
+ (define-syntax-rule (define-constant name val)
+ (begin
+ (define t val)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-6)
+ #:use-module (top-level-define/module-scoping-5))
+ (define-constant foo 10)
+ (define-constant bar 20)
+ (foo))
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, duplicate introduced name"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-7)
+ #:export (define-constant))
+ (define-syntax-rule (define-constant name val)
+ (begin
+ (define t val)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-8)
+ #:use-module (top-level-define/module-scoping-7))
+ (define-constant foo 10)
+ (define-constant foo 20)
+ (foo))
+ (current-module))
+ 20)))
(with-test-prefix "internal define"
(interaction-environment)))
(pass-if-exception "expected 0 values, got 1"
- exception:define-values-wrong-number-of-return-values
+ exception:wrong-number-of-values
(eval '(define-values () 1)
(interaction-environment)))
(pass-if-exception "expected 1 value, got 0"
- exception:define-values-wrong-number-of-return-values
+ exception:wrong-number-of-values
(eval '(define-values (x) (values))
(interaction-environment)))
(pass-if-exception "expected 1 value, got 2"
- exception:define-values-wrong-number-of-return-values
+ exception:wrong-number-of-values
(eval '(define-values (x) (values 1 2))
(interaction-environment)))
(pass-if-exception "expected 1 value with tail, got 0"
- exception:define-values-wrong-number-of-return-values
+ exception:wrong-number-of-values
(eval '(define-values (x . y) (values))
(interaction-environment)))
(pass-if-exception "expected 2 value with tail, got 1"
- exception:define-values-wrong-number-of-return-values
+ exception:wrong-number-of-values
(eval '(define-values (x y . z) 1)
(interaction-environment)))
x))
(pass-if-exception "expected 0 values, got 1"
- exception:define-values-wrong-number-of-return-values
+ exception:wrong-number-of-values
(eval '(let ()
(define-values () 1)
#f)
(interaction-environment)))
(pass-if-exception "expected 1 value, got 0"
- exception:define-values-wrong-number-of-return-values
+ exception:wrong-number-of-values
(eval '(let ()
(define-values (x) (values))
#f)
(interaction-environment)))
(pass-if-exception "expected 1 value, got 2"
- exception:define-values-wrong-number-of-return-values
+ exception:wrong-number-of-values
(eval '(let ()
(define-values (x) (values 1 2))
#f)
(interaction-environment)))
(pass-if-exception "expected 1 value with tail, got 0"
- exception:define-values-wrong-number-of-return-values
+ exception:wrong-number-of-values
(eval '(let ()
(define-values (x . y) (values))
#f)
(interaction-environment)))
(pass-if-exception "expected 2 value with tail, got 1"
- exception:define-values-wrong-number-of-return-values
+ exception:wrong-number-of-values
(eval '(let ()
(define-values (x y . z) 1)
#f)
'((para (code "arg"))))
(test-body "@url{arg}"
'((para (uref (% (url "arg"))))))
+ (test-body "@url{@@}"
+ '((para (uref (% (url "@"))))))
+ (test-body "@url{@var{foo}}"
+ '((para (uref (% (url (var "foo")))))))
(test-body "@code{ }"
'((para (code))))
(test-body "@code{ @code{} }"
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013,
-;;;; 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2014 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 (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
- #:use-module (language glil)
#:use-module (srfi srfi-13))
-;; Of course, the GLIL that is emitted depends on the source info of the
-;; input. Here we're not concerned about that, so we strip source
-;; information from the incoming tree-il.
-
-(define (strip-source x)
- (post-order! (lambda (x) (set! (tree-il-src x) #f))
- x))
-
-(define-syntax assert-tree-il->glil
- (syntax-rules (with-partial-evaluation without-partial-evaluation
- with-options)
- ((_ with-partial-evaluation in pat test ...)
- (assert-tree-il->glil with-options (#:partial-eval? #t)
- in pat test ...))
- ((_ without-partial-evaluation in pat test ...)
- (assert-tree-il->glil with-options (#:partial-eval? #f)
- in pat test ...))
- ((_ with-options opts in pat test ...)
- (let ((exp 'in))
- (pass-if 'in
- (let ((glil (unparse-glil
- (compile (strip-source (parse-tree-il exp))
- #:from 'tree-il #:to 'glil
- #:opts 'opts))))
- (pmatch glil
- (pat (guard test ...) #t)
- (else #f))))))
- ((_ in pat test ...)
- (assert-tree-il->glil with-partial-evaluation
- in pat test ...))))
-
(define-syntax-rule (pass-if-primitives-resolved in expected)
(pass-if (format #f "primitives-resolved in ~s" 'in)
(let* ((module (let ((m (make-module)))
(beautify-user-module! m)
m))
(orig (parse-tree-il 'in))
- (resolved (expand-primitives! (resolve-primitives! orig module))))
+ (resolved (expand-primitives (resolve-primitives orig module))))
(or (equal? (unparse-tree-il resolved) 'expected)
(begin
(format (current-error-port)
(with-test-prefix "eqv?"
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const #f) (toplevel x))
- (apply (primitive eq?) (const #f) (toplevel x)))
+ (primcall eqv? (toplevel x) (const #f))
+ (primcall eq? (const #f) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const ()) (toplevel x))
- (apply (primitive eq?) (const ()) (toplevel x)))
+ (primcall eqv? (toplevel x) (const ()))
+ (primcall eq? (const ()) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const #t) (lexical x y))
- (apply (primitive eq?) (const #t) (lexical x y)))
+ (primcall eqv? (const #t) (lexical x y))
+ (primcall eq? (const #t) (lexical x y)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const this-is-a-symbol) (toplevel x))
- (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
+ (primcall eqv? (const this-is-a-symbol) (toplevel x))
+ (primcall eq? (const this-is-a-symbol) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const 42) (toplevel x))
- (apply (primitive eq?) (const 42) (toplevel x)))
+ (primcall eqv? (const 42) (toplevel x))
+ (primcall eq? (const 42) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const 42.0) (toplevel x))
- (apply (primitive eqv?) (const 42.0) (toplevel x)))
+ (primcall eqv? (const 42.0) (toplevel x))
+ (primcall eqv? (const 42.0) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const #nil) (toplevel x))
- (apply (primitive eq?) (const #nil) (toplevel x))))
+ (primcall eqv? (const #nil) (toplevel x))
+ (primcall eq? (const #nil) (toplevel x))))
(with-test-prefix "equal?"
(pass-if-primitives-resolved
- (apply (primitive equal?) (const #f) (toplevel x))
- (apply (primitive eq?) (const #f) (toplevel x)))
+ (primcall equal? (toplevel x) (const #f))
+ (primcall eq? (const #f) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const ()) (toplevel x))
- (apply (primitive eq?) (const ()) (toplevel x)))
+ (primcall equal? (toplevel x) (const ()))
+ (primcall eq? (const ()) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const #t) (lexical x y))
- (apply (primitive eq?) (const #t) (lexical x y)))
+ (primcall equal? (const #t) (lexical x y))
+ (primcall eq? (const #t) (lexical x y)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const this-is-a-symbol) (toplevel x))
- (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
+ (primcall equal? (const this-is-a-symbol) (toplevel x))
+ (primcall eq? (const this-is-a-symbol) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const 42) (toplevel x))
- (apply (primitive eq?) (const 42) (toplevel x)))
+ (primcall equal? (const 42) (toplevel x))
+ (primcall eq? (const 42) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const 42.0) (toplevel x))
- (apply (primitive equal?) (const 42.0) (toplevel x)))
+ (primcall equal? (const 42.0) (toplevel x))
+ (primcall equal? (const 42.0) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const #nil) (toplevel x))
- (apply (primitive eq?) (const #nil) (toplevel x)))))
+ (primcall equal? (const #nil) (toplevel x))
+ (primcall eq? (const #nil) (toplevel x)))))
\f
(with-test-prefix "tree-il->scheme"
(case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
(and (eq? a a1) (eq? b b1) (eq? c c1))))
-(with-test-prefix "void"
- (assert-tree-il->glil
- (void)
- (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
- (assert-tree-il->glil
- (begin (void) (const 1))
- (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
- (assert-tree-il->glil
- (apply (primitive +) (void) (const 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 () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
- (assert-tree-il->glil
- (begin (apply (toplevel foo) (const 1)) (void))
- (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 0 #f)
- (label ,l4)
- (void) (call return 1))
- (and (eq? l1 l3) (eq? l2 l4)))
- (assert-tree-il->glil
- (apply (toplevel foo) (apply (toplevel bar)))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
- (call tail-call 1))))
-
-(with-test-prefix "conditional"
- (assert-tree-il->glil
- (if (toplevel foo) (const 1) (const 2))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
- (const 1) (call return 1)
- (label ,l2) (const 2) (call return 1))
- (eq? l1 l2))
-
- (assert-tree-il->glil without-partial-evaluation
- (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (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
- (apply (primitive null?) (if (toplevel foo) (const 1) (const 2)))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
- (const 1) (branch br ,l2)
- (label ,l3) (const 2) (label ,l4)
- (call null? 1) (call return 1))
- (eq? l1 l3) (eq? l2 l4)))
-
-(with-test-prefix "primitive-ref"
- (assert-tree-il->glil
- (primitive +)
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
-
- (assert-tree-il->glil
- (begin (primitive +) (const #f))
- (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (apply (primitive null?) (primitive +))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
- (call return 1))))
-
-(with-test-prefix "lexical refs"
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1)) (lexical x y))
- (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 with-options (#:partial-eval? #f #:cse? #f)
- (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
- (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 without-partial-evaluation
- (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
- (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))))
-
-(with-test-prefix "lexical sets"
- (assert-tree-il->glil
- ;; 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 () (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)
- (unbind)))
-
- (assert-tree-il->glil
- (let (x) (y) ((const 1))
- (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
- (lexical x y)))
- (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)
- (unbind)))
-
- (assert-tree-il->glil
- (let (x) (y) ((const 1))
- (apply (primitive null?)
- (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
- (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)
- (unbind))))
-
-(with-test-prefix "module refs"
- (assert-tree-il->glil
- (@ (foo) bar)
- (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 () (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 () (std-prelude 0 0 #f) (label _)
- (module public ref (foo) bar)
- (call null? 1) (call return 1)))
-
- (assert-tree-il->glil
- (@@ (foo) bar)
- (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 () (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 () (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 () (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 () (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 () (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 () (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 () (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 () (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 () (std-prelude 0 0 #f) (label _)
- (toplevel ref bar)
- (call return 1)))
-
- (assert-tree-il->glil without-partial-evaluation
- (begin (toplevel bar) (const #f))
- (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 () (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 () (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 () (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 () (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 () (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 () (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 () (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 () (std-prelude 0 0 #f) (label _)
- (const 2) (call return 1)))
-
- (assert-tree-il->glil
- (begin (const 2) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- ;; This gets simplified by `peval'.
- (apply (primitive null?) (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const #f) (call return 1))))
-
-(with-test-prefix "letrec"
- ;; simple bindings -> let
- (assert-tree-il->glil without-partial-evaluation
- (letrec (x y) (x1 y1) ((const 10) (const 20))
- (apply (toplevel foo) (lexical x x1) (lexical y y1)))
- (program () (std-prelude 0 2 #f) (label _)
- (const 10) (const 20)
- (bind (x #f 0) (y #f 1))
- (lexical #t #f set 1) (lexical #t #f set 0)
- (toplevel ref foo)
- (lexical #t #f ref 0) (lexical #t #f ref 1)
- (call tail-call 2)
- (unbind)))
-
- ;; complex bindings -> box and set! within let
- (assert-tree-il->glil without-partial-evaluation
- (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
- (program () (std-prelude 0 4 #f) (label _)
- (void) (void) ;; what are these?
- (bind (x #t 0) (y #t 1))
- (lexical #t #t box 1) (lexical #t #t box 0)
- (call new-frame 0) (toplevel ref foo) (call call 0)
- (call new-frame 0) (toplevel ref bar) (call call 0)
- (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
- (lexical #t #f ref 2) (lexical #t #t set 0)
- (lexical #t #f ref 3) (lexical #t #t set 1)
- (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings
- (unbind)
- (lexical #t #t ref 0) (lexical #t #t ref 1)
- (call add 2) (call return 1) (unbind)))
-
- ;; complex bindings in letrec* -> box and set! in order
- (assert-tree-il->glil without-partial-evaluation
- (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
- (program () (std-prelude 0 2 #f) (label _)
- (void) (void) ;; what are these?
- (bind (x #t 0) (y #t 1))
- (lexical #t #t box 1) (lexical #t #t box 0)
- (call new-frame 0) (toplevel ref foo) (call call 0)
- (lexical #t #t set 0)
- (call new-frame 0) (toplevel ref bar) (call call 0)
- (lexical #t #t set 1)
- (lexical #t #t ref 0)
- (lexical #t #t ref 1)
- (call add 2) (call return 1) (unbind)))
-
- ;; simple bindings in letrec* -> equivalent to letrec
- (assert-tree-il->glil without-partial-evaluation
- (letrec* (x y) (xx yy) ((const 1) (const 2))
- (lexical y yy))
- (program () (std-prelude 0 1 #f) (label _)
- (const 2)
- (bind (y #f 0)) ;; X is removed, and Y is unboxed
- (lexical #t #f set 0)
- (lexical #t #f ref 0)
- (call return 1) (unbind))))
-
-(with-test-prefix "lambda"
- (assert-tree-il->glil
- (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 ()
- (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 ()
- (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 ()
- (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 ()
- (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 ()
- (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 ()
- (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 make-closure 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 () (std-prelude 0 0 #f) (label _)
- (const #t) (call return 1)))
-
- (assert-tree-il->glil
- ;; This gets simplified by `peval'.
- (apply (primitive null?) (begin (const #f) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const #f) (call return 1))))
-
-(with-test-prefix "values"
- (assert-tree-il->glil
- (apply (primitive values)
- (apply (primitive values) (const 1) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 1) (call return 1)))
-
- (assert-tree-il->glil
- (apply (primitive values)
- (apply (primitive values) (const 1) (const 2))
- (const 3))
- (program () (std-prelude 0 0 #f) (label _)
- (const 1) (const 3) (call return/values 2)))
-
- (assert-tree-il->glil
- (apply (primitive +)
- (apply (primitive values) (const 1) (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 1) (call return 1)))
-
- ;; Testing `(values foo)' in push context with RA.
- (assert-tree-il->glil without-partial-evaluation
- (apply (primitive cdr)
- (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
- ((lambda ((name . lp))
- (lambda-case ((() #f #f #f () ())
- (apply (toplevel values) (const (one two)))))))
- (apply (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
- (program () (std-prelude 0 0 #f) (label _)
- (branch br _) ;; entering the fix, jump to :2
- ;; :1 body of lp, jump to :3
- (label _) (bind) (const (one two)) (branch br _) (unbind)
- ;; :2 initial call of lp, jump to :1
- (label _) (bind) (branch br _) (label _) (unbind)
- ;; :3 the push continuation
- (call cdr 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 without-partial-evaluation
- (let (x) (y) ((const 1))
- (if (lexical x y)
- (lexical x y)
- (let (a) (b) ((const 2))
- (lexical a b))))
- (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)
- (label ,l2)
- (const 2) (bind (a #f 0)) (lexical #t #f set 0)
- (lexical #t #f ref 0) (call return 1)
- (unbind)
- (unbind))
- (eq? l1 l2))
-
- ;; second bound var is unreferenced
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1))
- (if (lexical x y)
- (lexical x y)
- (let (a) (b) ((const 2))
- (lexical x y))))
- (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)
- (label ,l2)
- (lexical #t #f ref 0) (call return 1)
- (unbind))
- (eq? l1 l2)))
-
-(with-test-prefix "apply"
- (assert-tree-il->glil
- (apply (primitive @apply) (toplevel foo) (toplevel bar))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
- (assert-tree-il->glil
- (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
- (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 0 #f)
- (label ,l4)
- (void) (call return 1))
- (and (eq? l1 l3) (eq? l2 l4)))
- (assert-tree-il->glil
- (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref foo)
- (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
- (call tail-call 1))))
-
-(with-test-prefix "call/cc"
- (assert-tree-il->glil
- (apply (primitive @call-with-current-continuation) (toplevel foo))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
- (assert-tree-il->glil
- (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
- (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 0 #f)
- (label ,l4)
- (void) (call return 1))
- (and (eq? l1 l3) (eq? l2 l4)))
- (assert-tree-il->glil
- (apply (toplevel foo)
- (apply (toplevel @call-with-current-continuation) (toplevel bar)))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref foo)
- (toplevel ref bar) (call call/cc 1)
- (call tail-call 1))))
-
\f
-(with-test-prefix "labels allocation"
+(with-test-prefix "contification"
(pass-if "http://debbugs.gnu.org/9769"
((compile '(lambda ()
(let ((fail (lambda () #f)))
(let ((test (lambda () (fail))))
(test))
#t))
- ;; Prevent inlining. We're testing analyze.scm's
- ;; labels allocator here, and inlining it will
- ;; reduce the entire thing to #t.
+ ;; Prevent inlining. We're testing contificatoin here,
+ ;; and inlining it will reduce the entire thing to #t.
#:opts '(#:partial-eval? #f)))))
\f
\f
(with-test-prefix "tree-il-fold"
- (pass-if "empty tree"
- (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
+ (pass-if "void"
+ (let ((up 0) (down 0) (mark (list 'mark)))
(and (eq? mark
- (tree-il-fold (lambda (x y) (set! leaf? #t) y)
- (lambda (x y) (set! down? #t) y)
- (lambda (x y) (set! up? #t) y)
+ (tree-il-fold (lambda (x y) (set! down (1+ down)) y)
+ (lambda (x y) (set! up (1+ up)) y)
mark
- '()))
- (not leaf?)
- (not up?)
- (not down?))))
+ (make-void #f)))
+ (= up 1)
+ (= down 1))))
(pass-if "lambda and application"
- (let* ((leaves '()) (ups '()) (downs '())
+ (let* ((ups '()) (downs '())
(result (tree-il-fold (lambda (x y)
- (set! leaves (cons x leaves))
- (1+ y))
- (lambda (x y)
(set! downs (cons x downs))
(1+ y))
(lambda (x y)
'(lambda ()
(lambda-case
(((x y) #f #f #f () (x1 y1))
- (apply (toplevel +)
- (lexical x x1)
- (lexical y y1)))
+ (call (toplevel +)
+ (lexical x x1)
+ (lexical y y1)))
#f))))))
- (and (equal? (map strip-source leaves)
- (list (make-lexical-ref #f 'y 'y1)
+ (define (strip-source x)
+ (post-order (lambda (x)
+ (set! (tree-il-src x) #f)
+ x)
+ x))
+ (and (= result 12)
+ (equal? (map strip-source (list-head (reverse ups) 3))
+ (list (make-toplevel-ref #f '+)
+ (make-lexical-ref #f 'x 'x1)
+ (make-lexical-ref #f 'y 'y1)))
+ (equal? (map strip-source (reverse (list-head downs 3)))
+ (list (make-toplevel-ref #f '+)
(make-lexical-ref #f 'x 'x1)
- (make-toplevel-ref #f '+)))
- (= (length downs) 3)
- (equal? (reverse (map strip-source ups))
- (map strip-source downs))))))
+ (make-lexical-ref #f 'y 'y1)))))))
\f
;;;
(let ((_ 'underscore)
(#{gensym name}# 'ignore-me))
#t))
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused))))))
(with-test-prefix "unused-toplevel"
(let ((in (open-input-string
"(define foo 2) foo")))
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "used before definition"
(let ((in (open-input-string
"(define (bar) foo) (define foo 2) (bar)")))
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused but public"
(null? (call-with-warnings
(lambda ()
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused but public (more)"
(null? (call-with-warnings
(lambda ()
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused but define-public"
(null? (call-with-warnings
(lambda ()
(compile '(define-public foo 2)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(pass-if "used by macro"
(define-syntax baz
(syntax-rules () ((_) (bar))))")))
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused"
(let ((w (call-with-warnings
(lambda ()
(compile '(define foo 2)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(and (= (length w) 1)
(number? (string-contains (car w)
(let ((w (call-with-warnings
(lambda ()
(compile '(define (foo) (foo))
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(and (= (length w) 1)
(number? (string-contains (car w)
(w (call-with-warnings
(lambda ()
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(and (= (length w) 2)
(number? (string-contains (car w)
(null? (call-with-warnings
(lambda ()
(compile '(define #{gensym name}# 'ignore-me)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(with-test-prefix "unbound variable"
(w (call-with-warnings
(lambda ()
(compile v
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unbound)))))
(and (= (length w) 1)
(number? (string-contains (car w)
(w (call-with-warnings
(lambda ()
(compile `(set! ,v 7)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unbound)))))
(and (= (length w) 1)
(number? (string-contains (car w)
(lambda ()
(compile v
#:env m
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unbound))))))
(pass-if "module-local top-level is visible after"
(lambda ()
(compile '(lambda* (x #:optional y z) (list x y z))
#:opts %opts-w-unbound
- #:to 'assembly)))))
+ #:to 'cps)))))
(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)))))
+ #:to 'cps)))))
(pass-if "GOOPS definitions are visible"
(let ((m (make-module))
(lambda ()
(compile '((lambda (x y) (or x y)) 1 2 3 4 5)
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
(compile '(let ((f (lambda (x y) (+ x y))))
(f 2))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
(lambda ()
(compile '(cons 1 2 3 4)
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
(lambda ()
(compile '(let ((f cons)) (f 1 2 3 4))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
(let ((g f))
(f 1 2 3 4)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
(let ((g f))
(g 1)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
(odd?)))))
(odd? 1))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
(f 1 2)
(f 1 2 3)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "case-lambda with wrong number of arguments"
(let ((w (call-with-warnings
((x y) 2))))
(f 1 2 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
(f #:y 2)
(f 1 2 #:z 3)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "case-lambda* with wrong arguments"
(let ((w (call-with-warnings
(list (f)
(f 1 #:z 3)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 2)
(null? (filter (lambda (w)
(not
(p (+ (p) 1))
(p))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "top-level applicable struct with wrong arguments"
(let ((w (call-with-warnings
(compile '(let ((p current-warning-port))
(p 1 2 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
(define (f) 1)")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
(define (g) (f))")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
(define (foo x) (cons))")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(pass-if "keyword not passed and quiet"
(null? (call-with-warnings
(compile '(let ((f (lambda* (x #:key y) y)))
(f 2))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "keyword passed and quiet"
(null? (call-with-warnings
(compile '(let ((f (lambda* (x #:key y) y)))
(f 2 #:y 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "keyword passed to global and quiet"
(null? (call-with-warnings
(compile '(+ 2 3) #:env (current-module))")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(pass-if "extra keyword"
(let ((w (call-with-warnings
(compile '(let ((f (lambda* (x #:key y) y)))
(f 2 #:Z 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
y)))
(f 2 #:Z 3))
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(with-test-prefix "format"
(lambda ()
(compile '(format #t "hey!")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "quiet (1 arg)"
(null? (call-with-warnings
(lambda ()
(compile '(format #t "hey ~A!" "you")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "quiet (2 args)"
(null? (call-with-warnings
(lambda ()
(compile '(format #t "~A ~A!" "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "wrong port arg"
(let ((w (call-with-warnings
(lambda ()
(compile '(format 10 "foo")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong port argument")))))
(lambda ()
(compile '(format #f fmt)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"non-literal format string")))))
(lambda ()
(compile '(format #t (gettext "~A ~A!") "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as _"
(null? (call-with-warnings
(lambda ()
(compile '(format #t (_ "~A ~A!") "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as top-level _"
(null? (call-with-warnings
(define (_ s) (gettext s "my-domain"))
(format #t (_ "~A ~A!") "hello" "world"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as module-ref _"
(null? (call-with-warnings
(lambda ()
(compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as lexical _"
(null? (call-with-warnings
(gettext s "my-domain"))))
(format #t (_ "~A ~A!") "hello" "world"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using ngettext"
(null? (call-with-warnings
(compile '(format #t
(ngettext "~a thing" "~a things" n "dom") n)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using ngettext as N_"
(null? (call-with-warnings
(lambda ()
(compile '(format #t (N_ "~a thing" "~a things" n) n)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string with (define _ gettext)"
(null? (call-with-warnings
(define (foo)
(format #t (_ "~A ~A!") "hello" "world")))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "wrong format string"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f 'not-a-string)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong format string")))))
(lambda ()
(compile '(format "shbweeb")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments")))))
(compile '((@ (ice-9 format) format) some-port
"~&~3_~~ ~\n~12they~% ~!~|~/~q")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "one missing argument"
(let ((w (call-with-warnings
(lambda ()
(compile '(format some-port "foo ~A~%")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
(lambda ()
(compile '(format some-port (gettext "foo ~A~%"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
(compile '((@ (ice-9 format) format) #f
"foo ~10,2f and bar ~S~%")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 0")))))
(lambda ()
(compile '(format #t "foo ~A and ~S~%" hey)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 1")))))
(lambda ()
(compile '(format #t "foo ~A~%" 1 2)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 2")))))
(compile '((@ (ice-9 format) format) #t
"foo ~h ~a~%" 123.4 'bar)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~:h with locale object"
(null? (call-with-warnings
(compile '((@ (ice-9 format) format) #t
"foo ~:h~%" 123.4 %global-locale)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~:h without locale object"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 1")))))
(compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
'a 1 3.14)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "literals with selector"
(let ((w (call-with-warnings
(compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
1 'dont-ignore-me)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 2")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 0")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1 to 4, got 0")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2 to 4, got 0")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~[unterminated")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unterminated conditional")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "foo~;bar")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unexpected")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "foo~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unexpected"))))))
'hello '("ladies" "and")
'gentlemen)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~{...~}, too many args"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 3")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~@{...~}, too few args"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected at least 1, got 0")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~{")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unterminated")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~v"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~v_foo")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~*"
(lambda ()
(compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 3, got 2")))))
(lambda ()
(compile '(((@ (ice-9 format) format) #f "thing~p" 2))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~p, too few arguments"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~p")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
(lambda ()
(compile '(((@ (ice-9 format) format) #f "~d thing~:p" 2))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~:@p, too many arguments"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~d pupp~:@p" 5 5)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 2")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "pupp~:@p")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~^"
(null? (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~a ~^ ~a" 0 1)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~^, too few args"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~a ~^ ~a")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected at least 1, got 0")))))
(compile '((@ (ice-9 format) format) some-port
"~#~ ~,,-2f ~,,+2f ~'A~" 1234 1234)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "complex 1"
(let ((w (call-with-warnings
"~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1 2 3 4 5 6)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 4, got 6")))))
"~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1 2 3 4)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 4")))))
(lambda ()
(compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 5, got 0")))))
(let ((w (call-with-warnings
(lambda ()
(let ((in (open-input-string
- "(use-modules ((ice-9 format)
- #:renamer (symbol-prefix-proc 'i9-)))
+ "(use-modules ((ice-9 format) #:prefix i9-))
(i9-format #t \"yo! ~A\" 1 2)")))
(read-and-compile in
#:opts %opts-w-format
- #:to 'assembly))))))
+ #:to 'cps))))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 2")))))
(compile '(let ((format chbouib))
(format #t "not ~A a format string"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(with-test-prefix "simple-format"
(lambda ()
(compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "wrong number of args"
(let ((w (call-with-warnings
(lambda ()
(compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "wrong number")))))
(lambda ()
(compile '(simple-format #t "foo ~x~%" 16)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format option")))))
(lambda ()
(compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format option")))))
(lambda ()
(compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format option")))))))
(lambda ()
(compile '(case x ((1) 'one) ((2) 'two))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "one duplicate"
(let ((w (call-with-warnings
((2) 'two)
((1) 'one-again))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "duplicate")))))
((1 2 3) 'a)
((1) 'one))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "duplicate"))))))
(lambda ()
(compile '(case x ((1) 'one) ((2) 'two))
#:opts %opts-w-bad-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "not eqv?"
(let ((w (call-with-warnings
((1) 'one)
(("bad") 'bad))
#:opts %opts-w-bad-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"cannot be meaningfully compared")))))
(compile '(case x
((1 (2) 3) 'a))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"cannot be meaningfully compared")))))))
;;;; types.test --- Type tag decoding. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
;;;;
;;;; This file is part of GNU Guile.
;;;;
42 (expt 2 28) 3.14
"narrow string" "wide στρινγ"
'symbol 'λ
- ;; NB: keywords are SMOBs.
+ #:keyword #:λ
'(2 . 3) (iota 123) '(1 (two ("three")))
#(1 2 3) #(foo bar baz)
#vu8(255 254 253)
(with-test-prefix "opaque objects"
(test-inferior-objects
((make-guardian) smob (? integer?))
- (#:keyword smob (? integer?))
((%make-void-port "w") port (? integer?))
((open-input-string "hello") port (? integer?))
((lambda () #t) program _)
- ((the-vm) vm _)
((make-weak-vector 3 #t) weak-vector _)
- ((make-hash-table) hash-table _)
- ((make-weak-key-hash-table) hash-table _)
- ((make-weak-value-hash-table) hash-table _)
- ((make-doubly-weak-hash-table) hash-table _)
+ ((make-weak-key-hash-table) weak-table _)
+ ((make-weak-value-hash-table) weak-table _)
+ ((make-doubly-weak-hash-table) weak-table _)
(#2((1 2 3) (4 5 6)) array _)
(#*00000110 bitvector _)
((expt 2 70) bignum _))
(and (fold (lambda (k v result)
(and result
(equal? (cons k v)
- (vhash-assq k vh))))
+ (vhash-assoc k vh))))
#t
keys
values)
- (not (vhash-assq 'x vh)))))
+ (not (vhash-assoc 'x vh)))))
(pass-if "vhash as vlist"
(let* ((keys '(a b c d e f g h i))
;;;; weaks.test --- tests guile's weaks -*- scheme -*-
-;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2012, 2014
+;;;; 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
exception:wrong-type-arg
(list->weak-vector 32)))
- (with-test-prefix "make-weak-key-alist-vector"
+ (with-test-prefix "make-weak-key-hash-table"
(pass-if "create"
- (make-weak-key-alist-vector 17)
+ (make-weak-key-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-weak-key-alist-vector '(bad arg))))
- (with-test-prefix "make-weak-value-alist-vector"
+ (make-weak-key-hash-table '(bad arg))))
+ (with-test-prefix "make-weak-value-hash-table"
(pass-if "create"
- (make-weak-value-alist-vector 17)
+ (make-weak-value-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-weak-value-alist-vector '(bad arg))))
+ (make-weak-value-hash-table '(bad arg))))
- (with-test-prefix "make-doubly-weak-alist-vector"
+ (with-test-prefix "make-doubly-weak-hash-table"
(pass-if "create"
- (make-doubly-weak-alist-vector 17)
+ (make-doubly-weak-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-doubly-weak-alist-vector '(bad arg)))))
+ (make-doubly-weak-hash-table '(bad arg)))))
(or (not value)
(equal? value initial-value)))
- (let ((x (make-weak-key-alist-vector 17))
- (y (make-weak-value-alist-vector 17))
- (z (make-doubly-weak-alist-vector 17))
+ (let ((x (make-weak-key-hash-table 17))
+ (y (make-weak-value-hash-table 17))
+ (z (make-doubly-weak-hash-table 17))
(test-key "foo")
(test-value "bar"))
(with-test-prefix
(hash-set! t "foo" 1)
(equal? (hash-ref t "foo") 1)))
+ (pass-if "hash-set!, weak key, returns value"
+ (let ((t (make-weak-value-hash-table))
+ (val (string #\f #\o #\o)))
+ (eq? (hashq-set! t "bar" val)
+ (hashv-set! t "bar" val)
+ (hash-set! t "bar" val)
+ val)))
+
(pass-if "assoc can do anything"
;; Until 1.9.12, as hash table's custom ASSOC procedure was
;; called with the GC lock alloc held, which imposed severe
(pass-if-parse etag "W/\"foo\"" '("foo" . #f))
(pass-if-parse location "http://other-place"
(build-uri 'http #:host "other-place"))
+ (pass-if-parse location "#foo"
+ (build-uri-reference #:fragment "foo"))
+ (pass-if-parse location "/#foo"
+ (build-uri-reference #:path "/" #:fragment "foo"))
+ (pass-if-parse location "/foo"
+ (build-uri-reference #:path "/foo"))
+ (pass-if-parse location "//server/foo"
+ (build-uri-reference #:host "server" #:path "/foo"))
(pass-if-parse proxy-authenticate "Basic realm=\"guile\""
'((basic (realm . "guile"))))
(pass-if-parse retry-after "Tue, 15 Nov 1994 08:12:31 GMT"
;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 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
(response-content-encoding r))
(pass-if-equal "response-body-port"
- `("utf-8" ,body)
+ `("UTF-8" ,body)
(with-fluids ((%default-port-encoding #f))
(let* ((r (read-response (open-input-string example-1)))
(p (response-body-port r)))
;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2014 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 "file:///etc/hosts"
(uri=? (string->uri "file:///etc/hosts")
#:scheme 'file
- #:path "/etc/hosts")))
+ #:path "/etc/hosts"))
+
+ (pass-if "http://foo#bar"
+ (uri=? (string->uri "http://foo#bar")
+ #:scheme 'http
+ #:host "foo"
+ #:path ""
+ #:fragment "bar"))
+
+ (pass-if "http://foo:/#bar"
+ (uri=? (string->uri "http://foo:/#bar")
+ #:scheme 'http
+ #:host "foo"
+ #:path "/"
+ #:fragment "bar"))
+
+ (pass-if "http://foo:100#bar"
+ (uri=? (string->uri "http://foo:100#bar")
+ #:scheme 'http
+ #:host "foo"
+ #:port 100
+ #:path ""
+ #:fragment "bar"))
+
+ (pass-if "http://foo:100/#bar"
+ (uri=? (string->uri "http://foo:100/#bar")
+ #:scheme 'http
+ #:host "foo"
+ #:port 100
+ #:path "/"
+ #:fragment "bar"))
+
+ (pass-if "http://foo?q#bar"
+ (uri=? (string->uri "http://foo?q#bar")
+ #:scheme 'http
+ #:host "foo"
+ #:path ""
+ #:query "q"
+ #:fragment "bar"))
+
+ (pass-if "http://foo:/?q#bar"
+ (uri=? (string->uri "http://foo:/?q#bar")
+ #:scheme 'http
+ #:host "foo"
+ #:path "/"
+ #:query "q"
+ #:fragment "bar"))
+
+ (pass-if "http://foo:100?q#bar"
+ (uri=? (string->uri "http://foo:100?q#bar")
+ #:scheme 'http
+ #:host "foo"
+ #:port 100
+ #:path ""
+ #:query "q"
+ #:fragment "bar"))
+
+ (pass-if "http://foo:100/?q#bar"
+ (uri=? (string->uri "http://foo:100/?q#bar")
+ #:scheme 'http
+ #:host "foo"
+ #:port 100
+ #:path "/"
+ #:query "q"
+ #:fragment "bar")))
+
+(with-test-prefix "string->uri-reference"
+ (pass-if "/foo"
+ (uri=? (string->uri-reference "/foo")
+ #:path "/foo"))
+
+ (pass-if "ftp:/foo"
+ (uri=? (string->uri-reference "ftp:/foo")
+ #:scheme 'ftp
+ #:path "/foo"))
+
+ (pass-if "ftp:foo"
+ (uri=? (string->uri-reference "ftp:foo")
+ #:scheme 'ftp
+ #:path "foo"))
+
+ (pass-if "//foo/bar"
+ (uri=? (string->uri-reference "//foo/bar")
+ #:host "foo"
+ #:path "/bar"))
+
+ (pass-if "ftp://foo@bar:22/baz"
+ (uri=? (string->uri-reference "ftp://foo@bar:22/baz")
+ #:scheme 'ftp
+ #:userinfo "foo"
+ #:host "bar"
+ #:port 22
+ #:path "/baz"))
+
+ (pass-if "//foo@bar:22/baz"
+ (uri=? (string->uri-reference "//foo@bar:22/baz")
+ #:userinfo "foo"
+ #:host "bar"
+ #:port 22
+ #:path "/baz"))
+
+ (pass-if "http://bad.host.1"
+ (not (string->uri-reference "http://bad.host.1")))
+
+ (pass-if "//bad.host.1"
+ (not (string->uri-reference "//bad.host.1")))
+
+ (pass-if "http://1.good.host"
+ (uri=? (string->uri-reference "http://1.good.host")
+ #:scheme 'http #:host "1.good.host" #:path ""))
+
+ (pass-if "//1.good.host"
+ (uri=? (string->uri-reference "//1.good.host")
+ #:host "1.good.host" #:path ""))
+
+ (when (memq 'socket *features*)
+ (pass-if "http://192.0.2.1"
+ (uri=? (string->uri-reference "http://192.0.2.1")
+ #:scheme 'http #:host "192.0.2.1" #:path ""))
+
+ (pass-if "//192.0.2.1"
+ (uri=? (string->uri-reference "//192.0.2.1")
+ #:host "192.0.2.1" #:path ""))
+
+ (pass-if "http://[2001:db8::1]"
+ (uri=? (string->uri-reference "http://[2001:db8::1]")
+ #:scheme 'http #:host "2001:db8::1" #:path ""))
+
+ (pass-if "//[2001:db8::1]"
+ (uri=? (string->uri-reference "//[2001:db8::1]")
+ #:host "2001:db8::1" #:path ""))
+
+ (pass-if "http://[2001:db8::1]:80"
+ (uri=? (string->uri-reference "http://[2001:db8::1]:80")
+ #:scheme 'http
+ #:host "2001:db8::1"
+ #:port 80
+ #:path ""))
+
+ (pass-if "//[2001:db8::1]:80"
+ (uri=? (string->uri-reference "//[2001:db8::1]:80")
+ #:host "2001:db8::1"
+ #:port 80
+ #:path ""))
+
+ (pass-if "http://[::ffff:192.0.2.1]"
+ (uri=? (string->uri-reference "http://[::ffff:192.0.2.1]")
+ #:scheme 'http #:host "::ffff:192.0.2.1" #:path ""))
+
+ (pass-if "//[::ffff:192.0.2.1]"
+ (uri=? (string->uri-reference "//[::ffff:192.0.2.1]")
+ #:host "::ffff:192.0.2.1" #:path "")))
+
+ (pass-if "http://foo:"
+ (uri=? (string->uri-reference "http://foo:")
+ #:scheme 'http #:host "foo" #:path ""))
+
+ (pass-if "//foo:"
+ (uri=? (string->uri-reference "//foo:")
+ #:host "foo" #:path ""))
+
+ (pass-if "http://foo:/"
+ (uri=? (string->uri-reference "http://foo:/")
+ #:scheme 'http #:host "foo" #:path "/"))
+
+ (pass-if "//foo:/"
+ (uri=? (string->uri-reference "//foo:/")
+ #:host "foo" #:path "/"))
+
+ (pass-if "http://2012.jsconf.us/"
+ (uri=? (string->uri-reference "http://2012.jsconf.us/")
+ #:scheme 'http #:host "2012.jsconf.us" #:path "/"))
+
+ (pass-if "//2012.jsconf.us/"
+ (uri=? (string->uri-reference "//2012.jsconf.us/")
+ #:host "2012.jsconf.us" #:path "/"))
+
+ (pass-if "http://foo:not-a-port"
+ (not (string->uri-reference "http://foo:not-a-port")))
+
+ (pass-if "//foo:not-a-port"
+ (not (string->uri-reference "//foo:not-a-port")))
+
+ (pass-if "http://:10"
+ (not (string->uri-reference "http://:10")))
+
+ (pass-if "//:10"
+ (not (string->uri-reference "//:10")))
+
+ (pass-if "http://foo@"
+ (not (string->uri-reference "http://foo@")))
+
+ (pass-if "//foo@"
+ (not (string->uri-reference "//foo@")))
+
+ (pass-if "file:/"
+ (uri=? (string->uri-reference "file:/")
+ #:scheme 'file
+ #:path "/"))
+
+ (pass-if "/"
+ (uri=? (string->uri-reference "/")
+ #:path "/"))
+
+ (pass-if "foo"
+ (uri=? (string->uri-reference "foo")
+ #:path "foo"))
+
+ (pass-if "file:/etc/hosts"
+ (uri=? (string->uri-reference "file:/etc/hosts")
+ #:scheme 'file
+ #:path "/etc/hosts"))
+
+ (pass-if "/etc/hosts"
+ (uri=? (string->uri-reference "/etc/hosts")
+ #:path "/etc/hosts"))
+
+ (pass-if "file:///etc/hosts"
+ (uri=? (string->uri-reference "file:///etc/hosts")
+ #:scheme 'file
+ #:path "/etc/hosts"))
+
+ (pass-if "///etc/hosts"
+ (uri=? (string->uri-reference "///etc/hosts")
+ #:path "/etc/hosts"))
+
+ (pass-if "/foo#bar"
+ (uri=? (string->uri-reference "/foo#bar")
+ #:path "/foo"
+ #:fragment "bar"))
+
+ (pass-if "//foo#bar"
+ (uri=? (string->uri-reference "//foo#bar")
+ #:host "foo"
+ #:path ""
+ #:fragment "bar"))
+
+ (pass-if "//foo:/#bar"
+ (uri=? (string->uri-reference "//foo:/#bar")
+ #:host "foo"
+ #:path "/"
+ #:fragment "bar"))
+
+ (pass-if "//foo:100#bar"
+ (uri=? (string->uri-reference "//foo:100#bar")
+ #:host "foo"
+ #:port 100
+ #:path ""
+ #:fragment "bar"))
+
+ (pass-if "//foo:100/#bar"
+ (uri=? (string->uri-reference "//foo:100/#bar")
+ #:host "foo"
+ #:port 100
+ #:path "/"
+ #:fragment "bar"))
+
+ (pass-if "/foo?q#bar"
+ (uri=? (string->uri-reference "/foo?q#bar")
+ #:path "/foo"
+ #:query "q"
+ #:fragment "bar"))
+
+ (pass-if "//foo?q#bar"
+ (uri=? (string->uri-reference "//foo?q#bar")
+ #:host "foo"
+ #:path ""
+ #:query "q"
+ #:fragment "bar"))
+
+ (pass-if "//foo:/?q#bar"
+ (uri=? (string->uri-reference "//foo:/?q#bar")
+ #:host "foo"
+ #:path "/"
+ #:query "q"
+ #:fragment "bar"))
+
+ (pass-if "//foo:100?q#bar"
+ (uri=? (string->uri-reference "//foo:100?q#bar")
+ #:host "foo"
+ #:port 100
+ #:path ""
+ #:query "q"
+ #:fragment "bar"))
+
+ (pass-if "//foo:100/?q#bar"
+ (uri=? (string->uri-reference "//foo:100/?q#bar")
+ #:host "foo"
+ #:port 100
+ #:path "/"
+ #:query "q"
+ #:fragment "bar")))
(with-test-prefix "uri->string"
(pass-if "ftp:"
(equal? "ftp://foo/bar"
(uri->string (string->uri "ftp://foo/bar"))))
+ (pass-if "//foo/bar"
+ (equal? "//foo/bar"
+ (uri->string (string->uri-reference "//foo/bar"))))
+
(pass-if "ftp://foo@bar:22/baz"
(equal? "ftp://foo@bar:22/baz"
(uri->string (string->uri "ftp://foo@bar:22/baz"))))
+ (pass-if "//foo@bar:22/baz"
+ (equal? "//foo@bar:22/baz"
+ (uri->string (string->uri-reference "//foo@bar:22/baz"))))
+
(when (memq 'socket *features*)
(pass-if "http://192.0.2.1"
(equal? "http://192.0.2.1"
(uri->string (string->uri "http://192.0.2.1"))))
+ (pass-if "//192.0.2.1"
+ (equal? "//192.0.2.1"
+ (uri->string (string->uri-reference "//192.0.2.1"))))
+
(pass-if "http://[2001:db8::1]"
(equal? "http://[2001:db8::1]"
(uri->string (string->uri "http://[2001:db8::1]"))))
+ (pass-if "//[2001:db8::1]"
+ (equal? "//[2001:db8::1]"
+ (uri->string (string->uri-reference "//[2001:db8::1]"))))
+
(pass-if "http://[::ffff:192.0.2.1]"
(equal? "http://[::ffff:192.0.2.1]"
- (uri->string (string->uri "http://[::ffff:192.0.2.1]")))))
+ (uri->string (string->uri "http://[::ffff:192.0.2.1]"))))
+
+ (pass-if "//[::ffff:192.0.2.1]"
+ (equal? "//[::ffff:192.0.2.1]"
+ (uri->string (string->uri-reference "//[::ffff:192.0.2.1]")))))
(pass-if "http://foo:"
(equal? "http://foo"
(uri->string (string->uri "http://foo:"))))
+ (pass-if "//foo"
+ (equal? "//foo"
+ (uri->string (string->uri-reference "//foo"))))
+
(pass-if "http://foo:/"
(equal? "http://foo/"
- (uri->string (string->uri "http://foo:/")))))
+ (uri->string (string->uri "http://foo:/"))))
+
+ (pass-if "//foo:/"
+ (equal? "//foo/"
+ (uri->string (string->uri-reference "//foo:/"))))
+
+ (pass-if "/"
+ (equal? "/"
+ (uri->string (string->uri-reference "/"))))
+
+ (pass-if "/foo"
+ (equal? "/foo"
+ (uri->string (string->uri-reference "/foo"))))
+
+ (pass-if "/foo/"
+ (equal? "/foo/"
+ (uri->string (string->uri-reference "/foo/"))))
+
+ (pass-if "/foo/?bar#baz"
+ (equal? "/foo/?bar#baz"
+ (uri->string (string->uri-reference "/foo/?bar#baz"))))
+
+ (pass-if "foo/?bar#baz"
+ (equal? "foo/?bar#baz"
+ (uri->string (string->uri-reference "foo/?bar#baz")))))
(with-test-prefix "decode"
(pass-if "foo%20bar"
## Process this file with automake to produce Makefile.in.
##
-## Copyright 2005, 2006, 2008, 2009, 2010, 2013 Software Foundation, Inc.
+## Copyright 2005, 2006, 2008, 2009, 2010 Software Foundation, Inc.
##
## This file is part of GUILE.
##
## Fifth Floor, Boston, MA 02110-1301 USA
TESTS_ENVIRONMENT = \
- GUILE_INSTALL_LOCALE=1 \
$(top_builddir)/meta/guile \
-l $(srcdir)/run-vm-tests.scm -e run-vm-tests
;;; run-vm-tests.scm -- Run Guile-VM's test suite.
;;;
-;;; Copyright 2005, 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright 2005, 2009, 2010, 2013 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
(use-modules (system vm vm)
- (system vm program)
+ (system vm loader)
+ (system vm program)
(system base compile)
(system base language)
- (language scheme spec)
- (language objcode spec)
- (srfi srfi-1)
+ (srfi srfi-1)
(ice-9 r5rs))
\f
(define (compile-to-objcode sexp)
"Compile the expression @var{sexp} into a VM program and return it."
- (compile sexp #:from scheme #:to objcode))
+ (compile sexp #:from 'scheme #:to 'bytecode))
-(define (run-vm-program objcode)
- "Run VM program contained into @var{objcode}."
- ((make-program objcode)))
+(define (run-vm-program bv)
+ "Run VM program contained into @var{bv}."
+ ((load-thunk-from-memory bv)))
(define (compile/run-test-from-file file)
"Run test from source file @var{file} and return a value indicating whether
HCoop / bpt / guile.git / commitdiff