(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 '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 '$kentry 'scheme-indent-function 2))
+ (eval . (put '$kclause 'scheme-indent-function 1))
+ (eval . (put '$fun 'scheme-indent-function 2))))
(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
# Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'.
GUILE_MAJOR_VERSION=2
-GUILE_MINOR_VERSION=0
-GUILE_MICRO_VERSION=9
+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_CURRENT=0
LIBGUILE_INTERFACE_REVISION=0
-LIBGUILE_INTERFACE_AGE=7
+LIBGUILE_INTERFACE_AGE=0
LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}"
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 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 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
(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)))))
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"
module/Makefile
])
-AC_CONFIG_FILES([meta/guile-2.0.pc])
-AC_CONFIG_FILES([meta/guile-2.0-uninstalled.pc])
+AC_CONFIG_FILES([meta/guile-2.2.pc])
+AC_CONFIG_FILES([meta/guile-2.2-uninstalled.pc])
GUILE_CONFIG_SCRIPT([check-guile])
GUILE_CONFIG_SCRIPT([benchmark-guile])
-CFLAGS = `pkg-config guile-2.0 --cflags`
-LIBS = `pkg-config guile-2.0 --libs`
+CFLAGS = `pkg-config guile-2.2 --cflags`
+LIBS = `pkg-config guile-2.2 --libs`
O_FILES = image-type.o myguile.o
.\" 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)
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
@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))
+scheme@@(guile-user)> (let lp () (call-with-vm lp))
ERROR: In procedure call-with-vm:
ERROR: Stack overflow
@end lisp
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
@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 syntax-case. The value is an opaque
object, internal to the expander.
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.
@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
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@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'' is
+given by the inventory of constructs provided by Tree-IL, the target
+language of the Scheme compiler: procedure calls, conditionals, lexical
+references, etc. 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
@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>)>
+ #<<call> 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
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})
@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} <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} <sequence> src exps
@deftpx {External Representation} (begin . @var{exps})
Like Scheme's @code{begin}.
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,
evaluating @code{exp} to the @code{lambda}-like bindings described by
@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
Returns @code{#f} if @var{obj} is object code, @code{#f} otherwise.
@end deffn
-@deffn {Scheme Procedure} bytecode->objcode bytecode
+@deffn {Scheme Procedure} bytecode->objcode bytecode [endianness]
@deffnx {C Function} scm_bytecode_to_objcode (bytecode)
Makes a bytecode object from @var{bytecode}, which should be a
-bytevector. @xref{Bytevectors}.
+bytevector. @xref{Bytevectors}. By default, the embedded length fields
+in the bytevector are interpreted in the native byte order.
@end deffn
-@deffn {Scheme Variable} load-objcode file
-@deffnx {C Function} scm_load_objcode (file)
+@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.
-On disk, object code has an sixteen-byte cookie prepended to it, to
-prevent accidental loading of arbitrary garbage.
+On disk, object code is embedded in ELF, a flexible container format
+created for use in UNIX systems. Guile has its own ELF linker and
+loader, so it uses the ELF format on all systems.
@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.
+Embed object code into an ELF container, and write it out to a file.
+
+This procedure is part of a separate module, @code{(language objcode
+elf)}.
@end deffn
-@deffn {Scheme Variable} objcode->bytecode objcode
+@deffn {Scheme Variable} objcode->bytecode objcode [endianness]
@deffnx {C Function} scm_objcode_to_bytecode (objcode)
-Copy object code out to a bytevector for analysis by Scheme.
+Copy object code out to a bytevector for analysis by Scheme. By
+default, the length fields in the @code{struct scm_objcode} are
+interpreted in the native byte order.
@end deffn
The following procedure is actually in @code{(system vm program)}, but
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) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2013
-@c Free Software Foundation, Inc.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010,
+@c 2011, 2013 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 Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@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
r5rs
srfi-0
srfi-4
+srfi-6
srfi-13
srfi-14
srfi-23
@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 Copyright (C) 2008,2009,2010,2011,2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
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!
+code. The downside is that the interpreter in Guile 2.@var{x} 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
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}.
+@deffn Instruction push-fluid
+Pop a value and a fluid from the stack, in that order. Set the fluid
+to the value 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
+@deffn Instruction pop-fluid
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.
+@code{wind-fluid} instruction was processed.
@end deffn
@deffn Instruction fluid-ref
+++ /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 Free Software Foundation, Inc.
+;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006, 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
;;; 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 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,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
#include "libguile/foreign.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.
## 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 \
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
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_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 3
#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 Free Software Foundation, 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_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);
/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
- * 2010, 2012, 2013 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
* as published by the Free Software Foundation; either version 3 of
else
return 0;
- while (SCM_NIMP (ras))
+ while (scm_is_pair (ras))
{
ra1 = SCM_CAR (ras);
}
lvra = SCM_EOL;
plvra = &lvra;
- for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+ for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
{
ra1 = SCM_CAR (z);
vra1 = scm_i_make_array (1);
}
lvra = SCM_EOL;
plvra = &lvra;
- for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+ for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
{
ra1 = SCM_CAR (z);
vra1 = scm_i_make_array (1);
{
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))
+ for (z = lvra; scm_is_pair (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;
/* 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 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
}
else 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
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))
{
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_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)
{
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
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 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
# 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,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 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 License
\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
{
*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);
-/* 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 Free Software Foundation, 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))
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);
}
#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, 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 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 = 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_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);
}
/* 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 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 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
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 Free Software Foundation, 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);
}
#undef FUNC_NAME
-SCM
-scm_i_call_with_current_continuation (SCM proc)
-{
- static SCM call_cc = SCM_BOOL_F;
-
- if (scm_is_false (call_cc))
- call_cc = scm_make_program (call_cc_objcode, SCM_BOOL_F, SCM_BOOL_F);
-
- return scm_call_1 (call_cc, proc);
-}
-
SCM
scm_i_continuation_to_frame (SCM continuation)
{
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);
+ return scm_c_make_frame (SCM_VM_FRAME_KIND_CONT, data,
+ (data->fp + data->reloc) - data->stack_base,
+ (data->sp + data->reloc) - data->stack_base,
+ data->ra);
}
else
return SCM_BOOL_F;
}
-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 Free Software Foundation, 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);
-
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 Free Software Foundation, 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
-
-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 Free Software Foundation, 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
+
+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 Free Software Foundation, 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);
-#if SCM_HAVE_SYS_SELECT_H
-SCM_DEPRECATED int scm_internal_select (int fds,
- fd_set *rfds,
- fd_set *wfds,
- fd_set *efds,
- struct timeval *timeout);
-#endif
-\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
-
-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 Free Software Foundation, 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
+typedef scm_i_t_array scm_i_t_array__GONE__REPLACE_WITH__scm_t_array;
+
+#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_API SCM scm_immutable_cell (scm_t_bits car, scm_t_bits cdr);
+SCM_API SCM scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr);
+
+\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;
}
#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 Free Software Foundation, 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_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,
-/* 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
* 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 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))
+
+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
+env_set (SCM env, int depth, int width, SCM val)
+{
+ while (depth--)
+ env = next_rib (env);
+ VECTOR_SET (env, width + 1, val);
+}
+
SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
}
#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;
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
- 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;
- }
-
- 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;
- }
+ case SCM_M_CAPTURE_MODULE:
+ return eval (mx, scm_current_module ());
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
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);
+ SCM pos, ret;
+ int depth, width;
+
+ pos = mx;
+ depth = SCM_I_INUM (CAR (pos));
+ width = SCM_I_INUM (CDR (pos));
+
+ ret = env_ref (env, depth, width);
+
if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
/* we don't know what variable, though, because we don't have its
name */
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;
}
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)));
+ env = env_tail (env);
+ return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, env));
}
case SCM_M_TOPLEVEL_SET:
}
else
{
- while (scm_is_pair (env))
- env = CDR (env);
- SCM_VARIABLE_SET
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
- val);
+ env = env_tail (env);
+ SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, env), val);
return SCM_UNSPECIFIED;
}
}
return SCM_UNSPECIFIED;
}
- 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. */
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
SCM
var = scm_private_variable (scm_the_root_module (),
scm_from_latin1_symbol ("map"));
- return scm_apply (scm_variable_ref (var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (var),
+ scm_cons (proc, scm_cons (arg1, args)));
}
SCM
var = scm_private_variable (scm_the_root_module (),
scm_from_latin1_symbol ("for-each"));
- return scm_apply (scm_variable_ref (var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (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;
+ int i, argc, nreq, nopt, nenv;
SCM body, rest, kw, inits, alt;
SCM mx = BOOT_CLOSURE_CODE (proc);
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) + scm_ilength (inits);
+ env = make_env (nenv, SCM_UNDEFINED, 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);
- }
+ i++, args = CDR (args), inits = CDR (inits))
+ env_set (env, 0, i, CAR (args));
for (; i < nreq + nopt; i++, inits = CDR (inits))
- env = scm_cons (EVAL1 (CAR (inits), env), env);
+ env_set (env, 0, i, EVAL1 (CAR (inits), env));
if (scm_is_true (rest))
- env = scm_cons (args, env);
+ env_set (env, 0, i++, 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);
+ env_set (env, 0, i, CAR (args));
for (; i < nreq + nopt; i++, inits = CDR (inits))
- env = scm_cons (EVAL1 (CAR (inits), env), env);
+ env_set (env, 0, i, EVAL1 (CAR (inits), env));
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, i++, 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;
}
/* 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)));
- }
+ for (i = kw_start_idx; scm_is_pair (inits); i++, inits = CDR (inits))
+ if (SCM_UNBNDP (env_ref (env, 0, i)))
+ env_set (env, 0, i, EVAL1 (CAR (inits), env));
}
}
+ if (!scm_is_null (inits))
+ abort ();
+ if (i != nenv)
+ abort ();
+
*out_body = body;
*out_env = env;
}
{
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 Free Software Foundation, 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_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
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
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)
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_BOOL_F, SCM_BOOL_F, 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
(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"),
#ifndef SCM_EXPAND_H
#define SCM_EXPAND_H
-/* Copyright (C) 2010, 2011
+/* Copyright (C) 2010, 2011, 2013
* 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_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
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 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 License
# include <config.h>
#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#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
+notify_finalizers_to_run (void)
+{
+ 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:
+ finalization_count += GC_invoke_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
-GC_set_finalizer_notifier (void (*notifier) (void))
+spawn_finalizer_thread (void)
{
- GC_finalizer_notifier = notifier;
+ 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
+ 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);
+}
+
+
+\f
void
scm_init_finalizers (void)
SCM_BOOL_F);
GC_set_finalizer_notifier (queue_finalizer_async);
}
+
+void
+scm_init_finalizer_thread (void)
+{
+#if SCM_USE_PTHREAD_THREADS
+ 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 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 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_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 */
/* 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_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
- 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_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
ndrained = 0;
if (SCM_OUTPUT_PORT_P (port))
- scm_flush (port);
+ scm_flush_unlocked (port);
if (pt->read_buf == pt->putback_buf)
{
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_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_c_make_port (scm_tc16_fport, mode_bits, (scm_t_bits)fp);
+
+ SCM_PTAB_ENTRY (port)->rw_random = SCM_FDES_RANDOM_P (fdes);
+
+ if (mode_bits & SCM_BUF0)
+ scm_fport_buffer_add (port, 0, 0);
+ else
+ scm_fport_buffer_add (port, -1, -1);
- port = scm_new_port_table_entry (scm_tc16_fport);
- SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
- pt = SCM_PTAB_ENTRY(port);
- {
- 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
#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 Free Software Foundation, 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
(((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 frame_kind, void *stack_holder,
+ scm_t_ptrdiff fp_offset, scm_t_ptrdiff sp_offset,
+ scm_t_uint32 *ip)
{
struct scm_frame *p = scm_gc_malloc (sizeof (struct scm_frame),
"vmframe");
p->stack_holder = stack_holder;
- p->fp = fp;
- p->sp = sp;
+ p->fp_offset = fp_offset;
+ p->sp_offset = sp_offset;
p->ip = ip;
- p->offset = offset;
- return scm_cell (scm_tc7_frame, (scm_t_bits)p);
+ return scm_cell (scm_tc7_frame | (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);
}
+SCM*
+scm_i_frame_stack_base (SCM frame)
+#define FUNC_NAME "frame-stack-base"
+{
+ void *stack_holder;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ stack_holder = SCM_VM_FRAME_STACK_HOLDER (frame);
+
+ switch (SCM_VM_FRAME_KIND (frame))
+ {
+ case SCM_VM_FRAME_KIND_CONT:
+ return ((struct scm_vm_cont *) stack_holder)->stack_base;
+
+ case SCM_VM_FRAME_KIND_VM:
+ return ((struct scm_vm *) stack_holder)->stack_base;
+
+ default:
+ abort ();
+ }
+}
+#undef FUNC_NAME
+
+scm_t_ptrdiff
+scm_i_frame_offset (SCM frame)
+#define FUNC_NAME "frame-offset"
+{
+ void *stack_holder;
+
+ SCM_VALIDATE_VM_FRAME (1, frame);
+
+ stack_holder = SCM_VM_FRAME_STACK_HOLDER (frame);
+
+ switch (SCM_VM_FRAME_KIND (frame))
+ {
+ case SCM_VM_FRAME_KIND_CONT:
+ return ((struct scm_vm_cont *) stack_holder)->reloc;
+
+ case SCM_VM_FRAME_KIND_VM:
+ return 0;
+
+ default:
+ abort ();
+ }
+}
+#undef FUNC_NAME
+
\f
/* Scheme interface */
"")
#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_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_FP (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_uintptr_t ((scm_t_uintptr) SCM_VM_FRAME_SP (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))));
-}
-#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))));
+ return scm_from_uintptr_t ((scm_t_uintptr) (SCM_FRAME_RETURN_ADDRESS
+ (SCM_VM_FRAME_FP (frame))));
}
#undef FUNC_NAME
{
SCM_VALIDATE_VM_FRAME (1, frame);
/* fixme: munge fp if holder is a continuation */
- return scm_from_ulong
- ((unsigned long)
+ return scm_from_uintptr_t
+ ((scm_t_uintptr)
RELOC (frame,
SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
}
new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
if (new_fp)
{
+ SCM *stack_base = scm_i_frame_stack_base (frame);
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));
+ new_sp = SCM_FRAME_PREVIOUS_SP (this_fp);
+ frame = scm_c_make_frame (SCM_VM_FRAME_KIND (frame),
+ SCM_VM_FRAME_STACK_HOLDER (frame),
+ new_fp - stack_base, new_sp - stack_base,
+ SCM_FRAME_RETURN_ADDRESS (this_fp));
proc = scm_frame_procedure (frame);
if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc))
-/* Copyright (C) 2001, 2009, 2010, 2011 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 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.
+
+ 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. */
- 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. */
+
+\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))
-
-#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))
+ ((struct scm_vm_frame *) SCM_FRAME_LOWER_ADDRESS (fp))
+#define SCM_FRAME_LOCALS_ADDRESS(fp) (SCM_FRAME_STRUCT (fp)->locals)
-#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))
+
+/* Currently (November 2013) we keep the procedure and arguments in
+ their slots for the duration of the procedure call, regardless of
+ whether the values are live or not. This allows for backtraces that
+ show the closure and arguments. We may allow the compiler to relax
+ this restriction in the future, if the user so desires. This would
+ conserve stack space and make GC more precise. We would need better
+ debugging information to do that, however.
+
+ Even now there is an exception to the rule that slot 0 holds the
+ procedure, which is in the case of tail calls. The compiler will
+ emit code that shuffles the new procedure and arguments into position
+ before performing the tail call, so there is a window in which
+ SCM_FRAME_PROGRAM does not correspond to the program being executed.
+
+ The moral of the story is to use the IP in a frame to determine what
+ procedure is being called. It is only appropriate to use
+ SCM_FRAME_PROGRAM in the prologue of a procedure call, when you know
+ it must be there. */
+
+#define SCM_FRAME_PROGRAM(fp) (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);
+
+SCM_INTERNAL SCM scm_c_make_frame (enum scm_vm_frame_kind vm_frame_kind,
+ void *stack_holder, scm_t_ptrdiff fp_offset,
+ scm_t_ptrdiff sp_offset, scm_t_uint32 *ip);
+
+#endif
+
SCM_API SCM scm_frame_p (SCM obj);
SCM_API SCM scm_frame_procedure (SCM frame);
SCM_API SCM scm_frame_arguments (SCM frame);
SCM_API SCM scm_frame_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);
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 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
#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 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>
#endif
+/* 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)
\f
-/* Compatibility. */
-
-#ifndef HAVE_GC_GET_HEAP_USAGE_SAFE
-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)
-{
- *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 ();
-}
-#endif
-
-#ifndef HAVE_GC_GET_FREE_SPACE_DIVISOR
-static GC_word
-GC_get_free_space_divisor (void)
-{
- return GC_free_space_divisor;
-}
-#endif
-
-\f
/* Hooks. */
scm_t_c_hook scm_before_gc_c_hook;
scm_t_c_hook scm_before_mark_c_hook;
/* {Scheme Interface to GC}
*/
+static char const * scm_i_tag_name (scm_t_bits tag);
static SCM
tag_table_to_type_alist (void *closure, SCM key, SCM val, SCM acc)
{
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_INIT ();
-#if (! ((defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7))) \
- && (defined SCM_I_GSC_USE_PTHREAD_THREADS)
- /* When using GC 6.8, this call is required to initialize thread-local
- freelists (shouldn't be necessary with GC 7.0). */
- GC_init ();
-#endif
-
- GC_expand_hp (SCM_DEFAULT_INIT_HEAP_SIZE_2);
+ 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
}
/* 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,
\f
-char const *
+static char const *
scm_i_tag_name (scm_t_bits tag)
{
switch (tag & 0x7f) /* 7 bits */
return "foreign";
case scm_tc7_hashtable:
return "hashtable";
+ case scm_tc7_weak_set:
+ return "weak-set";
+ case scm_tc7_weak_table:
+ return "weak-table";
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:
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_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 Free Software Foundation, 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_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
- * Free Software Foundation, 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>
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#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) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013
* 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_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
make_dispatch_procedure (SCM gf)
}
}
+/* 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
{
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,1996,1997,1998,1999,2000,2001, 2006, 2008, 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
- */
-
-\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_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
- 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_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,1996,1997,1998,1999,2000,2001, 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
+ */
+
+\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_block_asyncs (&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
/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008,
* 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
- *
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
#endif
+/* 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; \
+}
+
+#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); \
+}
+
+#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;
+}
+
+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_string_hash (const unsigned char *str, size_t len)
{
- /* from suggestion at: */
- /* http://srfi.schemers.org/srfi-13/mail-archive/msg00112.html */
-
- unsigned long h = 0;
- while (len-- > 0)
- h = *str++ + h*37;
- return h;
+ return narrow_string_hash (str, len);
}
unsigned long
scm_i_string_hash (SCM str)
{
size_t len = scm_i_string_length (str);
- size_t i = 0;
-
- unsigned long h = 0;
- while (len-- > 0)
- h = (unsigned long) scm_i_string_ref (str, i++) + h * 37;
- scm_remember_upto_here_1 (str);
- return h;
+ if (scm_i_is_narrow_string (str))
+ return narrow_string_hash ((const scm_t_uint8 *) scm_i_string_chars (str),
+ len);
+ else
+ 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)
+ {
+ 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)
{
- 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);
+ 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:
{
size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
- if (len > 5)
- {
- size_t i = d/2;
- unsigned long h = 1;
- while (i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
- h = ((h << 8) + (scm_hasher (elt, n, 2))) % n;
- }
- return h;
- }
- else
- {
- size_t i = len;
- unsigned long h = (n)-1;
- while (i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
- h = ((h << 8) + (scm_hasher (elt, n, d/len))) % n;
- }
- return h;
- }
+ size_t i = depth / 2;
+ unsigned long h = scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
+ if (len)
+ while (i--)
+ 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,
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", 1, 0, 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);
}
}
#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_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 struct scm_instruction *
-scm_lookup_instruction_by_name (SCM name)
-{
- static SCM instructions_by_name = SCM_BOOL_F;
- struct scm_instruction *table = fetch_instruction_table ();
- SCM op;
-
- if (SCM_UNLIKELY (scm_is_false (instructions_by_name)))
- {
- unsigned int i;
-
- instructions_by_name =
- scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS));
-
- for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
- if (scm_is_true (table[i].symname))
- scm_hashq_set_x (instructions_by_name, table[i].symname,
- SCM_I_MAKINUM (i));
- }
-
- op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
- if (SCM_I_INUMP (op))
- return &table[SCM_I_INUM (op)];
-
- 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 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006, 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_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 Free Software Foundation, 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
keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#:", port);
+ scm_puts_unlocked ("#:", port);
scm_display (KEYWORDSYM (exp), port);
return 1;
}
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 Free Software Foundation, 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 "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_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);
+
+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 *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;
+ 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;
+ }
+ }
+ }
+
+ 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);
+ 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;
+
+ 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;
+ }
+
+ 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_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)))
+ goto cleanup;
+
+ if (scm_is_true (init))
+ scm_call_0 (init);
+
+ register_elf (data, len);
+
+ /* 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;
+};
+
+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)
+{
+ 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;
+ }
+ }
+
+ {
+ size_t end;
+ size_t n = find_mapped_elf_insertion_index (data);
+
+ for (end = mapped_elf_images_count; n < end; end--)
+ {
+ mapped_elf_images[end].start = mapped_elf_images[end - 1].start;
+ mapped_elf_images[end].end = mapped_elf_images[end - 1].end;
+ }
+ mapped_elf_images_count++;
+
+ mapped_elf_images[n].start = data;
+ mapped_elf_images[n].end = data + len;
+ }
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+}
+
+static SCM
+scm_find_mapped_elf_image (SCM ip)
+{
+ char *ptr = (char *) scm_to_uintptr_t (ip);
+ SCM result;
+
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ {
+ 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)
+ {
+ 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_c_take_gc_bytevector (data, len, SCM_BOOL_F);
+ }
+ else
+ result = SCM_BOOL_F;
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
+ return result;
+}
+
+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;
+}
+
+\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 Free Software Foundation, 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
-
-#include "libguile/__scm.h"
+#ifndef _SCM_LOADER_H_
+#define _SCM_LOADER_H_
-\f
+#include <libguile.h>
-SCM_API int scm_print_carefully_p;
+SCM_API SCM scm_load_thunk_from_file (SCM filename);
+SCM_API SCM scm_load_thunk_from_memory (SCM bv);
-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 Free Software Foundation, Inc.
+ * Copyright (C) 1995,1997,1998,2000,2001, 2006, 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
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;
}
#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_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args)))
+ (scm_cons (SCM_I_MAKINUM (n), args))
-#define MAKMEMO_BEGIN(exps) \
- MAKMEMO (SCM_M_BEGIN, exps)
+#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) \
#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) \
+#define MAKMEMO_LAMBDA(body, arity, meta) \
MAKMEMO (SCM_M_LAMBDA, \
- scm_cons (body, scm_cons (docstring, arity)))
+ scm_cons (body, scm_cons (meta, 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_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_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_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_TOP_REF(var) \
MAKMEMO (SCM_M_TOPLEVEL_REF, var)
#define MAKMEMO_TOP_SET(var, val) \
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)))
+#define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
+ MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, 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",
+ "seq",
"if",
"lambda",
"let",
"quote",
"define",
- "dynwind",
- "with-fluids",
+ "capture-module",
"apply",
"call/cc",
"call-with-values",
"toplevel-set!",
"module-ref",
"module-set!",
- "prompt",
+ "call-with-prompt",
};
+
+\f
+
+
static int
-scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
+try_lookup_rib (SCM x, SCM rib)
{
- scm_puts ("#<memoized ", port);
- scm_write (scm_unmemoize_expression (memoized), port);
- scm_puts (">", port);
- return 1;
+ 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;
+}
-\f
-
+static SCM
+make_pos (int depth, int width)
+{
+ return scm_cons (SCM_I_MAKINUM (depth), SCM_I_MAKINUM (width));
+}
-static int
+static SCM
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 */
+ int d = 0;
+ for (; scm_is_pair (env); env = CDR (env), d++)
+ {
+ int w = try_lookup_rib (x, CAR (env));
+ if (w < 0)
+ continue;
+ return make_pos (d, w);
+ }
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)))
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)
{
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));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME)),
+ env);
else
return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F);
REF (exp, MODULE_SET, PUBLIC));
case SCM_EXPANDED_TOPLEVEL_REF:
- return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME)), env);
case SCM_EXPANDED_TOPLEVEL_SET:
- return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
- memoize (REF (exp, TOPLEVEL_SET, EXP), env));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
+ memoize (REF (exp, TOPLEVEL_SET, EXP),
+ capture_env (env))),
+ env);
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
- case SCM_EXPANDED_APPLICATION:
+ case SCM_EXPANDED_CALL:
{
SCM proc, args;
- proc = REF (exp, APPLICATION, PROC);
- args = memoize_exps (REF (exp, APPLICATION, ARGS), env);
+ proc = REF (exp, CALL, PROC);
+ args = memoize_exps (REF (exp, CALL, 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_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 == 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_TOP_REF (name), env),
+ nargs, args);
+ else
+ return MAKMEMO_CALL (MAKMEMO_MOD_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 or #f. */
{
- SCM meta, docstring, body, proc;
+ SCM meta, 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))
MAKMEMO_QUOTE (SCM_EOL),
MAKMEMO_QUOTE (SCM_BOOL_F))),
FIXED_ARITY (0),
- SCM_BOOL_F /* docstring */);
+ meta);
else
- proc = memoize (body, env);
-
- if (scm_is_string (docstring))
- {
- SCM args = SCM_MEMOIZED_ARGS (proc);
- SCM_SETCAR (SCM_CDR (args), docstring);
- }
+ {
+ proc = memoize (body, capture_env (env));
+ SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
+ }
- return proc;
+ return maybe_makmemo_capture_module (proc, env);
}
case SCM_EXPANDED_LAMBDA_CASE:
{
SCM req, rest, opt, kw, inits, vars, body, alt;
- SCM walk, minits, arity, new_env;
- int nreq, nopt, ntotal;
+ SCM walk, minits, arity, rib, new_env;
+ int nreq, nopt;
req = REF (exp, LAMBDA_CASE, REQ);
rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
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);
+ rib = scm_vector (vars);
+ new_env = scm_cons (rib, 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 ();
-
+ for (walk = inits; scm_is_pair (walk); walk = CDR (walk))
+ minits = scm_cons (memoize (CAR (walk), new_env), minits);
minits = scm_reverse_x (minits, SCM_UNDEFINED);
if (scm_is_true (kw))
int idx;
k = CAR (CAR (kw));
- idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env);
+ 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));
arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
- SCM_BOOL_F /* docstring */);
+ SCM_BOOL_F /* meta, filled in later */);
}
case SCM_EXPANDED_LET:
{
- SCM vars, exps, body, inits, new_env;
+ 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);
- 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));
+ varsv = scm_vector (vars);
+ inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
+ SCM_BOOL_F);
+ new_env = scm_cons (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);
}
case SCM_EXPANDED_LETREC:
{
- SCM vars, exps, body, undefs, new_env;
+ SCM vars, varsv, exps, expsv, 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);
- }
+ varsv = scm_vector (vars);
+ nvars = VECTOR_LENGTH (varsv);
+ expsv = scm_vector (exps);
+
+ undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED));
+ new_env = scm_cons (varsv, capture_env (env));
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));
+ SCM body_exps = memoize (body, new_env);
+ for (i = nvars - 1; i >= 0; i--)
+ {
+ SCM init = memoize (VECTOR_REF (expsv, i), new_env);
+ body_exps = MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i), init),
+ body_exps);
+ }
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (undefs, body_exps), env);
}
else
{
- SCM sets = SCM_EOL, inits = SCM_EOL;
- for (; scm_is_pair (exps); exps = CDR (exps), i--)
+ SCM sets = SCM_BOOL_F, inits = scm_c_make_vector (nvars, SCM_BOOL_F);
+ for (i = nvars - 1; i >= 0; 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);
+ SCM init, set;
+
+ init = memoize (VECTOR_REF (expsv, i), new_env);
+ VECTOR_SET (inits, i, init);
+
+ set = MAKMEMO_LEX_SET (make_pos (1, i),
+ MAKMEMO_LEX_REF (make_pos (0, i)));
+ if (scm_is_false (sets))
+ sets = set;
+ else
+ sets = MAKMEMO_SEQ (set, sets);
}
- 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))));
+
+ if (scm_is_false (sets))
+ return memoize (body, env);
+
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (undefs,
+ MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
+ memoize (body, new_env))),
+ 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 ();
}
#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);
+ return memoize (exp, SCM_BOOL_F);
}
#undef FUNC_NAME
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);
- }
+ 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[16];
- buf[15] = 0;
- snprintf (buf, 15, "<%u>", scm_to_uint32 (n));
- return scm_from_locale_symbol (buf);
+ 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
{
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));
+ 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_sym_atcall_cc, unmemoize (args));
+ 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_sym_at_call_with_values,
+ return scm_list_3 (scm_from_latin1_symbol ("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_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)));
scm_i_finite_list_copy (CADR (args)),
CADDR (args)),
unmemoize (CAR (args)));
- case SCM_M_PROMPT:
- return scm_list_4 (scm_sym_at_prompt,
+ 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)));
\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}.")
"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);
+ SCM mx = SCM_MEMOIZED_ARGS (m);
+
+ if (scm_is_false (mod))
+ mod = scm_the_root_module ();
+
switch (SCM_MEMOIZED_TAG (m))
{
case SCM_M_TOPLEVEL_REF:
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);
+ SCM_SETCDR (m, var);
return var;
}
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);
+ SCM_SETCDR (m, var);
return var;
}
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"
+ 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"));
}
#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
* 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_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_TOPLEVEL_SET,
SCM_M_MODULE_REF,
SCM_M_MODULE_SET,
- SCM_M_PROMPT
+ 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 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
{
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 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 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
#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), "")
-{
- CHASE_PAIRS (x, "cdr", 0x02); /* 00000010 */
-}
-SCM_DEFINE (scm_car, "car", 1, 0, 0, (SCM x), "")
-{
- CHASE_PAIRS (x, "car", 0x03); /* 00000011 */
-}
SCM_DEFINE (scm_cddr, "cddr", 1, 0, 0, (SCM x), "")
{
CHASE_PAIRS (x, "cddr", 0x0a); /* 00001010 */
scm_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);
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 */
#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 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 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 <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"
#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;
}
static void
\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;
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. */
-
-\f
-
-/* This function is not and should not be thread safe. */
-SCM
-scm_new_port_table_entry (scm_t_bits tag)
-#define FUNC_NAME "scm_new_port_table_entry"
+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
{
- /*
- 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;
+ char modes[4];
+ modes[0] = '\0';
- 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;
+ 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");
- pti->at_stream_start_for_bom_read = 1;
- pti->at_stream_start_for_bom_write = 1;
+ return scm_from_latin1_string (modes);
+}
+#undef FUNC_NAME
- /* 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 */
- pti->pending_eof = 0;
- pti->alist = SCM_EOL;
+\f
- SCM_SET_CELL_TYPE (z, tag);
- SCM_SETPTAB_ENTRY (z, entry);
+/* The port table --- a weak set of all ports.
- scm_hashq_set_x (scm_i_port_weak_hash, z, SCM_BOOL_F);
+ 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;
- /* For each new port, register a finalizer so that it port type's free
- function can be invoked eventually. */
- register_finalizer_for_port (z);
- return z;
-}
-#undef FUNC_NAME
+\f
-#if SCM_ENABLE_DEPRECATED==1
-scm_t_port *
-scm_add_to_port_table (SCM port)
+/* Port finalization. */
+
+struct do_free_data
{
- SCM z;
- scm_t_port * pt;
+ scm_t_ptob_descriptor *ptob;
+ SCM port;
+};
- scm_c_issue_deprecation_warning ("scm_add_to_port_table is deprecated.");
+static SCM
+do_free (void *body_data)
+{
+ struct do_free_data *data = body_data;
- 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);
+ /* `close' is for explicit `close-port' by user. `free' is for this
+ purpose: ports collected by the GC. */
+ data->ptob->free (data->port);
- return pt;
+ return SCM_BOOL_T;
}
-#endif
-
-
-/* Remove a port from the table and destroy it. */
-
-static void close_iconv_descriptors (scm_t_iconv_descriptors *id);
+/* Finalize the object (a port) pointed to by PTR. */
static void
-scm_i_remove_port (SCM port)
-#define FUNC_NAME "scm_remove_port"
+finalize_port (void *ptr, void *data)
{
- scm_t_port *p;
- scm_t_port_internal *pti;
+ SCM port = SCM_PACK_POINTER (ptr);
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- 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;
+ if (!SCM_PORTP (port))
+ abort ();
- if (pti->iconv_descriptors)
+ if (SCM_OPENP (port))
{
- close_iconv_descriptors (pti->iconv_descriptors);
- pti->iconv_descriptors = NULL;
- }
+ struct do_free_data data;
+
+ SCM_CLR_PORT_OPEN_FLAG (port);
- SCM_SETPTAB_ENTRY (port, 0);
+ data.ptob = SCM_PORT_DESCRIPTOR (port);
+ data.port = port;
- scm_hashq_remove_x (scm_i_port_weak_hash, port);
+ scm_internal_catch (SCM_BOOL_T, do_free, &data,
+ scm_handle_by_message_noexit, NULL);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ scm_gc_ports_collected++;
+ }
}
-#undef FUNC_NAME
-/* 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));
-}
-#undef FUNC_NAME
-#endif
+\f
-void
-scm_port_non_buffer (scm_t_port *pt)
+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)
{
- 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;
-}
+ SCM ret;
+ scm_t_port *entry;
+ scm_t_port_internal *pti;
+ scm_t_ptob_descriptor *ptob;
-\f
-/* Revealed counts --- an oddity inherited from SCSH. */
+ 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));
-/* Find a port in the table and return its revealed count.
- Also used by the garbage collector.
- */
+ 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);
-int
-scm_revealed_count (SCM port)
-{
- return SCM_REVEALED(port);
-}
+ 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"))
+ {
+ 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);
+ }
+ entry->ilseq_handler = handler;
+ pti->iconv_descriptors = NULL;
+ pti->at_stream_start_for_bom_read = 1;
+ pti->at_stream_start_for_bom_write = 1;
-/* Return the revealed count for a port. */
+ pti->pending_eof = 0;
+ pti->alist = SCM_EOL;
-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_OPENPORT (1, port);
- return scm_from_int (scm_revealed_count (port));
+ if (SCM_PORT_DESCRIPTOR (ret)->free)
+ scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL);
+
+ 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
-/* 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
+scm_c_make_port (scm_t_bits tag, unsigned long mode_bits, scm_t_bits stream)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- SCM_REVEALED (port) = scm_to_int (rcount);
- return SCM_UNSPECIFIED;
+ return scm_c_make_port_with_encoding (tag, mode_bits,
+ scm_i_default_port_encoding (),
+ scm_i_default_port_conversion_handler (),
+ stream);
}
-#undef FUNC_NAME
+SCM
+scm_new_port_table_entry (scm_t_bits tag)
+{
+ return scm_c_make_port (tag, 0, 0);
+}
\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
- */
+/* Predicates. */
-static long
-scm_i_mode_bits_n (SCM modes)
+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_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));
+ return scm_from_bool (SCM_PORTP (x));
}
+#undef FUNC_NAME
-long
-scm_mode_bits (char *modes)
+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_i_mode_bits (scm_from_locale_string (modes));
+ return scm_from_bool (SCM_INPUT_PORT_P (x));
}
+#undef FUNC_NAME
-long
-scm_i_mode_bits (SCM 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
{
- 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;
+ x = SCM_COERCE_OUTPORT (x);
+ return scm_from_bool (SCM_OUTPUT_PORT_P (x));
}
+#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_DEFINE (scm_port_closed_p, "port-closed?", 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
+ "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
+ "open.")
+#define FUNC_NAME s_scm_port_closed_p
{
- char modes[4];
- modes[0] = '\0';
+ SCM_VALIDATE_PORT (1, port);
+ return scm_from_bool (!SCM_OPPORTP (port));
+}
+#undef FUNC_NAME
- 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);
+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));
}
#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)
- {
- 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;
- }
-}
+ scm_t_iconv_descriptors *id;
+ iconv_t input_cd, output_cd;
+ size_t i;
-#define SCM_MBCHAR_BUF_SIZE (4)
+ input_cd = (iconv_t) -1;
+ output_cd = (iconv_t) -1;
-/* 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;
+ for (i = 0; encoding[i]; i++)
+ if (encoding[i] > 127)
+ goto invalid_encoding;
- if (utf8_buf[0] <= 0x7f)
- {
- assert (size == 1);
- codepoint = utf8_buf[0];
- }
- else if ((utf8_buf[0] & 0xe0) == 0xc0)
+ if (reading)
{
- 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 codepoint;
-}
-
-/* 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++
-
- int byte;
- scm_t_port *pt;
+ /* 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>). */
- *len = 0;
- pt = SCM_PTAB_ENTRY (port);
+ /* Assume opening an iconv descriptor causes about 16 KB of
+ allocation. */
+ scm_gc_register_allocation (16 * 1024);
- byte = scm_get_byte_or_eof (port);
- if (byte == EOF)
- {
- *codepoint = EOF;
- return 0;
+ input_cd = iconv_open ("UTF-8", encoding);
+ if (input_cd == (iconv_t) -1)
+ goto invalid_encoding;
}
- buf[0] = (scm_t_uint8) byte;
- *len = 1;
-
- if (buf[0] <= 0x7f)
- /* 1-byte form. */
- *codepoint = buf[0];
- else if (buf[0] >= 0xc2 && buf[0] <= 0xdf)
+ if (writing)
{
- /* 2-byte form. */
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
+ /* Assume opening an iconv descriptor causes about 16 KB of
+ allocation. */
+ scm_gc_register_allocation (16 * 1024);
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
- goto invalid_seq;
+ 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;
+ }
+ }
- CONSUME_PEEKED_BYTE ();
- buf[1] = (scm_t_uint8) byte;
- *len = 2;
+ id = scm_gc_malloc_pointerless (sizeof (*id), "iconv descriptors");
+ id->input_cd = input_cd;
+ id->output_cd = output_cd;
- *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 (port);
- ASSERT_NOT_EOF (byte);
+ /* Register a finalizer to close the descriptors. */
+ scm_i_set_finalizer (id, finalize_iconv_descriptors, NULL);
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80
- || (buf[0] == 0xe0 && byte < 0xa0)
- || (buf[0] == 0xed && byte > 0x9f)))
- goto invalid_seq;
+ return id;
- CONSUME_PEEKED_BYTE ();
- buf[1] = (scm_t_uint8) byte;
- *len = 2;
+ 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_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
+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;
+}
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
- goto invalid_seq;
+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);
- CONSUME_PEEKED_BYTE ();
- buf[2] = (scm_t_uint8) byte;
- *len = 3;
+ assert (pti->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV);
- *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)
+ if (!pti->iconv_descriptors)
{
- /* 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;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ const char *precise_encoding;
- CONSUME_PEEKED_BYTE ();
- buf[1] = (scm_t_uint8) byte;
- *len = 2;
+ if (!pt->encoding)
+ pt->encoding = "ISO-8859-1";
- byte = scm_peek_byte_or_eof (port);
- ASSERT_NOT_EOF (byte);
+ /* 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;
- if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
- goto invalid_seq;
+ pti->iconv_descriptors =
+ open_iconv_descriptors (precise_encoding,
+ SCM_INPUT_PORT_P (port),
+ SCM_OUTPUT_PORT_P (port));
+ }
- CONSUME_PEEKED_BYTE ();
- buf[2] = (scm_t_uint8) byte;
- *len = 3;
+ 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[3] = (scm_t_uint8) byte;
- *len = 4;
+ /* 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] & 0x07) << 18UL
- | ((scm_t_wchar) buf[1] & 0x3f) << 12UL
- | ((scm_t_wchar) buf[2] & 0x3f) << 6UL
- | (buf[3] & 0x3f);
+ if (encoding_matches (encoding, "UTF-8"))
+ {
+ pt->encoding = "UTF-8";
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
+ }
+ else if (encoding_matches (encoding, "ISO-8859-1"))
+ {
+ pt->encoding = "ISO-8859-1";
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
}
else
- goto invalid_seq;
-
- return 0;
+ {
+ pt->encoding = canonicalize_encoding (encoding);
+ pti->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+ }
- 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. */
+ pti->iconv_descriptors = NULL;
+ if (prev)
+ close_iconv_descriptors (prev);
+}
- return EILSEQ;
+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_VALIDATE_PORT (1, port);
-#undef CONSUME_PEEKED_BYTE
-#undef ASSERT_NOT_EOF
+ return scm_from_latin1_string (SCM_PTAB_ENTRY (port)->encoding);
}
+#undef FUNC_NAME
-/* 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_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_t_iconv_descriptors *id;
- scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE];
- size_t input_size = 0;
+ char *enc_str;
- id = scm_i_port_iconv_descriptors (port, SCM_PORT_READ);
+ SCM_VALIDATE_PORT (1, port);
+ SCM_VALIDATE_STRING (2, enc);
- for (;;)
- {
- int byte_read;
- char *input, *output;
- size_t input_left, output_left, done;
+ enc_str = scm_to_latin1_string (enc);
+ scm_i_set_port_encoding_x (port, enc_str);
+ free (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;
- }
- }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
- buf[input_size++] = byte_read;
+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;
- input = buf;
- input_left = input_size;
- output = (char *) utf8_buf;
- output_left = sizeof (utf8_buf);
+ SCM_VALIDATE_OPPORT (1, port);
- done = iconv (id->input_cd, &input, &input_left, &output, &output_left);
+ if (scm_is_false (port))
+ h = scm_i_default_port_conversion_handler ();
+ else
+ {
+ scm_t_port *pt;
- 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;
- }
- }
+ 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);
-
- if (SCM_LIKELY (err == 0))
- {
- 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_MISC_ERROR ("unknown conversion strategy ~s", scm_list_1 (sym));
- /* 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);
- }
- else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK)
+ if (scm_is_false (port))
+ scm_i_set_default_port_conversion_handler (handler);
+ else
{
- *codepoint = '?';
- err = 0;
- update_port_lf (*codepoint, port);
+ SCM_VALIDATE_OPPORT (1, port);
+ SCM_PTAB_ENTRY (port)->ilseq_handler = handler;
}
- return err;
+ return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
-/* 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);
+\f
- return codepoint;
-}
-#undef FUNC_NAME
+/* The port lock. */
-/* 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)
+static void
+lock_port (void *mutex)
{
- 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_i_pthread_mutex_lock ((scm_i_pthread_mutex_t *) mutex);
+}
- if (pti->pending_eof)
- {
- pti->pending_eof = 0;
- return EOF;
- }
+static void
+unlock_port (void *mutex)
+{
+ scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t *) mutex);
+}
- if (pt->read_buf == pt->putback_buf)
+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)
{
- /* 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);
+ scm_dynwind_unwind_handler (unlock_port, lock, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_rewind_handler (lock_port, lock, 0);
}
- return scm_ptobs[SCM_PTOBNUM (port)].fill_input (port);
}
+#undef FUNC_NAME
-int
-scm_fill_input (SCM port)
-{
- return scm_i_fill_input (port);
-}
-/* Slow-path fallback for 'scm_get_byte_or_eof' in inline.h */
-int
-scm_slow_get_byte_or_eof (SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
+\f
- if (pt->rw_active == SCM_PORT_WRITE)
- scm_flush (port);
+/* Input. */
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
+int
+scm_get_byte_or_eof (SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ int ret;
- if (pt->read_pos >= pt->read_end)
- {
- if (SCM_UNLIKELY (scm_i_fill_input (port) == EOF))
- return EOF;
- }
+ scm_c_lock_port (port, &lock);
+ ret = scm_get_byte_or_eof_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
- return *pt->read_pos++;
+ return ret;
}
-/* Slow-path fallback for 'scm_peek_byte_or_eof' in inline.h */
int
-scm_slow_peek_byte_or_eof (SCM port)
+scm_peek_byte_or_eof (SCM port)
{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (pt->rw_active == SCM_PORT_WRITE)
- scm_flush (port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
+ scm_i_pthread_mutex_t *lock;
+ int ret;
- if (pt->read_pos >= pt->read_end)
- {
- if (SCM_UNLIKELY (scm_i_fill_input (port) == EOF))
- {
- scm_i_set_pending_eof (port);
- return EOF;
- }
- }
+ scm_c_lock_port (port, &lock);
+ ret = scm_peek_byte_or_eof_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
- return *pt->read_pos;
+ return ret;
}
-
-/* scm_lfwrite
+/* scm_c_read
*
- * This function differs from scm_c_write; it updates port line and
- * column. */
-
-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)];
-
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
-
- ptob->write (port, ptr, size);
-
- for (; size; ptr++, size--)
- update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
-}
-
-/* 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 (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
-
- if (end == (size_t) -1)
- end = scm_i_string_length (str);
-
- scm_i_display_substring (str, start, end, port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
-}
-
-/* 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! */
+ * 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
psb->size = old_size;
}
+static int scm_i_fill_input_unlocked (SCM port);
+
size_t
-scm_c_read (SCM port, void *buffer, size_t size)
+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_ptobs[SCM_PTOBNUM (port)].flush (port);
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
if (pt->rw_random)
pt->rw_active = SCM_PORT_READ;
if (size == 0)
return n_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))
+ /* 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 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.
+ /* 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
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 until we have all the bytes that we need,
- or we hit EOF. */
- while (pt->read_buf_size && (scm_i_fill_input (port) != EOF))
+ /* 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;
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))
+ 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);
}
#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"
+size_t
+scm_c_read (SCM port, void *buffer, size_t size)
{
- 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);
+ scm_i_pthread_mutex_t *lock;
+ size_t ret;
- ptob->write (port, ptr, size);
+ scm_c_lock_port (port, &lock);
+ ret = scm_c_read_unlocked (port, buffer, size);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
+ return ret;
}
-#undef FUNC_NAME
-void
-scm_flush (SCM port)
+/* Update the line and column number of PORT after consumption of C. */
+static inline void
+update_port_lf (scm_t_wchar c, SCM port)
{
- long i = SCM_PTOBNUM (port);
- assert (i >= 0);
- (scm_ptobs[i].flush) (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;
+ }
}
-void
-scm_end_input (SCM port)
+#define SCM_MBCHAR_BUF_SIZE (4)
+
+/* 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)
{
- long offset;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_wchar codepoint;
- scm_i_clear_pending_eof (port);
- if (pt->read_buf == pt->putback_buf)
+ if (utf8_buf[0] <= 0x7f)
{
- 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;
+ 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);
}
else
- offset = 0;
+ {
+ 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);
+ }
- scm_ptobs[SCM_PTOBNUM (port)].end_input (port, offset);
+ return codepoint;
}
-\f
-
-
-static void
-scm_i_unget_bytes (const unsigned char *buf, size_t len, SCM port)
-#define FUNC_NAME "scm_unget_bytes"
+/* 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);
- size_t old_len, new_len;
-
- scm_i_clear_pending_eof (port);
+#define ASSERT_NOT_EOF(b) \
+ if (SCM_UNLIKELY ((b) == EOF)) \
+ goto invalid_seq
+#define CONSUME_PEEKED_BYTE() \
+ pt->read_pos++
- if (pt->read_buf != pt->putback_buf)
- /* switch to the put-back buffer. */
- {
- if (pt->putback_buf == NULL)
- {
- pt->putback_buf_size = (len > SCM_INITIAL_PUTBACK_BUF_SIZE
- ? len : SCM_INITIAL_PUTBACK_BUF_SIZE);
- pt->putback_buf
- = (unsigned char *) scm_gc_malloc_pointerless
- (pt->putback_buf_size, "putback buffer");
- }
+ int byte;
+ scm_t_port *pt;
- pt->saved_read_buf = pt->read_buf;
- pt->saved_read_pos = pt->read_pos;
- pt->saved_read_end = pt->read_end;
- pt->saved_read_buf_size = pt->read_buf_size;
+ *len = 0;
+ pt = SCM_PTAB_ENTRY (port);
- /* Put read_pos at the end of the buffer, so that ungets will not
- have to shift the buffer contents each time. */
- pt->read_buf = pt->putback_buf;
- pt->read_pos = pt->read_end = pt->putback_buf + pt->putback_buf_size;
- pt->read_buf_size = pt->putback_buf_size;
+ byte = scm_get_byte_or_eof_unlocked (port);
+ if (byte == EOF)
+ {
+ *codepoint = EOF;
+ return 0;
}
- old_len = pt->read_end - pt->read_pos;
- new_len = old_len + len;
+ buf[0] = (scm_t_uint8) byte;
+ *len = 1;
- if (new_len > pt->read_buf_size)
- /* The putback buffer needs to be enlarged. */
+ if (buf[0] <= 0x7f)
+ /* 1-byte form. */
+ *codepoint = buf[0];
+ else if (buf[0] >= 0xc2 && buf[0] <= 0xdf)
{
- size_t new_buf_size;
- unsigned char *new_buf, *new_end, *new_pos;
-
- new_buf_size = pt->read_buf_size * 2;
- if (new_buf_size < new_len)
- new_buf_size = new_len;
+ /* 2-byte form. */
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
- new_buf = (unsigned char *)
- scm_gc_malloc_pointerless (new_buf_size, "putback buffer");
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
+ goto invalid_seq;
- /* Put the bytes at the end of the buffer, so that future
- ungets won't need to shift the buffer. */
- new_end = new_buf + new_buf_size;
- new_pos = new_end - old_len;
- memcpy (new_pos, pt->read_pos, old_len);
+ CONSUME_PEEKED_BYTE ();
+ buf[1] = (scm_t_uint8) byte;
+ *len = 2;
- pt->read_buf = pt->putback_buf = new_buf;
- pt->read_pos = new_pos;
- pt->read_end = new_end;
- pt->read_buf_size = pt->putback_buf_size = new_buf_size;
+ *codepoint = ((scm_t_wchar) buf[0] & 0x1f) << 6UL
+ | (buf[1] & 0x3f);
}
- else if (pt->read_buf + len < pt->read_pos)
- /* If needed, shift the existing buffer contents up.
- This should not happen unless some external code
- manipulates the putback buffer pointers. */
+ else if ((buf[0] & 0xf0) == 0xe0)
{
- unsigned char *new_end = pt->read_buf + pt->read_buf_size;
- unsigned char *new_pos = new_end - old_len;
+ /* 3-byte form. */
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
- memmove (new_pos, pt->read_pos, old_len);
- pt->read_pos = new_pos;
- pt->read_end = new_end;
- }
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80
+ || (buf[0] == 0xe0 && byte < 0xa0)
+ || (buf[0] == 0xed && byte > 0x9f)))
+ goto invalid_seq;
- /* Move read_pos back and copy the bytes there. */
- pt->read_pos -= len;
- memcpy (pt->read_buf + (pt->read_pos - pt->read_buf), buf, len);
+ CONSUME_PEEKED_BYTE ();
+ buf[1] = (scm_t_uint8) byte;
+ *len = 2;
- if (pt->rw_active == SCM_PORT_WRITE)
- scm_flush (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
+ ASSERT_NOT_EOF (byte);
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
-}
-#undef FUNC_NAME
+ if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
+ goto invalid_seq;
-void
-scm_unget_bytes (const unsigned char *buf, size_t len, SCM port)
+ CONSUME_PEEKED_BYTE ();
+ buf[2] = (scm_t_uint8) byte;
+ *len = 3;
+
+ *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);
+
+ 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_unlocked (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_unlocked (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);
+ }
+ 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;
+
+#undef CONSUME_PEEKED_BYTE
+#undef ASSERT_NOT_EOF
+}
+
+/* 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);
+
+ if (*codepoint == EOF)
+ *len = 0;
+ else
+ {
+ *len = 1;
+ buf[0] = *codepoint;
+ }
+ return 0;
+}
+
+/* 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);
+
+ for (;;)
+ {
+ int byte_read;
+ char *input, *output;
+ size_t input_left, output_left, done;
+
+ 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);
+
+ 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;
+ }
+ }
+ }
+}
+
+/* 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))
+ {
+ 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 err;
+}
+
+/* Read a codepoint from PORT and return it. */
+scm_t_wchar
+scm_getc_unlocked (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
+
+scm_t_wchar
+scm_getc (SCM 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;
+}
+
+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
+{
+ 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
+
+
+\f
+
+/* Pushback. */
+\f
+
+
+static void
+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);
+ size_t old_len, new_len;
+
+ scm_i_clear_pending_eof (port);
+
+ if (pt->read_buf != pt->putback_buf)
+ /* switch to the put-back buffer. */
+ {
+ if (pt->putback_buf == NULL)
+ {
+ pt->putback_buf_size = (len > SCM_INITIAL_PUTBACK_BUF_SIZE
+ ? len : SCM_INITIAL_PUTBACK_BUF_SIZE);
+ pt->putback_buf
+ = (unsigned char *) scm_gc_malloc_pointerless
+ (pt->putback_buf_size, "putback buffer");
+ }
+
+ pt->saved_read_buf = pt->read_buf;
+ pt->saved_read_pos = pt->read_pos;
+ pt->saved_read_end = pt->read_end;
+ pt->saved_read_buf_size = pt->read_buf_size;
+
+ /* Put read_pos at the end of the buffer, so that ungets will not
+ have to shift the buffer contents each time. */
+ pt->read_buf = pt->putback_buf;
+ pt->read_pos = pt->read_end = pt->putback_buf + pt->putback_buf_size;
+ pt->read_buf_size = pt->putback_buf_size;
+ }
+
+ old_len = pt->read_end - pt->read_pos;
+ new_len = old_len + len;
+
+ if (new_len > pt->read_buf_size)
+ /* The putback buffer needs to be enlarged. */
+ {
+ size_t new_buf_size;
+ unsigned char *new_buf, *new_end, *new_pos;
+
+ new_buf_size = pt->read_buf_size * 2;
+ if (new_buf_size < new_len)
+ new_buf_size = new_len;
+
+ new_buf = (unsigned char *)
+ scm_gc_malloc_pointerless (new_buf_size, "putback buffer");
+
+ /* Put the bytes at the end of the buffer, so that future
+ ungets won't need to shift the buffer. */
+ new_end = new_buf + new_buf_size;
+ new_pos = new_end - old_len;
+ memcpy (new_pos, pt->read_pos, old_len);
+
+ pt->read_buf = pt->putback_buf = new_buf;
+ pt->read_pos = new_pos;
+ pt->read_end = new_end;
+ pt->read_buf_size = pt->putback_buf_size = new_buf_size;
+ }
+ else if (pt->read_buf + len < pt->read_pos)
+ /* If needed, shift the existing buffer contents up.
+ This should not happen unless some external code
+ manipulates the putback buffer pointers. */
+ {
+ unsigned char *new_end = pt->read_buf + pt->read_buf_size;
+ unsigned char *new_pos = new_end - old_len;
+
+ memmove (new_pos, pt->read_pos, old_len);
+ pt->read_pos = new_pos;
+ pt->read_end = new_end;
+ }
+
+ /* Move read_pos back and copy the bytes there. */
+ pt->read_pos -= len;
+ memcpy (pt->read_buf + (pt->read_pos - pt->read_buf), buf, len);
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_flush (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+}
+#undef FUNC_NAME
+
+void
+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 < 0xf0)
+ {
+ 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);
}
#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_errport_fluid = scm_make_fluid ();
cur_loadport_fluid = scm_make_fluid ();
- scm_i_port_weak_hash = scm_make_weak_key_hash_table (SCM_I_MAKINUM(31));
+ scm_i_port_weak_set = scm_c_make_weak_set (31);
#include "libguile/ports.x"
#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 Free Software Foundation, 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);
+ 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);
+
+/* 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 alist. */
SCM_INTERNAL SCM scm_i_port_alist (SCM port);
SCM_INTERNAL void scm_i_set_port_alist_x (SCM port, SCM alist);
-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;
+ switch (c)
+ {
+ case '\'':
+ case '`':
+ case ',':
+ case '"':
+ case ';':
+ case '#':
+ /* Some initial-character constraints. */
+ return 1;
- /* 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++)
{
}
}
- scm_lfwrite ("}#", 2, port);
+ scm_lfwrite_unlocked ("}#", 2, port);
}
/* FIXME: allow R6RS hex escapes instead of #{...}#. */
-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_extended_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); \
} \
} \
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:
if (SCM_WRITINGP (pstate))
{
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_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);
+ scm_puts_unlocked ("#w(", port);
goto common_vector_printer;
case scm_tc7_vector:
ENTER_NESTED_DATA (pstate, exp, circref);
- scm_puts ("#(", port);
+ scm_puts_unlocked ("#(", port);
common_vector_printer:
{
register long i;
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_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);
- }
- }
-
+ for (i = 0; i < last; ++i)
+ {
+ scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
+ scm_putc_unlocked (' ', port);
+ }
if (i == last)
{
/* CHECK_INTS; */
scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
}
if (cutp)
- scm_puts (" ...", port);
- scm_putc (')', port);
+ scm_puts_unlocked (" ...", port);
+ scm_putc_unlocked (')', port);
}
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 non-zero
/* 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 Free Software Foundation, 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_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 Free Software Foundation, 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_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
+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_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;
- /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
- SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
return port;
}
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;
+ port = scm_c_make_port_with_encoding (bytevector_output_port_type,
+ mode_bits,
+ NULL, /* encoding */
+ SCM_FAILED_CONVERSION_ERROR,
+ (scm_t_bits)buf);
- SCM_SET_BOP_BUFFER (port, 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);
{
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;
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);
}
static SCM
long line = SCM_LINUM (port);
int column = SCM_COL (port) - 1;
- while ('"' != (c = scm_getc (port)))
+ while ('"' != (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;
}
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')
{
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 != 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));
}
#define SCM_ENCODING_SEARCH_SIZE (500)
+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;
+}
+
/* Search the first few hundred characters of a file for an Emacs-like coding
declaration. Returns either NULL or a string whose storage has been
allocated with `scm_gc_malloc ()'. */
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;
}
-/* 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 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 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
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
-/* Copyright (C) 1994-1998, 2000-2011 Free Software Foundation, Inc.
+/* Copyright (C) 1994-1998, 2000-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
#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 Free Software Foundation, Inc.
+ * 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
}
#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 Free Software Foundation, Inc.
+ * 2004, 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
)\
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( \
- 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)
{
#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, 1996, 1997, 2000, 2001, 2002, 2003, 2005, 2006,
- * 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ * 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_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 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#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 Free Software Foundation, 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 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 Free Software Foundation, 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");
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 Free Software Foundation, 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)\
/* 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 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
* 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)
+narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut)
{
unsigned long int len;
SCM frame;
frame = SCM_STACK_FRAME (stack);
/* 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);
len--;
frame = scm_frame_previous (frame);
- if (scm_is_eq (proc, inner_key))
+ if (scm_is_eq (proc, inner_cut))
break;
}
}
- else if (scm_is_symbol (inner_key))
- {
- /* 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;
- }
- 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);
}
}
+ else
+ {
+ /* Cut until the given prompt tag is seen. */
+ scm_t_ptrdiff fp_offset = find_prompt (inner_cut);
+ for (; len; len--, frame = scm_frame_previous (frame))
+ if (fp_offset == SCM_VM_FRAME_FP_OFFSET (frame))
+ break;
+ }
SCM_SET_STACK_LENGTH (stack, len);
SCM_SET_STACK_FRAME (stack, frame);
/* Cut outer part. */
- if (scm_is_true (scm_procedure_p (outer_key)))
+ if (scm_is_true (scm_procedure_p (outer_cut)))
{
/* Cut until the given procedure is seen. */
- for (; outer && len ; --outer)
+ for (; len ;)
{
frame = scm_stack_ref (stack, scm_from_long (len - 1));
len--;
- if (scm_is_eq (scm_frame_procedure (frame), outer_key))
+ if (scm_is_eq (scm_frame_procedure (frame), outer_cut))
break;
}
}
- else if (scm_is_symbol (outer_key))
+ 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. FIXME, assumes prompt tags are
- symbols. */
- SCM prompt = find_prompt (outer_key);
+ /* Cut until the given prompt tag is seen. */
+ scm_t_ptrdiff fp_offset = find_prompt (outer_cut);
while (len)
{
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))
+ if (fp_offset == SCM_VM_FRAME_FP_OFFSET (frame))
break;
}
}
- else
- {
- /* Cut specified number of frames. */
- if (outer < len)
- len -= outer;
- else
- len = 0;
- }
SCM_SET_STACK_LENGTH (stack, len);
}
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);
+ frame = scm_c_make_frame (SCM_VM_FRAME_KIND_CONT, c,
+ (c->fp + c->reloc) - c->stack_base,
+ (c->sp + c->reloc) - c->stack_base,
+ c->ra);
}
else if (SCM_VM_FRAME_P (obj))
frame = obj;
}
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);
+ inner_cut,
+ outer_cut);
n = SCM_STACK_LENGTH (stack);
}
-/* 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 Free Software Foundation, 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;
/* Create a scheme string with space for LEN 8-bit Latin-1-encoded
\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)
{
#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 Free Software Foundation, Inc.
+ * 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
/* 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
* 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
\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))
+#define SCM_HAS_TYP7S(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7S, 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_unused_53 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/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. */
+/* The GC "kind" for threads that allow them to mark their VM
+ stacks. */
+static int thread_gc_kind;
-/* 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 ()
+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_USE_PTHREAD_THREADS
-/* No threads; we can just use GC_stackbottom. */
-static void *
-get_thread_stack_base ()
-{
- return GC_stackbottom;
-}
+ if (SCM_UNPACK (t->handle) == 0)
+ /* T must be on the free-list; ignore. (See warning in
+ gc_mark.h.) */
+ return mark_stack_ptr;
-#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;
+ /* 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);
- pthread_getattr_np (pthread_self (), &attr);
- pthread_attr_getstack (&attr, &start, &size);
- end = (char *)start + size;
+ if (t->vp)
+ mark_stack_ptr = scm_i_vm_mark_stack (t->vp, mark_stack_ptr,
+ mark_stack_limit);
-#if SCM_STACK_GROWS_UP
- return start;
-#else
- return end;
-#endif
+ return mark_stack_ptr;
}
-#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))
-
-/* We have a sufficiently new libgc (7.2 or newer). */
-
-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);
-}
-
-#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.held_mutex = NULL;
t.join_queue = SCM_EOL;
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;
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 Free Software Foundation, 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;
-
/* 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 Free Software Foundation, 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_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);
static SCM
pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
{
- SCM vm, prompt, res;
+ struct scm_vm *vp;
+ volatile SCM v_handler;
+ SCM res;
+ scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
+ scm_i_jmp_buf registers;
/* Only handle catch-alls without pre-unwind handlers */
if (!SCM_UNBNDP (pre_unwind_handler))
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))
+ /* These two are volatile, so we know we can access them after a
+ nonlocal return to the setjmp. */
+ vp = scm_the_vm ();
+ v_handler = handler;
+
+ /* Push the prompt onto the dynamic stack. */
+ scm_dynstack_push_prompt (dynstack,
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
+ | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
+ sym_pre_init_catch_tag,
+ vp->fp - vp->stack_base,
+ vp->sp - vp->stack_base,
+ vp->ip,
+ ®isters);
+
+ if (SCM_I_SETJMP (registers))
{
/* nonlocal exit */
- SCM args = scm_i_prompt_pop_abort_args_x (vm);
+ SCM args;
+ /* vp is not volatile */
+ vp = scm_the_vm ();
+ args = scm_i_prompt_pop_abort_args_x (vp);
/* cdr past the continuation */
- return scm_apply_0 (handler, scm_cdr (args));
+ return scm_apply_0 (v_handler, scm_cdr (args));
}
res = scm_call_0 (thunk);
- scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
+ scm_dynstack_pop (dynstack);
return res;
}
static int
find_pre_init_catch (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_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack,
+ sym_pre_init_catch_tag,
+ NULL, NULL, NULL, NULL, NULL))
+ return 1;
return 0;
}
pre_init_throw (SCM k, SCM args)
{
if (find_pre_init_catch ())
- return scm_at_abort (sym_pre_init_catch_tag, scm_cons (k, args));
+ return scm_abort_to_prompt_star (sym_pre_init_catch_tag, scm_cons (k, args));
else
{
static int error_printing_error = 0;
}
#undef FUNC_NAME
+SCM_DEFINE (scm_uniform_vector_element_type_code,
+ "uniform-vector-element-type-code", 1, 0, 0,
+ (SCM v),
+ "Return the type of the elements in the uniform vector, @var{v},\n"
+ "as an integer code.")
+#define FUNC_NAME s_scm_uniform_vector_element_type_code
+{
+ scm_t_array_handle h;
+ SCM ret;
+
+ 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_from_uint16 (h.element_type);
+ 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"
#ifndef SCM_UNIFORM_H
#define SCM_UNIFORM_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, 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_uniform_vector_p (SCM v);
SCM_API SCM scm_uniform_vector_length (SCM v);
SCM_API SCM scm_uniform_vector_element_type (SCM v);
+SCM_API SCM scm_uniform_vector_element_type_code (SCM v);
SCM_API SCM scm_uniform_vector_element_size (SCM v);
SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx);
SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val);
#define SCM_VALIDATE_H
/* Copyright (C) 1999, 2000, 2001, 2002, 2004, 2006, 2007, 2009,
- * 2012 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
#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)
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))
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)
return scm_from_size_t (dim->ubnd - dim->lbnd + 1);
}
else
- SCM_WTA_DISPATCH_1 (g_vector_length, v, 1, NULL);
+ return scm_wta_dispatch_1 (g_vector_length, v, 1, "vector-length");
}
size_t
SCM
scm_c_vector_ref (SCM v, size_t k)
{
- if (SCM_I_IS_VECTOR (v))
+ if (SCM_I_IS_NONWEAK_VECTOR (v))
{
- register SCM elt;
-
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 (SCM_UNPACK (elt) == 0 && SCM_I_WVECTP (v))
- /* ELT was a weak pointer and got nullified by the GC. */
- return SCM_BOOL_F;
-
- return elt;
+ return SCM_SIMPLE_VECTOR_REF (v, k);
}
+ else if (SCM_I_WVECTP (v))
+ 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;
-
- 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)))
- /* 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");
+
+ k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
+ if (k >= dim->ubnd - dim->lbnd + 1)
+ scm_out_of_range (NULL, scm_from_size_t (k));
+
+ if (SCM_I_IS_NONWEAK_VECTOR (vv))
+ return SCM_SIMPLE_VECTOR_REF (vv, k);
+ else if (SCM_I_WVECTP (vv))
+ return scm_c_weak_vector_ref (vv, k);
+ else
+ scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
}
else
- SCM_WTA_DISPATCH_2 (g_vector_ref, v, scm_from_size_t (k), 2, NULL);
+ return scm_wta_dispatch_2 (g_vector_ref, v, scm_from_size_t (k), 2,
+ "vector-ref");
}
SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x);
void
scm_c_vector_set_x (SCM v, size_t k, SCM obj)
{
- if (SCM_I_IS_VECTOR (v))
+ 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;
- if (SCM_I_WVECTP (v))
- {
- /* Make it a weak pointer. */
- SCM *link = & SCM_I_VECTOR_WELTS (v)[k];
- SCM_I_REGISTER_DISAPPEARING_LINK ((void **) link, SCM2PTR (obj));
- }
+ scm_out_of_range (NULL, scm_from_size_t (k));
+ SCM_SIMPLE_VECTOR_SET (v, k, obj);
}
+ else if (SCM_I_WVECTP (v))
+ 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))
- {
- 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));
- }
- }
+
+ k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
+ if (k >= dim->ubnd - dim->lbnd + 1)
+ scm_out_of_range (NULL, scm_from_size_t (k));
+
+ if (SCM_I_IS_NONWEAK_VECTOR (vv))
+ SCM_SIMPLE_VECTOR_SET (vv, k, obj);
+ else if (SCM_I_WVECTP (vv))
+ scm_c_weak_vector_set_x (vv, k, obj);
else
scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
}
else
{
if (SCM_UNPACK (g_vector_set_x))
- scm_apply_generic (g_vector_set_x,
- scm_list_3 (v, scm_from_size_t (k), obj));
+ scm_wta_dispatch_n (g_vector_set_x,
+ scm_list_3 (v, scm_from_size_t (k), obj),
+ 0,
+ "vector-set!");
else
scm_wrong_type_arg_msg (NULL, 0, v, "vector");
}
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");
+ SCM vector;
+ unsigned long int j;
- if (k > 0)
- {
- SCM *base;
- 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"
#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 Free Software Foundation, 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_TYP7S (x, scm_tc7_vector))
+#define SCM_I_IS_NONWEAK_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 Free Software Foundation, 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 (current_thread, SYNC_IP (), CACHE_FP ())
+
+
+/* Virtual Machine
+
+ This is Guile's new virtual machine. When I say "new", I mean
+ relative to the current virtual machine. At some point it will
+ become "the" virtual machine, and we'll delete this paragraph. As
+ such, the rest of the comments speak as if there's only one VM.
+ In difference from the old VM, local 0 is the procedure, and the
+ first argument is local 1. At some point in the future we should
+ change the fp to point to the procedure and not to local 1.
+
+ <more overview here>
+ */
+
+
+/* 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)
+
+
+
+/* After advancing vp->sp, but before writing any stack slots, check
+ that it is actually in bounds. If it is not in bounds, currently we
+ signal an error. In the future we may expand the stack instead,
+ possibly by moving it elsewhere, therefore no pointer into the stack
+ besides FP is valid across a CHECK_OVERFLOW call. Be careful! */
+#define CHECK_OVERFLOW() \
+ do { \
+ if (SCM_UNLIKELY (vp->sp >= vp->stack_limit)) \
+ { \
+ SYNC_IP (); \
+ vm_expand_stack (vp); \
+ CACHE_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. */
+#define ALLOC_FRAME(n) \
+ do { \
+ vp->sp = LOCAL_ADDRESS (n - 1); \
+ CHECK_OVERFLOW (); \
+ } 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); \
+ } 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 *current_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 (SCM_FRAME_PROGRAM (fp)))
+ {
+ SCM proc = SCM_FRAME_PROGRAM (fp);
+
+ 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 (SCM_FRAME_PROGRAM (fp));
+ 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_cons (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 three 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;
+
+ 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);
+
+ PUSH_CONTINUATION_HOOK ();
+ APPLY_HOOK ();
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ goto apply;
+
+ ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ 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 (2, tail_call, "tail-call", OP1 (U8_U24))
+ {
+ scm_t_uint32 nlocals;
+
+ UNPACK_24 (op, nlocals);
+
+ VM_HANDLE_INTERRUPTS;
+
+ RESET_FRAME (nlocals);
+
+ APPLY_HOOK ();
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ goto apply;
+
+ ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ 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 (3, 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);
+
+ APPLY_HOOK ();
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ goto apply;
+
+ ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ 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 (4, 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 (5, 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 (6, 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 (7, 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 (8, 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);
+
+ VM_HANDLE_INTERRUPTS;
+ 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 (9, 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 ();
+ VM_HANDLE_INTERRUPTS;
+
+ // FIXME: separate args
+ ret = scm_i_foreign_call (scm_cons (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 (10, 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 (11, 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),
+ ¤t_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 (12, 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));
+
+ APPLY_HOOK ();
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ goto apply;
+
+ ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ 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 (13, 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 (¤t_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);
+
+ APPLY_HOOK ();
+
+ if (SCM_UNLIKELY (!SCM_PROGRAM_P (SCM_FRAME_PROGRAM (fp))))
+ goto apply;
+
+ ip = SCM_PROGRAM_CODE (SCM_FRAME_PROGRAM (fp));
+ 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 (14, 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 (15, 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 (16, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24))
+ {
+ BR_NARGS (!=);
+ }
+ VM_DEFINE_OP (17, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24))
+ {
+ BR_NARGS (<);
+ }
+ VM_DEFINE_OP (18, 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 (19, 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 (SCM_FRAME_PROGRAM (fp)));
+ NEXT (1);
+ }
+ VM_DEFINE_OP (20, 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 (SCM_FRAME_PROGRAM (fp)));
+ NEXT (1);
+ }
+ VM_DEFINE_OP (21, 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 (SCM_FRAME_PROGRAM (fp)));
+ 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 (22, 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 (23, 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 (24, 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 (SCM_FRAME_PROGRAM (fp)));
+ 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 (25, 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 allow-other-keys:1 has-rest:1 _:6 nreq-and-opt:24
+ * _:8 ntotal:24 kw-offset:32
+ *
+ * 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 (26, 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 (SCM_FRAME_PROGRAM (fp)));
+
+ /* 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 (SCM_FRAME_PROGRAM (fp),
+ LOCAL_REF (ntotal + n)));
+ n++;
+ }
+ else
+ VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (SCM_FRAME_PROGRAM (fp),
+ LOCAL_REF (ntotal + n)));
+
+ if (has_rest)
+ {
+ SCM rest = SCM_EOL;
+ n = nkw;
+ while (n--)
+ rest = scm_cons (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 (27, 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_cons (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 (28, br, "br", OP1 (U8_L24))
+ {
+ scm_t_int32 offset = op;
+ offset >>= 8; /* Sign-extending shift. */
+ 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 (29, 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 (30, 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 (31, 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 (32, 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 (33, 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 (34, 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 (35, 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 (36, 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 (37, 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 (38, 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 (39, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24))
+ {
+ BR_ARITHMETIC (==, scm_num_eq_p);
+ }
+
+ /* br-if-< a:12 b:12 _:8 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 (40, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24))
+ {
+ BR_ARITHMETIC (<, scm_less_p);
+ }
+
+ /* br-if-<= a:12 b:12 _:8 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_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 (42, 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 (43, 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 (44, box, "box", OP1 (U8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, src;
+ UNPACK_12_12 (op, dst, src);
+ LOCAL_SET (dst, scm_cell (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 (45, 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 (SCM_FRAME_PROGRAM (fp), 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 (46, 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 (47, 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_words (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 (48, 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 (49, 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 (50, 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 (51, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32))
+ {
+ 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 (52, 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 (53, 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 (54, static_ref, "static-ref", OP2 (U8_U24, S32))
+ {
+ 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 (55, 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 (56, 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 (57, 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 (58, 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 (fp[0], 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 (59, 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 (60, 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 (fp[0], 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 (61, 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)
+ {
+#ifdef VM_ENABLE_PARANOID_ASSERTIONS
+ ASSERT
+ (scm_is_true
+ scm_equal_p (modname,
+ scm_list_2 (SCM_BOOL_T,
+ scm_from_utf8_symbol ("guile"))));
+#endif
+ 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 (fp[0], 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 (62, 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 (¤t_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 (63, wind, "wind", OP1 (U8_U12_U12))
+ {
+ scm_t_uint16 winder, unwinder;
+ UNPACK_12_12 (op, winder, unwinder);
+ scm_dynstack_push_dynwind (¤t_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 (64, unwind, "unwind", OP1 (U8_X24))
+ {
+ scm_dynstack_pop (¤t_thread->dynstack);
+ NEXT (1);
+ }
+
+ /* push-fluid fluid:12 value:12
+ *
+ * Dynamically bind N fluids to values. The fluids are expected to be
+ * allocated in a continguous range on the stack, starting from
+ * FLUID-BASE. The values do not have this restriction.
+ */
+ VM_DEFINE_OP (65, push_fluid, "push-fluid", OP1 (U8_U12_U12))
+ {
+ scm_t_uint32 fluid, value;
+
+ UNPACK_12_12 (op, fluid, value);
+
+ scm_dynstack_push_fluid (¤t_thread->dynstack,
+ LOCAL_REF (fluid), LOCAL_REF (value),
+ current_thread->dynamic_state);
+ NEXT (1);
+ }
+
+ /* pop-fluid _:24
+ *
+ * Leave the dynamic extent of a with-fluids expression, restoring the
+ * fluids to their previous values.
+ */
+ VM_DEFINE_OP (66, pop_fluid, "pop-fluid", OP1 (U8_X24))
+ {
+ /* This function must not allocate. */
+ scm_dynstack_unwind_fluid (¤t_thread->dynstack,
+ current_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 (67, 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 (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_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 (SCM_FRAME_PROGRAM (fp), 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 (68, 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 (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_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 (69, 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 (70, 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-to-number dst:12 src:12
+ *
+ * Parse a string in SRC to a number, and store in DST.
+ */
+ VM_DEFINE_OP (71, 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-to-symbol dst:12 src:12
+ *
+ * Parse a string in SRC to a symbol, and store in DST.
+ */
+ VM_DEFINE_OP (72, 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 (73, 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 (74, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ ARGS2 (x, y);
+ RETURN (scm_cons (x, y));
+ }
+
+ /* car dst:12 src:12
+ *
+ * Place the car of SRC in DST.
+ */
+ VM_DEFINE_OP (75, 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 (76, 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 (77, 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 (78, 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 (79, 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 (80, 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 (81, 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 (82, 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 (83, 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 (84, 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 (85, 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 (86, 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 (87, 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 (88, 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 << 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 (89, 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 (90, 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 (91, 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/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 (92, 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_words (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 (93, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST)
+ {
+ ARGS1 (vect);
+ if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
+ RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
+ else
+ {
+ SYNC_IP ();
+ RETURN (scm_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 (94, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ 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_IP ();
+ RETURN (scm_vector_ref (vect, idx));
+ }
+ }
+
+ /* 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 (95, 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);
+ if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (v)
+ && idx < SCM_I_VECTOR_LENGTH (v)))
+ LOCAL_SET (dst, SCM_I_VECTOR_ELTS (LOCAL_REF (src))[idx]);
+ else
+ LOCAL_SET (dst, scm_c_vector_ref (v, idx));
+ NEXT (1);
+ }
+
+ /* vector-set! dst:8 idx:8 src:8
+ *
+ * Store SRC into the vector DST at index IDX.
+ */
+ VM_DEFINE_OP (96, 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);
+
+ 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_IP ();
+ scm_vector_set_x (vect, idx, 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 (97, 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);
+
+ if (SCM_LIKELY (SCM_I_IS_NONWEAK_VECTOR (vect)
+ && idx < SCM_I_VECTOR_LENGTH (vect)))
+ SCM_I_VECTOR_WELTS (vect)[idx] = val;
+ else
+ {
+ SYNC_IP ();
+ scm_vector_set_x (vect, scm_from_uint8 (idx), val);
+ }
+ NEXT (1);
+ }
+
+
+ \f
+
+ /*
+ * Structs and GOOPS
+ */
+
+ /* struct-vtable dst:12 src:12
+ *
+ * Store the vtable of SRC into DST.
+ */
+ VM_DEFINE_OP (98, 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 (99, 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 (100, 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 (101, 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 (102, 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));
+ }
+
+ /* slot-ref dst:8 src:8 idx:8
+ *
+ * Fetch the item at slot IDX in the struct in SRC, and store it in
+ * DST. Unlike struct-ref, IDX is an 8-bit immediate value, not an
+ * index into the stack.
+ */
+ VM_DEFINE_OP (103, slot_ref, "slot-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ {
+ scm_t_uint8 dst, src, idx;
+ UNPACK_8_8_8 (op, dst, src, idx);
+ LOCAL_SET (dst,
+ SCM_PACK (SCM_STRUCT_DATA (LOCAL_REF (src))[idx]));
+ NEXT (1);
+ }
+
+ /* slot-set! dst:8 idx:8 src:8
+ *
+ * Store SRC into slot IDX of the struct in DST. Unlike struct-set!,
+ * IDX is an 8-bit immediate value, not an index into the stack.
+ */
+ VM_DEFINE_OP (104, slot_set, "slot-set!", OP1 (U8_U8_U8_U8))
+ {
+ scm_t_uint8 dst, idx, src;
+ UNPACK_8_8_8 (op, dst, idx, src);
+ SCM_STRUCT_DATA (LOCAL_REF (dst))[idx] = SCM_UNPACK (LOCAL_REF (src));
+ NEXT (1);
+ }
+
+
+ \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 (105, 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:12 type:12 _:8 fill:12 bounds:12
+ *
+ * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST.
+ */
+ VM_DEFINE_OP (106, make_array, "make-array", OP2 (U8_U12_U12, X8_U12_U12) | OP_DST)
+ {
+ scm_t_uint16 dst, type, fill, bounds;
+ UNPACK_12_12 (op, dst, type);
+ UNPACK_12_12 (ip[1], fill, 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 (107, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_FIXABLE_INT_REF (u8, u8, uint8, 1);
+
+ VM_DEFINE_OP (108, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_FIXABLE_INT_REF (s8, s8, int8, 1);
+
+ VM_DEFINE_OP (109, 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 (110, 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 (111, 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 (112, 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 (113, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_INT_REF (u64, uint64, 8);
+
+ VM_DEFINE_OP (114, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_INT_REF (s64, int64, 8);
+
+ VM_DEFINE_OP (115, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST)
+ BV_FLOAT_REF (f32, ieee_single, float, 4);
+
+ VM_DEFINE_OP (116, 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 (117, 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 (118, 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 (119, 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 (120, 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 (121, 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 (122, 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 (123, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8))
+ BV_INT_SET (u64, uint64, 8);
+
+ VM_DEFINE_OP (124, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8))
+ BV_INT_SET (s64, int64, 8);
+
+ VM_DEFINE_OP (125, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8))
+ BV_FLOAT_SET (f32, ieee_single, float, 4);
+
+ VM_DEFINE_OP (126, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
+ BV_FLOAT_SET (f64, ieee_double, double, 8);
+
+ VM_DEFINE_OP (127, unused_127, NULL, NOP)
+ VM_DEFINE_OP (128, unused_128, NULL, NOP)
+ VM_DEFINE_OP (129, unused_129, NULL, NOP)
+ VM_DEFINE_OP (130, unused_130, NULL, NOP)
+ VM_DEFINE_OP (131, unused_131, NULL, NOP)
+ 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 CHECK_OVERFLOW
+#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, 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_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("a5")
-#define SP_REG asm("a4")
-#define FP_REG
-#endif
-#ifdef __arm__
-#define IP_REG asm("r9")
-#define SP_REG asm("r8")
-#define FP_REG asm("r7")
-#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, 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
-/*
- * 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
-# ifdef __x86_64__
-# define _CX "rcx"
-# else
-# define _CX "ecx"
-# 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 << 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;
-
- nvalues = SCM_I_INUM (*sp--);
- 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:
-*/
* 02110-1301 USA
*/
+/* For mremap(2) on GNU/Linux systems. */
+#define _GNU_SOURCE
+
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
#include <stdint.h>
+#ifdef HAVE_SYS_MMAN_H
+#include <sys/mman.h>
+#endif
+
#include "libguile/bdw-gc.h"
#include <gc/gc_mark.h>
#include "control.h"
#include "frames.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;
necessary, but might be if you think you found a bug in the VM. */
#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 */
-
/* #define VM_ENABLE_PARANOID_ASSERTIONS */
-#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
-#define VM_ENABLE_ASSERTIONS
-#endif
-
-/* When defined, arrange so that the GC doesn't scan the VM stack beyond its
- current SP. This should help avoid excess data retention. See
- http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001
- for a discussion. */
-#define VM_ENABLE_PRECISE_STACK_GC_SCAN
-
-/* 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
-
\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
call to vm_run; but 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)
+vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv)
{
- struct scm_vm *vp;
struct scm_vm_cont *cp;
SCM *argv_copy;
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);
-
- if (vp->stack_size < cp->stack_size + n + 1)
+ if (vp->stack_size < cp->stack_size + n + 3)
scm_misc_error ("vm-engine", "not enough space to reinstate continuation",
- scm_list_2 (vm, cont));
+ scm_list_1 (cont));
-#ifdef VM_ENABLE_STACK_NULLING
- {
- 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 */
- }
-#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;
- }
+ {
+ size_t i;
+
+ /* Push on an empty frame, as the continuation expects. */
+ for (i = 0; i < 3; i++)
+ {
+ vp->sp++;
+ *vp->sp = SCM_BOOL_F;
+ }
+
+ /* Push the return values. */
+ for (i = 0; i < n; i++)
+ {
+ vp->sp++;
+ *vp->sp = argv_copy[i];
+ }
+ 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);
+
+ 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;
- scm_c_run_hookn (hook, args, 1);
+ 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);
+ /* FIXME: NULLSTACK (SCM_VM_DATA (vp)->sp - sp) */
+ 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)
+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 scm_vm *vp;
struct scm_vm_cont *cp;
SCM *argv_copy, *base;
+ scm_t_ptrdiff reloc;
size_t i;
argv_copy = alloca (n * sizeof(SCM));
memcpy (argv_copy, argv, n * sizeof(SCM));
- vp = SCM_VM_DATA (vm);
cp = SCM_VM_CONT_DATA (cont);
- base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
+ base = SCM_FRAME_LOCALS_ADDRESS (vp->fp);
+ reloc = cp->reloc + (base - cp->stack_base);
#define RELOC(scm_p) \
- (((SCM *) (scm_p)) + cp->reloc + (base - cp->stack_base))
+ (((SCM *) (scm_p)) + 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));
+ scm_list_1 (cont));
memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM));
vp->sp = base - 1 + cp->stack_size;
vp->fp = RELOC (cp->fp);
- vp->ip = cp->mvra;
+ vp->ip = cp->ra;
- /* now push args. ip is in a MV context. */
+ /* Push the arguments. */
for (i = 0; i < n; i++)
{
vp->sp++;
*vp->sp = argv_copy[i];
}
- vp->sp++;
- *vp->sp = scm_from_size_t (n);
- /* Finally, rewind the dynamic state.
-
- 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. */
+ /* 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. */
{
- long delta = 0;
- SCM newwinds = scm_i_dynwinds ();
- for (; scm_is_pair (intwinds); intwinds = scm_cdr (intwinds), delta--)
+ scm_t_bits *walk;
+
+ for (walk = SCM_DYNSTACK_FIRST (cp->dynstack);
+ SCM_DYNSTACK_TAG (walk);
+ walk = SCM_DYNSTACK_NEXT (walk))
{
- 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_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);
}
- scm_dowinds (newwinds, delta);
}
#undef RELOC
}
\f
-/*
- * VM Internal functions
- */
-
-void
-scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
-{
- const struct scm_vm *vm;
-
- vm = SCM_VM_DATA (x);
-
- scm_puts ("#<vm ", port);
- switch (vm->engine)
- {
- case SCM_VM_REGULAR_ENGINE:
- scm_puts ("regular-engine ", port);
- break;
-
- case SCM_VM_DEBUG_ENGINE:
- scm_puts ("debug-engine ", port);
- break;
-
- default:
- scm_puts ("unknown-engine ", port);
- }
- scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
-}
-
-\f
/*
* VM Error Handling
*/
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 proc, SCM sym) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_unbound_fluid (SCM proc, 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_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)
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));
}
-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 ();
- vm_error ("VM: Stack overflow", SCM_UNDEFINED);
-}
-
static void
vm_error_stack_underflow (void)
{
vm_error ("Too few values returned to continuation", SCM_UNDEFINED);
}
+static void
+vm_error_wrong_number_of_values (scm_t_uint32 expected)
+{
+ vm_error ("Wrong number of values returned to continuation (expected ~a)",
+ scm_from_uint32 (expected));
+}
+
static void
vm_error_continuation_not_rewindable (SCM cont)
{
vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len));
}
-#ifdef VM_CHECK_IP
-static void
-vm_error_invalid_address (void)
+
+\f
+
+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)
+};
+
+
+static SCM
+scm_vm_builtin_ref (unsigned idx)
{
- vm_error ("VM: Invalid program address", SCM_UNDEFINED);
+ switch (idx)
+ {
+#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();
+ }
}
-#endif
-#if VM_CHECK_OBJECT
-static void
-vm_error_object ()
+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"
{
- vm_error ("VM: Invalid object table access", SCM_UNDEFINED);
+ 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;
}
-#endif
+#undef FUNC_NAME
-#if VM_CHECK_FREE_VARIABLES
-static void
-vm_error_free_variable ()
+SCM
+scm_vm_builtin_index_to_name (SCM index)
+#define FUNC_NAME "builtin-index->name"
{
- vm_error ("VM: Invalid free variable access", SCM_UNDEFINED);
+ unsigned idx;
+
+ SCM_VALIDATE_UINT_COPY (1, index, idx);
+
+ switch (idx)
+ {
+#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;
+ }
}
-#endif
+#undef FUNC_NAME
-\f
+static void
+scm_init_vm_builtins (void)
+{
+ 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);
+}
-static SCM boot_continuation;
+SCM
+scm_i_call_with_current_continuation (SCM proc)
+{
+ return scm_call_1 (vm_builtin_call_with_current_continuation, proc);
+}
\f
/*
* VM
*/
-static SCM
-resolve_variable (SCM what, SCM program_module)
-{
- if (SCM_LIKELY (scm_is_symbol (what)))
- {
- if (scm_is_true (program_module))
- return scm_module_lookup (program_module, what);
- else
- return scm_module_lookup (scm_the_root_module (), what);
- }
- else
- {
- 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 VM_MIN_STACK_SIZE (1024)
-#define VM_DEFAULT_STACK_SIZE (64 * 1024)
-static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
+/* Hard stack limit is 512M words: 2 gigabytes on 32-bit machines, 4 on
+ 64-bit machines. */
+static const size_t hard_max_stack_size = 512 * 1024 * 1024;
+
+/* Initial stack size: 4 or 8 kB. */
+static const size_t initial_stack_size = 1024;
+
+/* Default soft stack limit is 1M words (4 or 8 megabytes). */
+static size_t default_max_stack_size = 1024 * 1024;
static void
initialize_default_stack_size (void)
{
- int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size);
- if (size >= VM_MIN_STACK_SIZE)
- vm_stack_size = size;
+ int size = scm_getenv_int ("GUILE_STACK_SIZE", (int) default_max_stack_size);
+ if (size >= initial_stack_size && (size_t) size < ((size_t) -1) / sizeof(SCM))
+ default_max_stack_size = size;
}
-#define VM_NAME vm_regular_engine
+static void vm_expand_stack (struct scm_vm *vp) SCM_NOINLINE;
+#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
-static const scm_t_vm_engine vm_engines[] =
+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[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)
+ SCM_SYSERROR;
+#else
+ ret = malloc (size);
+ if (!ret)
+ SCM_SYSERROR;
#endif
-static SCM
-make_vm (void)
-#define FUNC_NAME "make_vm"
+ 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;
+
+ if (new_size >= ((size_t) -1) / sizeof (SCM))
+ abort ();
- vp->stack_size= vm_stack_size;
+ 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)
+ SCM_SYSERROR;
- /* 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;
+
+ new_stack = allocate_stack (new_size);
+ memcpy (new_stack, old_stack, old_size * sizeof (SCM));
+ free_stack (old_stack, old_size);
-#ifdef VM_ENABLE_STACK_NULLING
- memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
+ 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 = initial_stack_size;
+ vp->stack_base = allocate_stack (vp->stack_size);
+ vp->stack_limit = vp->stack_base + vp->stack_size;
+ vp->max_stack_size = default_max_stack_size;
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
-
/* 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)
+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)
{
- GC_word *word;
- const struct scm_vm *vm;
+ SCM *sp, *fp;
- /* The first word of the VM stack should contain a pointer to the
- corresponding VM. */
- vm = * ((struct scm_vm **) addr);
-
- 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;
-
- 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);
+ 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))
+ mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word *) elt,
+ mark_stack_ptr, mark_stack_limit,
+ NULL);
+ }
+ sp = SCM_FRAME_PREVIOUS_SP (fp);
+ }
return mark_stack_ptr;
}
-#endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */
-
-
-SCM
-scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
+/* 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 */
-
-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 (struct scm_vm *vp)
{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ scm_t_ptrdiff stack_size = vp->sp + 1 - vp->stack_base;
- if (SCM_UNLIKELY (scm_is_false (t->vm)))
- t->vm = make_vm ();
+ if (stack_size > hard_max_stack_size)
+ {
+ /* We have expanded the soft limit to the point that we reached a
+ hard limit. There is nothing sensible to do. */
+ fprintf (stderr, "Hard stack size limit (%zu words) reached; aborting.\n",
+ hard_max_stack_size);
+ abort ();
+ }
- return t->vm;
-}
-#undef FUNC_NAME
+ if (stack_size > vp->stack_size)
+ {
+ SCM *old_stack;
+ size_t new_size;
+ scm_t_ptrdiff reloc;
+
+ new_size = vp->stack_size;
+ while (new_size < stack_size)
+ new_size *= 2;
+ old_stack = vp->stack_base;
+ vp->stack_base = expand_stack (old_stack, vp->stack_size, new_size);
+ vp->stack_size = new_size;
+ vp->stack_limit = vp->stack_base + new_size;
+ reloc = vp->stack_base - old_stack;
+
+ if (reloc)
+ {
+ SCM *fp;
+ vp->fp += reloc;
+ vp->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;
+ }
+ }
+ }
+ if (stack_size >= vp->max_stack_size)
+ {
+ /* Expand the soft limit by 256K entries to give us space to
+ handle the error. */
+ vp->max_stack_size += 256 * 1024;
-SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
- (SCM obj),
- "")
-#define FUNC_NAME s_scm_vm_p
-{
- return scm_from_bool (SCM_VM_P (obj));
-}
-#undef FUNC_NAME
+ /* If it's still not big enough... it's quite improbable, but go
+ ahead and set to the full available stack size. */
+ if (vp->max_stack_size < stack_size)
+ vp->max_stack_size = vp->stack_size;
-SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
- (void),
- "")
-#define FUNC_NAME s_scm_make_vm,
-{
- return make_vm ();
+ /* But don't exceed the hard maximum. */
+ if (vp->max_stack_size > hard_max_stack_size)
+ vp->max_stack_size = hard_max_stack_size;
+
+ /* Finally, reset the limit, to catch further overflows. */
+ vp->stack_limit = vp->stack_base + vp->max_stack_size;
+
+ vm_error ("VM: Stack overflow", SCM_UNDEFINED);
+ }
+
+ /* Otherwise continue, with the new enlarged stack. */
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_ip
+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)->ip);
+ if (SCM_UNLIKELY (!t->vp))
+ t->vp = make_vm ();
+
+ return t->vp;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_sp
+struct scm_vm *
+scm_the_vm (void)
{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->sp);
+ return thread_vm (SCM_I_CURRENT_THREAD);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
- (SCM vm),
- "")
-#define FUNC_NAME s_scm_vm_fp
+SCM
+scm_call_n (SCM proc, SCM *argv, size_t nargs)
{
- SCM_VALIDATE_VM (1, vm);
- return scm_from_unsigned_integer ((scm_t_bits) SCM_VM_DATA (vm)->fp);
+ 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, 3 + nargs for the procedure application, and 3 for
+ setting up a new frame. */
+ base_frame_size = 3 + 3 + nargs + 3;
+ vp->sp += base_frame_size;
+ if (vp->sp >= vp->stack_limit)
+ vm_expand_stack (vp);
+ 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];
+ vp->sp = &SCM_FRAME_LOCAL (vp->fp, nargs);
+
+ {
+ int resume = SCM_I_SETJMP (registers);
+
+ if (SCM_UNLIKELY (resume))
+ /* 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)
-{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
- t->vm = vm;
-}
-
-SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
- (SCM vm, SCM proc, SCM args),
+/* 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.\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}.")
+ "@var{vm} is the current VM.")
#define FUNC_NAME s_scm_call_with_vm
{
- SCM prev_vm, ret;
- SCM *argv;
- int i, nargs;
- scm_t_wind_flags flags;
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
-
- SCM_VALIDATE_VM (1, vm);
- SCM_VALIDATE_PROC (2, proc);
-
- 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);
- }
-
- prev_vm = t->vm;
-
- /* 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;
- }
-
- ret = scm_c_vm_run (vm, proc, argv, nargs);
-
- if (flags)
- scm_dynwind_end ();
-
- return ret;
+ return scm_apply_0 (proc, args);
}
#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 ();
sym_regular = scm_from_latin1_symbol ("regular");
sym_debug = scm_from_latin1_symbol ("debug");
- boot_continuation = make_boot_program ();
+ 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));
-#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
- vm_stack_gc_kind =
- GC_new_kind (GC_new_free_list (),
- GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0),
- 0, 1);
-
-#endif
+#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 Free Software Foundation, 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 */
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 hooks[SCM_VM_NUM_HOOKS]; /* hooks */
int trace_level; /* traces enabled if trace_level > 0 */
- scm_t_int64 cookie; /* used to detect unrewindable continuations */
+ size_t max_stack_size;
+ SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
+ 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_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 void scm_i_vm_cont_print (SCM x, SCM port,
scm_print_state *pstate);
-/* 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_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)
+ if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
return *pt->read_buf;
}
else
- scm_ungetc (SCM_CHAR (ans), port);
+ scm_ungetc_unlocked (SCM_CHAR (ans), port);
return SCM_CHAR (ans);
}
#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 Free Software Foundation, 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", 1, 0, 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 Free Software Foundation, 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)
+
+static SCM
+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 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 = 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_I_WVECTP (obj));
+}
+#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)
+{
+ struct weak_vector_ref_data d;
+ void *ret;
+
+ d.wv = wv;
+ d.k = k;
+
+ if (k >= SCM_I_VECTOR_LENGTH (wv))
+ scm_out_of_range (NULL, 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;
+}
+
+
+void
+scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x)
+{
+ SCM *elts;
+ struct weak_vector_ref_data d;
+ void *prev;
+
+ d.wv = wv;
+ d.k = k;
+
+ if (k >= SCM_I_VECTOR_LENGTH (wv))
+ scm_out_of_range (NULL, 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));
+}
+
+
+\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 Free Software Foundation, 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 k, SCM fill);
+SCM_API SCM scm_weak_vector (SCM l);
+SCM_API SCM scm_weak_vector_p (SCM x);
+SCM_INTERNAL SCM scm_c_weak_vector_ref (SCM v, size_t k);
+SCM_INTERNAL 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 Free Software Foundation, 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}
- */
-
-
-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_I_WVECTP (obj) && !SCM_IS_WHVEC (obj));
-}
-#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 Free Software Foundation, 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_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
bin_SCRIPTS = guile-config guild
EXTRA_DIST= \
guile.m4 ChangeLog-2008 \
- guile-2.0.pc.in guile-2.0-uninstalled.pc.in \
+ guile-2.2.pc.in guile-2.2-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-2.2.pc
## FIXME: in the future there will be direct automake support for
## doing this. When that happens, switch over.
;;;; 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!
+$(GOBJECTS): ice-9/psyntax-pp.go
+ice-9/psyntax-pp.go: ice-9/eval.go
+CLEANFILES += ice-9/eval.go ice-9/psyntax-pp.go
+nobase_mod_DATA += ice-9/eval.scm ice-9/psyntax-pp.scm
+nobase_ccache_DATA += ice-9/eval.go ice-9/psyntax-pp.go
+EXTRA_DIST += ice-9/eval.scm ice-9/psyntax-pp.scm
+ETAGS_ARGS += ice-9/eval.scm ice-9/psyntax-pp.scm
+
+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 \
- ice-9/vlist.scm \
- srfi/srfi-1.scm \
language/tree-il/peval.scm \
language/tree-il/cse.scm \
+ system/vm/elf.scm \
+ ice-9/vlist.scm \
+ srfi/srfi-1.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) \
- $(BYTECODE_LANG_SOURCES) \
- $(OBJCODE_LANG_SOURCES) \
+ $(CPS_LANG_SOURCES) \
+ $(RTL_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 = \
- language/bytecode/spec.scm
-
-OBJCODE_LANG_SOURCES = \
- language/objcode/spec.scm
+CPS_LANG_SOURCES = \
+ language/cps.scm \
+ language/cps/arities.scm \
+ language/cps/closure-conversion.scm \
+ language/cps/compile-rtl.scm \
+ language/cps/constructors.scm \
+ language/cps/contification.scm \
+ language/cps/dfg.scm \
+ language/cps/elide-values.scm \
+ language/cps/primitives.scm \
+ language/cps/reify-primitives.scm \
+ language/cps/slot-allocation.scm \
+ language/cps/spec.scm \
+ language/cps/specialize-primcalls.scm \
+ language/cps/verify.scm
+
+RTL_LANG_SOURCES = \
+ language/rtl.scm \
+ language/rtl/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/posix.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/xref.scm \
EXTRA_DIST += oop/ChangeLog-2008
+ELISP_SOURCES = \
+ language/elisp/boot.el
+
NOCOMP_SOURCES = \
ice-9/match.upstream.scm \
ice-9/psyntax.scm \
(define make-prompt-tag
(lambda* (#:optional (stem "prompt"))
- (gensym stem)))
+ ;; 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 default-prompt-tag
- ;; not sure if we should expose this to the user as a fluid
+ ;; Redefined later to be a parameter.
(let ((%default-prompt-tag (make-prompt-tag)))
(lambda ()
%default-prompt-tag)))
(define (call-with-prompt tag thunk handler)
- (@prompt tag (thunk) handler))
+ ((@@ primitive call-with-prompt) tag thunk handler))
(define (abort-to-prompt tag . args)
- (@abort tag args))
+ (abort-to-prompt* tag args))
+(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))))
;; Define catch and with-throw-handler, using some common helper routines and a
;; shared fluid. Hide the helpers in a lexical contour.
(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))))
+ (with-fluid* %running-exception-handlers (cons pre running)
+ (lambda ()
+ (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
(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)))
+ (with-fluid* %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))))))
(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))))
+ (with-fluid* %exception-handler
+ (custom-throw-handler #f k pre-unwind-handler)
+ thunk)))
(set! throw
(lambda (key . args)
\f
-;;; {R4RS compliance}
+;;; {Language primitives}
;;;
-(primitive-load-path "ice-9/r4rs")
+;; 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
+ (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))))
+
+\f
+
+;;; {Low-Level Port Code}
+;;;
+
+;; 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")
+
+;; 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))
+
+;; 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))
+
+(define (open-io-file str)
+ "Open file with name STR for both input and output."
+ (open-file str OPEN_BOTH))
\f
(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
(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 ()
\f
-;;;
-;;; Enhanced file opening procedures
-;;;
-
-(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-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.
;;;
;; 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"))
+
+\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
+
+;;; {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 (eval load compile expand)
- (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-23 ;; `error` procedure
;;;
(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 'rtl)))
(read-and-eval port #:lang lang))))))))
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 2009, 2010, 2012, 2013 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
\f
(eval-when (compile)
- (define-syntax capture-env
+ (define-syntax env-toplevel
(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)))))
+ (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)))))))
+
+ ;; For evaluating the initializers in a "let" expression. We have to
+ ;; evaluate the initializers before creating the environment rib, to
+ ;; prevent continuation-related shenanigans; see
+ ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time for a
+ ;; deeper discussion.
+ ;;
+ ;; This macro will inline evaluation of the first N initializers.
+ ;; That number N is indicated by the number of template arguments
+ ;; passed to the macro. It's a bit nasty but it's flexible and
+ ;; optimizes well.
+ (define-syntax let-env-evaluator
+ (syntax-rules ()
+ ((eval-and-make-env eval env (template ...))
+ (let ()
+ (define-syntax eval-and-make-env
+ (syntax-rules ()
+ ((eval-and-make-env inits width (template ...) k)
+ (let lp ((n (length '(template ...))) (vals '()))
+ (if (eqv? n width)
+ (let ((env (make-env n #f env)))
+ (let lp ((n (1- n)) (vals vals))
+ (if (null? vals)
+ (k env)
+ (begin
+ (env-set! env 0 n (car vals))
+ (lp (1- n) (cdr vals))))))
+ (lp (1+ n)
+ (cons (eval (vector-ref inits n) env) vals)))))
+ ((eval-and-make-env inits width (var (... ...)) k)
+ (let ((n (length '(var (... ...)))))
+ (if (eqv? n width)
+ (k (make-env n #f env))
+ (let* ((x (eval (vector-ref inits n) env))
+ (k (lambda (env)
+ (env-set! env 0 n x)
+ (k env))))
+ (eval-and-make-env inits width (x var (... ...)) k)))))))
+ (lambda (inits)
+ (let ((width (vector-length inits))
+ (k (lambda (env) env)))
+ (eval-and-make-env inits width () k)))))))
;; Fast case for procedures with fixed arities.
(define-syntax make-fixed-closure
#`((#,nreq)
(lambda (#,@formals)
(eval body
- (cons* #,@(reverse formals) env))))))
+ (make-env* env #,@formals))))))
(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)
+ (let ((env (make-env nreq #f env)))
+ #,@(map (lambda (formal n)
+ #`(env-set! env 0 #,n #,formal))
+ formals (iota (length formals)))
+ (let lp ((i #,*max-static-argument-count*)
+ (args more))
+ (cond
+ ((= i nreq)
(eval body
(if (null? args)
- new-env
+ 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)))))))))))))
+ '() #f))))
+ ((null? args)
+ (scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f))
+ (else
+ (env-set! env 0 i (car args))
+ (lp (1+ i) (cdr args))))))))))))))
+
+ ;; Fast case for procedures with fixed arities and a rest argument.
+ (define-syntax make-rest-closure
+ (lambda (x)
+ (define *max-static-argument-count* 3)
+ (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-rest-closure eval nreq body e)))
+ ((_ eval nreq body env)
+ #`(case nreq
+ #,@(map (lambda (nreq)
+ (let ((formals (make-formals nreq)))
+ #`((#,nreq)
+ (lambda (#,@formals . rest)
+ (eval body
+ (make-env* env #,@formals rest))))))
+ (iota *max-static-argument-count*))
+ (else
+ #,(let ((formals (make-formals *max-static-argument-count*)))
+ #`(lambda (#,@formals . more)
+ (let ((env (make-env (1+ nreq) #f env)))
+ #,@(map (lambda (formal n)
+ #`(env-set! env 0 #,n #,formal))
+ formals (iota (length formals)))
+ (let lp ((i #,*max-static-argument-count*)
+ (args more))
+ (cond
+ ((= i nreq)
+ (env-set! env 0 nreq args)
+ (eval body env))
+ ((null? args)
+ (scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f))
+ (else
+ (env-set! env 0 i (car args))
+ (lp (1+ i) (cdr args))))))))))))))
(define-syntax call
(lambda (x)
(lambda (x)
(syntax-case x ()
((_ mx c ...)
- #'(let ((tag (memoized-expression-typecode mx))
- (data (memoized-expression-data mx)))
+ #'(let ((tag (car mx))
+ (data (cdr mx)))
(mx-match mx data tag c ...)))))))
;;; module-ref: 14468
;;; define: 1259
;;; toplevel-set: 328
-;;; dynwind: 162
-;;; with-fluids: 0
;;; call/cc: 0
;;; module-set: 0
;;;
(define primitive-eval
(let ()
- ;; We pre-generate procedures with fixed arities, up to some number of
- ;; arguments; see make-fixed-closure above.
+ ;; We pre-generate procedures with fixed arities, up to some number
+ ;; of arguments, and some rest arities; see make-fixed-closure and
+ ;; make-rest-closure above.
;; A unique marker for unbound keywords.
(define unbound-arg (list 'unbound-arg))
;; 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 ...)
+ (and alt ; (body meta nreq ...)
(let* ((body (car alt))
(spec (cddr alt))
(nreq (car spec))
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))
+ (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 (not kw) (not rest?) (> nargs (+ nreq nopt)))
+ (and alt kw (not rest?) (> (npositional %args) (+ nreq nopt))))
+ (if alt
+ (apply alt-proc %args)
+ ((scm-error 'wrong-number-of-args
+ "eval" "Wrong number of arguments"
+ '() #f))))
+ (else
+ (let* ((nvals (+ nreq (if rest? 1 0) (length inits)))
+ (env (make-env nvals unbound-arg env)))
+ (let lp ((i 0) (args %args))
+ (cond
+ ((< i nreq)
+ ;; Bind required arguments.
+ (env-set! env 0 i (car args))
+ (lp (1+ i) (cdr args)))
+ ((not kw)
+ ;; Optional args (possibly), but no keyword args.
+ (let lp ((i i) (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))
+ ((< i (+ nreq nopt))
+ (cond
+ ((< i nargs)
+ (env-set! env 0 i (car args))
+ (lp (1+ i) (cdr args) (cdr inits)))
+ (else
+ (env-set! env 0 i (eval (car inits) env))
+ (lp (1+ i) args (cdr inits)))))
(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))))
+ (when rest?
+ (env-set! env 0 i args))
+ (eval body env)))))
+ (else
+ ;; Optional args. As before, but stop at the first
+ ;; keyword.
+ (let lp ((i i) (args args) (inits inits))
+ (cond
+ ((< i (+ nreq nopt))
+ (cond
+ ((and (< i nargs) (not (keyword? (car args))))
+ (env-set! env 0 i (car args))
+ (lp (1+ i) (cdr args) (cdr inits)))
+ (else
+ (env-set! env 0 i (eval (car inits) env))
+ (lp (1+ i) args (cdr inits)))))
+ (else
+ (when rest?
+ (env-set! env 0 i args))
+ (let ((aok (car kw))
+ (kw (cdr kw))
+ (kw-base (if rest? (1+ i) i)))
;; 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))))))))))))))))
+ (cond
+ ((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.
+ (env-set! env 0 (cdr kw-pair) v)
+ ;; Unknown keyword.
+ (if (not aok)
+ ((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
+ ;; Finished parsing keywords. Fill in
+ ;; uninitialized kwargs by evalling init
+ ;; expressions in their appropriate
+ ;; environment.
+ (let lp ((i kw-base) (inits inits))
+ (cond
+ ((pair? inits)
+ (when (eq? (env-ref env 0 i) unbound-arg)
+ (env-set! env 0 i (eval (car inits) env)))
+ (lp (1+ i) (cdr inits)))
+ (else
+ ;; 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))
+ (('lexical-ref (depth . width))
+ (env-ref env depth width))
(('call (f nargs . args))
(let ((proc (eval f env)))
(variable-ref
(if (variable? var-or-sym)
var-or-sym
- (memoize-variable-access! exp
- (capture-env (if (pair? env)
- (cdr (last-pair env))
- env))))))
+ (memoize-variable-access! exp (env-toplevel env)))))
(('if (test consequent . alternate))
(if (eval test env)
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)))))
+ (eval body ((let-env-evaluator eval env (_ _ _ _)) inits)))
- (('lambda (body docstring nreq . tail))
+ (('lambda (body meta nreq . tail))
(let ((proc
(if (null? tail)
- (make-fixed-closure eval nreq body (capture-env env))
+ (make-fixed-closure eval nreq body 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))
+ (make-rest-closure eval nreq body env)
+ (apply make-general-closure env body nreq tail)))))
+ (let lp ((meta meta))
+ (unless (null? meta)
+ (set-procedure-property! proc (caar meta) (cdar meta))
+ (lp (cdr meta))))
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)))
+ (('seq (head . tail))
+ (begin
+ (eval head env)
+ (eval tail env)))
+
+ (('lexical-set! ((depth . width) . x))
+ (env-set! env depth width (eval x env)))
(('call-with-values (producer . consumer))
(call-with-values (eval producer env)
(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)
+ (begin
+ (define! name (eval x env))
(if #f #f)))
-
+
+ (('capture-module x)
+ (eval x (current-module)))
+
(('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))))
+ (memoize-variable-access! exp (env-toplevel 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-with-prompt (tag thunk . handler))
+ (call-with-prompt
+ (eval tag env)
+ (eval thunk env)
+ (eval handler env)))
(('call/cc proc)
(call/cc (eval proc env)))
(if (macroexpanded? exp)
exp
((module-transformer (current-module)) exp)))
- '()))))
+ #f))))
;;;; "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)
t)
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)
;; clauses. `g+s' is a list of two elements, the get! and set!
;; expressions respectively.
+(define (match-error v)
+ #((definite-bailout? . #t))
+ (error 'match "no matching pattern" v))
+
(define-syntax match-next
(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 match-error in non-tail context, so that the
+ ;; backtrace can show the source location of the failing match
+ ;; form.
+ (begin
+ (match-error 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 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
\"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 "#"))))
- ((uniform-vector? x)
- (cond
- ((>= width 9)
- (format #t "#~a(" (uniform-vector-element-type x))
- (print-sequence x (- width 6) (uniform-vector-length x)
- uniform-vector-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 "#"))))
+ ((uniform-vector? x)
+ (cond
+ ((>= width 9)
+ (format #t "#~a(" (uniform-vector-element-type x))
+ (print-sequence x (- width 6) (uniform-vector-length x)
+ uniform-vector-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 (eq? (cadr a) 'macro)
+ (if (memq (cadr a) '(macro syntax-parameter))
(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))
+ (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))
- (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
(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) (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) (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)) tmp-1))
(apply (lambda (dots e) (gen-syntax src e r maps (lambda (x) #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 "misplaced ellipsis" 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)))) 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)))))
(else (values 'other #f)))))))))))
(syntax-locally-bound-identifiers
(lambda (id)
(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))
(cons '#(syntax-object x ((top)) (hygiene guile))
(cons k
(map (lambda (tmp-1 tmp)
- (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp)
+ (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
(list '#(syntax-object syntax ((top)) (hygiene guile))
tmp-1)))
template
(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))
(cons '#(syntax-object x ((top)) (hygiene guile))
(cons k
(map (lambda (tmp-1 tmp)
- (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp)
+ (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
(list '#(syntax-object syntax ((top)) (hygiene guile))
tmp-1)))
template
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 (eq? (cadr a) 'macro)
+ (if (memq (cadr a) '(macro syntax-parameter))
(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))
- (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))
+ (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 ()
(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)
- (syntax-violation 'syntax "misplaced ellipsis" src)
- (values `(quote ,e) maps)))))
- (syntax-case e ()
- ((dots e)
- (ellipsis? #'dots)
- (gen-syntax src #'e r maps (lambda (x) #f) mod))
- ((x dots . y)
- ;; this could be about a dozen lines of code, except that we
- ;; choose to handle #'(x ... ...) forms
- (ellipsis? #'dots)
- (let f ((y #'y)
- (k (lambda (maps)
- (call-with-values
- (lambda ()
- (gen-syntax src #'x r
- (cons '() maps) ellipsis? mod))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis"
- src)
- (values (gen-map x (car maps))
- (cdr maps))))))))
- (syntax-case y ()
- ((dots . y)
- (ellipsis? #'dots)
- (f #'y
- (lambda (maps)
- (call-with-values
- (lambda () (k (cons '() maps)))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis" src)
- (values (gen-mappend x (car maps))
- (cdr maps))))))))
- (_ (call-with-values
- (lambda () (gen-syntax src y r maps ellipsis? mod))
- (lambda (y maps)
- (call-with-values
- (lambda () (k maps))
- (lambda (x maps)
- (values (gen-append x y) maps)))))))))
- ((x . y)
- (call-with-values
- (lambda () (gen-syntax src #'x r maps ellipsis? mod))
- (lambda (x maps)
- (call-with-values
- (lambda () (gen-syntax src #'y r maps ellipsis? mod))
- (lambda (y maps) (values (gen-cons x y) maps))))))
- (#(e1 e2 ...)
- (call-with-values
- (lambda ()
- (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
- (lambda (e maps) (values (gen-vector e) maps))))
- (_ (values `(quote ,e) maps))))))
-
- (define gen-ref
- (lambda (src var level maps)
- (if (fx= level 0)
- (values var maps)
- (if (null? maps)
- (syntax-violation 'syntax "missing ellipsis" src)
- (call-with-values
- (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
- (lambda (outer-var outer-maps)
- (let ((b (assq outer-var (car maps))))
- (if b
- (values (cdr b) maps)
- (let ((inner-var (gen-var 'tmp)))
- (values inner-var
- (cons (cons (cons outer-var inner-var)
- (car maps))
- outer-maps)))))))))))
-
- (define gen-mappend
- (lambda (e map-env)
- `(apply (primitive append) ,(gen-map e map-env))))
-
- (define gen-map
- (lambda (e map-env)
- (let ((formals (map cdr map-env))
- (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
- (cond
- ((eq? (car e) 'ref)
- ;; identity map equivalence:
- ;; (map (lambda (x) x) y) == y
- (car actuals))
- ((and-map
- (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
- (cdr e))
- ;; eta map equivalence:
- ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
- `(map (primitive ,(car e))
- ,@(map (let ((r (map cons formals actuals)))
- (lambda (x) (cdr (assq (cadr x) r))))
- (cdr e))))
- (else `(map (lambda ,formals ,e) ,@actuals))))))
-
- (define gen-cons
- (lambda (x y)
- (case (car y)
- ((quote)
- (if (eq? (car x) 'quote)
- `(quote (,(cadr x) . ,(cadr y)))
- (if (eq? (cadr y) '())
- `(list ,x)
- `(cons ,x ,y))))
- ((list) `(list ,x ,@(cdr y)))
- (else `(cons ,x ,y)))))
-
- (define gen-append
- (lambda (x y)
- (if (equal? y '(quote ()))
- x
- `(append ,x ,y))))
-
- (define gen-vector
- (lambda (x)
- (cond
- ((eq? (car x) 'list) `(vector ,@(cdr x)))
- ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
- (else `(list->vector ,x)))))
-
-
- (define regen
- (lambda (x)
- (case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
- ((primitive) (build-primref no-source (cadr x)))
- ((quote) (build-data no-source (cadr x)))
- ((lambda)
- (if (list? (cadr x))
- (build-simple-lambda no-source (cadr x) #f (cadr x) '() (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)
+ (syntax-violation 'syntax "misplaced ellipsis" src)
+ (values `(quote ,e) maps))))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? #'dots)
+ (gen-syntax src #'e r maps (lambda (x) #f) mod))
+ ((x dots . y)
+ ;; this could be about a dozen lines of code, except that we
+ ;; choose to handle #'(x ... ...) forms
+ (ellipsis? #'dots)
+ (let f ((y #'y)
+ (k (lambda (maps)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'x r
+ (cons '() maps) ellipsis? mod))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis"
+ src)
+ (values (gen-map x (car maps))
+ (cdr maps))))))))
+ (syntax-case y ()
+ ((dots . y)
+ (ellipsis? #'dots)
+ (f #'y
+ (lambda (maps)
(call-with-values
- (lambda () (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)))))
(else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id)
#((macro-type . syntax-rules)
(patterns pattern ...))
(syntax-case x (k ...)
- ((dummy . pattern) #'template)
+ ((_ . pattern) #'template)
...)))
((_ (k ...) docstring ((keyword . pattern) template) ...)
(string? (syntax->datum #'docstring))
#((macro-type . syntax-rules)
(patterns pattern ...))
(syntax-case x (k ...)
- ((dummy . pattern) #'template)
+ ((_ . pattern) #'template)
...))))))
(define-syntax define-syntax-rule
+++ /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))))
;;;; 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
-;;; Guile Lowlevel Intermediate Language
-
-;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+;;; installed-scm-file
+;;;; Copyright (C) 2003, 2006, 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
;;;; 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
-;;; Code:
-
-(define-module (language bytecode spec)
- #:use-module (system base language)
- #:use-module (system vm objcode)
- #:export (bytecode))
-
-(define (compile-objcode x e opts)
- (values (bytecode->objcode x) e e))
-
-(define (decompile-objcode x e opts)
- (values (objcode->bytecode x) e))
+(define-module (ice-9 weak-vector)
+ #:export (make-weak-vector list->weak-vector weak-vector weak-vector?))
-(define-language bytecode
- #:title "Guile Bytecode Vectors"
- #:reader (lambda (port env) (read port))
- #:printer write
- #:compilers `((objcode . ,compile-objcode))
- #:decompilers `((objcode . ,decompile-objcode))
- #:for-humans? #f
- )
+(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
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; 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:
+;;; $kif for test continuations, $kargs for continuations that bind
+;;; values, 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:
+;;;
+;;; - $ktrunc represents a continuation that receives multiple values,
+;;; but which truncates them to some number of required values,
+;;; possibly with a rest list.
+;;;
+;;; - $kentry labels an entry point for a $fun (a function), and
+;;; contains a $ktail representing the formal argument which is the
+;;; function's continuation.
+;;;
+;;; - $kentry also contains $kclause continuations, corresponding to
+;;; the case-lambda clauses of the function. $kclause actually
+;;; contains the clause body. 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 src meta free
+;;; ($ $cont kentry
+;;; ($ $kentry self ($ $cont ktail _ ($ $ktail))
+;;; (($ $kclause arity
+;;; ($ $cont kbody _ ($ $kargs names syms body)))
+;;; ...))))
+;;; #t))
+;;;
+;;; A $continue to ktail is in tail position. $kentry, $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. A $prompt also records the continuation
+;;; that pops the prompt, to make various static analyses easier.
+;;;
+;;; In summary:
+;;;
+;;; - $letk, $letrec, and $continue are terms.
+;;;
+;;; - $cont is a continuation, containing a continuation body ($kargs,
+;;; $kif, 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)
+ #:export (;; Helper.
+ $arity
+ make-$arity
+
+ ;; Terms.
+ $letk $continue $letrec
+
+ ;; Continuations.
+ $cont
+
+ ;; Continuation bodies.
+ $kif $ktrunc $kargs $kentry $ktail $kclause
+
+ ;; Expressions.
+ $void $const $prim $fun $call $primcall $values $prompt
+
+ ;; Building macros.
+ let-gensyms
+ build-cps-term build-cps-cont build-cps-exp
+ rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
+
+ ;; Misc.
+ parse-cps unparse-cps
+ fold-conts fold-local-conts))
+
+;; 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)
+
+;; Continuations
+(define-cps-type $cont k cont)
+(define-cps-type $kif kt kf)
+(define-cps-type $ktrunc arity k)
+(define-cps-type $kargs names syms body)
+(define-cps-type $kentry self tail clauses)
+(define-cps-type $ktail)
+(define-cps-type $kclause arity cont)
+
+;; Expressions.
+(define-cps-type $void)
+(define-cps-type $const val)
+(define-cps-type $prim name)
+(define-cps-type $fun src meta free body)
+(define-cps-type $call proc args)
+(define-cps-type $primcall name args)
+(define-cps-type $values args)
+(define-cps-type $prompt escape? tag handler pop)
+
+(define-syntax let-gensyms
+ (syntax-rules ()
+ ((_ (sym ...) body body* ...)
+ (let ((sym (gensym (symbol->string 'sym))) ...)
+ body 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 $kif $ktrunc $kargs $kentry $ktail $kclause)
+ ((_ (unquote exp))
+ exp)
+ ((_ ($kif kt kf))
+ (make-$kif kt kf))
+ ((_ ($ktrunc req rest kargs))
+ (make-$ktrunc (make-$arity req '() rest '() #f) kargs))
+ ((_ ($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)))
+ ((_ ($kentry self tail (unquote clauses)))
+ (make-$kentry self (build-cps-cont tail) clauses))
+ ((_ ($kentry self tail (clause ...)))
+ (make-$kentry self (build-cps-cont tail) (list (build-cps-cont clause) ...)))
+ ((_ ($ktail))
+ (make-$ktail))
+ ((_ ($kclause arity cont))
+ (make-$kclause (build-arity arity) (build-cps-cont cont)))))
+
+(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 $call $primcall $values $prompt)
+ ((_ (unquote exp)) exp)
+ ((_ ($void)) (make-$void))
+ ((_ ($const val)) (make-$const val))
+ ((_ ($prim name)) (make-$prim name))
+ ((_ ($fun src meta free body))
+ (make-$fun src meta free (build-cps-cont body)))
+ ((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
+ ((_ ($call proc args)) (make-$call proc args))
+ ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...)))
+ ((_ ($primcall name args)) (make-$primcall name args))
+ ((_ ($values (arg ...))) (make-$values (list arg ...)))
+ ((_ ($values args)) (make-$values args))
+ ((_ ($prompt escape? tag handler pop))
+ (make-$prompt escape? tag handler pop))))
+
+(define-syntax build-cps-term
+ (syntax-rules (unquote $letk $letk* $letconst $letrec $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-gensyms (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)))
+ ((_ ($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))))
+ (('kif kt kf)
+ (build-cont-body ($kif kt kf)))
+ (('ktrunc req rest k)
+ (build-cont-body ($ktrunc req rest k)))
+ (('kargs names syms body)
+ (build-cont-body ($kargs names syms ,(parse-cps body))))
+ (('kentry self tail clauses)
+ (build-cont-body
+ ($kentry self ,(parse-cps tail) ,(map parse-cps clauses))))
+ (('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))))
+ (('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 meta free body)
+ (build-cps-exp ($fun (src exp) meta free ,(parse-cps body))))
+ (('letrec ((name sym fun) ...) body)
+ (build-cps-term
+ ($letrec name sym (map parse-cps fun) ,(parse-cps body))))
+ (('call proc arg ...)
+ (build-cps-exp ($call proc arg)))
+ (('primcall name arg ...)
+ (build-cps-exp ($primcall name arg)))
+ (('values arg ...)
+ (build-cps-exp ($values arg)))
+ (('prompt escape? tag handler pop)
+ (build-cps-exp ($prompt escape? tag handler pop)))
+ (_
+ (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)))
+ (($ $kif kt kf)
+ `(kif ,kt ,kf))
+ (($ $ktrunc ($ $arity req () rest '() #f) k)
+ `(ktrunc ,req ,rest ,k))
+ (($ $kargs () () body)
+ `(kseq ,(unparse-cps body)))
+ (($ $kargs names syms body)
+ `(kargs ,names ,syms ,(unparse-cps body)))
+ (($ $kentry self tail clauses)
+ `(kentry ,self ,(unparse-cps tail) ,(map unparse-cps clauses)))
+ (($ $ktail)
+ `(ktail))
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body)
+ `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
+
+ ;; Calls.
+ (($ $continue k src exp)
+ `(continue ,k ,(unparse-cps exp)))
+ (($ $void)
+ `(void))
+ (($ $const val)
+ `(const ,val))
+ (($ $prim name)
+ `(prim ,name))
+ (($ $fun src meta free body)
+ `(fun ,meta ,free ,(unparse-cps body)))
+ (($ $letrec names syms funs body)
+ `(letrec ,(map (lambda (name sym fun)
+ (list name sym (unparse-cps fun)))
+ names syms funs)
+ ,(unparse-cps body)))
+ (($ $call proc args)
+ `(call ,proc ,@args))
+ (($ $primcall name args)
+ `(primcall ,name ,@args))
+ (($ $values args)
+ `(values ,@args))
+ (($ $prompt escape? tag handler pop)
+ `(prompt ,escape? ,tag ,handler ,pop))
+ (_
+ (error "unexpected cps" exp))))
+
+(define (fold-conts proc seed fun)
+ (define (cont-folder cont seed)
+ (match cont
+ (($ $cont k cont)
+ (let ((seed (proc k cont seed)))
+ (match cont
+ (($ $kargs names syms body)
+ (term-folder body seed))
+
+ (($ $kentry self tail clauses)
+ (fold cont-folder (cont-folder tail seed) clauses))
+
+ (($ $kclause arity body)
+ (cont-folder body seed))
+
+ (_ seed))))))
+
+ (define (fun-folder fun seed)
+ (match fun
+ (($ $fun src meta free body)
+ (cont-folder body seed))))
+
+ (define (term-folder term seed)
+ (match term
+ (($ $letk conts body)
+ (fold cont-folder (term-folder body seed) conts))
+
+ (($ $continue k src exp)
+ (match exp
+ (($ $fun) (fun-folder exp seed))
+ (_ seed)))
+
+ (($ $letrec names syms funs body)
+ (fold fun-folder (term-folder body seed) funs))))
+
+ (fun-folder fun seed))
+
+(define (fold-local-conts proc seed cont)
+ (define (cont-folder cont seed)
+ (match cont
+ (($ $cont k cont)
+ (let ((seed (proc k cont seed)))
+ (match cont
+ (($ $kargs names syms body)
+ (term-folder body seed))
+
+ (($ $kentry self tail clauses)
+ (fold cont-folder (cont-folder tail seed) clauses))
+
+ (($ $kclause arity body)
+ (cont-folder body seed))
+
+ (_ seed))))))
+
+ (define (term-folder term seed)
+ (match term
+ (($ $letk conts body)
+ (fold cont-folder (term-folder body seed) conts))
+
+ (($ $continue) seed)
+
+ (($ $letrec names syms funs body) (term-folder body seed))))
+
+ (cont-folder cont seed))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; 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-clause-arities clause)
+ (let ((conts (build-local-cont-table clause))
+ (ktail (match clause
+ (($ $cont _ ($ $kentry _ ($ $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 fix-arities 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 conts)
+ (($ $ktail)
+ ,(let-gensyms (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)))))
+ (($ $ktrunc arity kargs)
+ ,(rewrite-cps-term arity
+ (($ $arity () () #f () #f)
+ ($continue kargs src ,exp))
+ (_
+ ,(let-gensyms (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-gensyms (k*)
+ (build-cps-term
+ ($letk ((k* ($kargs () () ($continue k src ($void)))))
+ ($continue k* src ,exp)))))))
+ (1
+ (rewrite-cps-term (lookup-cont k conts)
+ (($ $ktail)
+ ,(rewrite-cps-term exp
+ (($values (sym))
+ ($continue ktail src ($primcall 'return (sym))))
+ (_
+ ,(let-gensyms (k* v)
+ (build-cps-term
+ ($letk ((k* ($kargs (v) (v)
+ ($continue k src
+ ($primcall 'return (v))))))
+ ($continue k* src ,exp)))))))
+ (($ $ktrunc arity kargs)
+ ,(rewrite-cps-term arity
+ (($ $arity (_) () #f () #f)
+ ($continue kargs src ,exp))
+ (_
+ ,(let-gensyms (kvalues value)
+ (build-cps-term
+ ($letk ((kvalues ($kargs ('value) (value)
+ ($continue k src
+ ($primcall 'values (value))))))
+ ($continue kvalues src ,exp)))))))
+ (($ $kargs () () _)
+ ,(let-gensyms (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)
+ ,(adapt-exp 1 k src (fix-arities exp)))
+ (($ $call)
+ ;; In general, calls have unknown return arity. For that
+ ;; reason every non-tail call has an implicit adaptor
+ ;; continuation to adapt the return to the target
+ ;; continuation, and we don't need to do any adapting here.
+ ($continue k src ,exp))
+ (($ $primcall 'return (arg))
+ ;; Primcalls to return are in tail position.
+ ($continue ktail src ,exp))
+ (($ $primcall (? (lambda (name)
+ (and (not (prim-rtl-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-rtl-instruction name)))
+ (if (and inst (not (eq? inst name)))
+ (build-cps-exp ($primcall inst args))
+ exp)))
+ (let-gensyms (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))
+ (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $cont)
+ ,cont)))
+
+ (rewrite-cps-cont clause
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
+
+(define (fix-arities fun)
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta free ,(fix-clause-arities body)))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; 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 (ice-9 receive)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:export (convert-closures))
+
+(define (union s1 s2)
+ (lset-union eq? s1 s2))
+
+(define (difference s1 s2)
+ (lset-difference eq? s1 s2))
+
+;; bound := sym ...
+;; free := sym ...
+
+(define (convert-free-var sym self bound k)
+ "Convert one possibly free variable reference to a bound reference.
+
+If @var{sym} is free (i.e., not present in @var{bound},), it is replaced
+by a closure reference via a @code{free-ref} primcall, and @var{k} is
+called with the new var. Otherwise @var{sym} is bound, so @var{k} is
+called with @var{sym}.
+
+@var{k} should return two values: a term and a list of additional free
+values in the term."
+ (if (memq sym bound)
+ (k sym)
+ (let-gensyms (k* sym*)
+ (receive (exp free) (k sym*)
+ (values (build-cps-term
+ ($letk ((k* ($kargs (sym*) (sym*) ,exp)))
+ ($continue k* #f ($primcall 'free-ref (self sym)))))
+ (cons sym free))))))
+
+(define (convert-free-vars syms self bound k)
+ "Convert a number of possibly free references to bound references.
+@var{k} is called with the bound references, and should return two
+values: the term and a list of additional free variables in the term."
+ (match syms
+ (() (k '()))
+ ((sym . syms)
+ (convert-free-var sym self bound
+ (lambda (sym)
+ (convert-free-vars syms self bound
+ (lambda (syms)
+ (k (cons sym syms)))))))))
+
+(define (init-closure src v free outer-self outer-bound body)
+ "Initialize the free variables @var{free} in a closure bound to
+@var{v}, and continue with @var{body}. @var{outer-self} must be the
+label of the outer procedure, where the initialization will be
+performed, and @var{outer-bound} is the list of bound variables there."
+ (fold (lambda (free idx body)
+ (let-gensyms (k idxsym)
+ (build-cps-term
+ ($letk ((k ($kargs () () ,body)))
+ ,(convert-free-var
+ free outer-self outer-bound
+ (lambda (free)
+ (values (build-cps-term
+ ($letconst (('idx idxsym idx))
+ ($continue k src
+ ($primcall 'free-set! (v idxsym free)))))
+ '())))))))
+ body
+ free
+ (iota (length free))))
+
+(define (cc* exps self bound)
+ "Convert all free references in the list of expressions @var{exps} to
+bound references, and convert functions to flat closures. Returns two
+values: the transformed list, and a cumulative set of free variables."
+ (let lp ((exps exps) (exps* '()) (free '()))
+ (match exps
+ (() (values (reverse exps*) free))
+ ((exp . exps)
+ (receive (exp* free*) (cc exp self bound)
+ (lp exps (cons exp* exps*) (union free free*)))))))
+
+;; Closure conversion.
+(define (cc exp self bound)
+ "Convert all free references in @var{exp} to bound references, and
+convert functions to flat closures."
+ (match exp
+ (($ $letk conts body)
+ (receive (conts free) (cc* conts self bound)
+ (receive (body free*) (cc body self bound)
+ (values (build-cps-term ($letk ,conts ,body))
+ (union free free*)))))
+
+ (($ $cont sym ($ $kargs names syms body))
+ (receive (body free) (cc body self (append syms bound))
+ (values (build-cps-cont (sym ($kargs names syms ,body)))
+ free)))
+
+ (($ $cont sym ($ $kentry self tail clauses))
+ (receive (clauses free) (cc* clauses self (list self))
+ (values (build-cps-cont (sym ($kentry self ,tail ,clauses)))
+ free)))
+
+ (($ $cont sym ($ $kclause arity body))
+ (receive (body free) (cc body self bound)
+ (values (build-cps-cont (sym ($kclause ,arity ,body)))
+ free)))
+
+ (($ $cont)
+ ;; Other kinds of continuations don't bind values and don't have
+ ;; bodies.
+ (values exp '()))
+
+ ;; Remove letrec.
+ (($ $letrec names syms funs body)
+ (let ((bound (append bound syms)))
+ (receive (body free) (cc body self bound)
+ (let lp ((in (map list names syms funs))
+ (bindings (lambda (body) body))
+ (body body)
+ (free free))
+ (match in
+ (() (values (bindings body) free))
+ (((name sym ($ $fun src meta () fun-body)) . in)
+ (receive (fun-body fun-free) (cc fun-body #f '())
+ (lp in
+ (lambda (body)
+ (let-gensyms (k)
+ (build-cps-term
+ ($letk ((k ($kargs (name) (sym) ,(bindings body))))
+ ($continue k src
+ ($fun src meta fun-free ,fun-body))))))
+ (init-closure src sym fun-free self bound body)
+ (union free (difference fun-free bound))))))))))
+
+ (($ $continue k src
+ (or ($ $void)
+ ($ $const)
+ ($ $prim)))
+ (values exp '()))
+
+ (($ $continue k src ($ $fun src* meta () body))
+ (receive (body free) (cc body #f '())
+ (match free
+ (()
+ (values (build-cps-term
+ ($continue k src ($fun src* meta free ,body)))
+ free))
+ (_
+ (values
+ (let-gensyms (kinit v)
+ (build-cps-term
+ ($letk ((kinit ($kargs (v) (v)
+ ,(init-closure
+ src v free self bound
+ (build-cps-term
+ ($continue k src ($values (v))))))))
+ ($continue kinit src ($fun src* meta free ,body)))))
+ (difference free bound))))))
+
+ (($ $continue k src ($ $call proc args))
+ (convert-free-vars (cons proc args) self bound
+ (match-lambda
+ ((proc . args)
+ (values (build-cps-term
+ ($continue k src ($call proc args)))
+ '())))))
+
+ (($ $continue k src ($ $primcall name args))
+ (convert-free-vars args self bound
+ (lambda (args)
+ (values (build-cps-term
+ ($continue k src ($primcall name args)))
+ '()))))
+
+ (($ $continue k src ($ $values args))
+ (convert-free-vars args self bound
+ (lambda (args)
+ (values (build-cps-term
+ ($continue k src ($values args)))
+ '()))))
+
+ (($ $continue k src ($ $prompt escape? tag handler pop))
+ (convert-free-var
+ tag self bound
+ (lambda (tag)
+ (values (build-cps-term
+ ($continue k src ($prompt escape? tag handler pop)))
+ '()))))
+
+ (_ (error "what" exp))))
+
+;; Convert the slot arguments of 'free-ref' primcalls from symbols to
+;; indices.
+(define (convert-to-indices body free)
+ (define (free-index sym)
+ (or (list-index (cut eq? <> sym) free)
+ (error "free variable not found!" sym free)))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts) ,(visit-term body)))
+ (($ $continue k src ($ $primcall 'free-ref (closure sym)))
+ ,(let-gensyms (idx)
+ (build-cps-term
+ ($letconst (('idx idx (free-index sym)))
+ ($continue k src ($primcall 'free-ref (closure idx)))))))
+ (($ $continue k src ($ $fun src* meta free body))
+ ($continue k src
+ ($fun src* meta free ,(convert-to-indices body free))))
+ (($ $continue)
+ ,term)))
+ (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))
+ (sym ($kclause ,arity ,(visit-cont body))))
+ ;; Other kinds of continuations don't bind values and don't have
+ ;; bodies.
+ (($ $cont)
+ ,cont)))
+
+ (rewrite-cps-cont body
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))))
+
+(define (convert-closures exp)
+ "Convert free reference in @var{exp} to primcalls to @code{free-ref},
+and allocate and initialize flat closures."
+ (match exp
+ (($ $fun src meta () body)
+ (receive (body free) (cc body #f '())
+ (unless (null? free)
+ (error "Expected no free vars in toplevel thunk" exp body free))
+ (build-cps-exp
+ ($fun src meta free ,(convert-to-indices body free)))))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; Commentary:
+;;;
+;;; Compiling CPS to RTL. The result is in the RTL language, which
+;;; happens to be an ELF image as a bytecode.
+;;;
+;;; Code:
+
+(define-module (language cps compile-rtl)
+ #: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 dfg)
+ #:use-module (language cps elide-values)
+ #:use-module (language cps primitives)
+ #:use-module (language cps reify-primitives)
+ #:use-module (language cps slot-allocation)
+ #:use-module (language cps specialize-primcalls)
+ #:use-module (system vm assembler)
+ #:export (compile-rtl))
+
+;; 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))
+
+ ;; Calls to source-to-source optimization passes go here.
+ (let* ((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)))
+ ;; Passes that are needed:
+ ;;
+ ;; * Abort contification: turning abort primcalls into continuation
+ ;; calls, and eliding prompts if possible.
+ ;;
+ ;; * Common subexpression elimination. Desperately needed. Requires
+ ;; effects analysis.
+ ;;
+ ;; * 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).
+ ;;
+ ;; * Generic simplification pass, to be run as needed. Used to
+ ;; "clean up", both on the original raw input and after specific
+ ;; optimization passes.
+
+ exp))
+
+(define (collect-conts f cfa)
+ (let ((contv (make-vector (cfa-k-count cfa) #f)))
+ (fold-local-conts
+ (lambda (k cont tail)
+ (let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
+ (when idx
+ (vector-set! contv idx cont))))
+ '()
+ (match f
+ (($ $fun src meta free entry)
+ entry)))
+ contv))
+
+(define (compile-fun f asm)
+ (let* ((dfg (compute-dfg f #:global? #f))
+ (cfa (analyze-control-flow f dfg))
+ (allocation (allocate-slots f dfg))
+ (contv (collect-conts f cfa)))
+ (define (lookup-cont k)
+ (vector-ref contv (cfa-k-idx cfa k)))
+
+ (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 meta)
+ (match (vector-ref contv 0)
+ (($ $kentry self tail clauses)
+ (emit-begin-program asm (cfa-k-sym cfa 0) meta)
+ (let lp ((n 1)
+ (ks (map (match-lambda (($ $cont k) k)) clauses)))
+ (match ks
+ (()
+ (unless (= n (vector-length contv))
+ (error "unexpected end of clauses"))
+ (emit-end-program asm))
+ ((k . ks)
+ (unless (eq? (cfa-k-sym cfa n) k)
+ (error "unexpected k" k))
+ (lp (compile-clause n (and (pair? ks) (car ks)))
+ ks)))))))
+
+ (define (compile-clause n alternate)
+ (match (vector-ref contv n)
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
+ (let* ((kw-indices (map (match-lambda
+ ((key name sym)
+ (cons key (lookup-slot sym allocation))))
+ kw))
+ (k (cfa-k-sym cfa n))
+ (nlocals (lookup-nlocals k allocation)))
+ (emit-label asm k)
+ (emit-begin-kw-arity asm req opt rest kw-indices
+ allow-other-keys? nlocals alternate)
+ (let ((next (compile-body (1+ n) nlocals)))
+ (emit-end-arity asm)
+ next)))))
+
+ (define (compile-body n nlocals)
+ (let compile-cont ((n n))
+ (if (= n (vector-length contv))
+ n
+ (match (vector-ref contv n)
+ (($ $kclause) n)
+ (($ $kargs _ _ term)
+ (emit-label asm (cfa-k-sym cfa n))
+ (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 n k exp nlocals)
+ (compile-cont (1+ n))))))
+ (_
+ (emit-label asm (cfa-k-sym cfa n))
+ (compile-cont (1+ n)))))))
+
+ (define (compile-expression n k exp nlocals)
+ (let* ((label (cfa-k-sym cfa n))
+ (k-idx (cfa-k-idx cfa k))
+ (fallthrough? (= k-idx (1+ n))))
+ (define (maybe-emit-jump)
+ (unless (= k-idx (1+ n))
+ (emit-br asm k)))
+ (match (vector-ref contv k-idx)
+ (($ $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 () ())
+ (compile-effect label exp k nlocals)
+ (maybe-emit-jump))
+ (($ $kargs names syms)
+ (compile-values label exp syms)
+ (maybe-emit-jump))
+ (($ $kif kt kf)
+ (compile-test label exp kt kf
+ (and (= k-idx (1+ n))
+ (< (+ n 2) (cfa-k-count cfa))
+ (cfa-k-sym cfa (+ n 2)))))
+ (($ $ktrunc ($ $arity req () rest () #f) kargs)
+ (compile-trunc label k exp (length req) (and rest #t) nlocals)
+ (unless (and (= k-idx (1+ n))
+ (< (+ n 2) (cfa-k-count cfa))
+ (eq? (cfa-k-sym cfa (+ n 2)) kargs))
+ (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))))
+ (($ $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))
+ (($ $fun src meta () ($ $cont k))
+ (emit-load-static-procedure asm dst k))
+ (($ $fun src meta free ($ $cont k))
+ (emit-make-closure asm dst k (length free)))
+ (($ $call proc args)
+ (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-receive asm dst proc-slot nlocals)))
+ (($ $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/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/immediate (vtable nfields))
+ (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields)))
+ (($ $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-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-rtl-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 pop)
+ (match (lookup-cont handler)
+ (($ $ktrunc ($ $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)
+ (emit-receive-values asm proc-slot (->bool rest) nreq)
+ (when 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!/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 'variable-set! (var val))
+ (emit-box-set! asm (slot var) (slot val)))
+ (($ $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-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)) (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))
+ ;; 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))))
+
+ (define (compile-trunc label k exp nreq rest? nlocals)
+ (match exp
+ (($ $call proc args)
+ (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)
+ ;; FIXME: Only allow more values if there is a rest arg.
+ ;; Express values truncation by the presence of an
+ ;; unused rest arg instead of implicitly.
+ (emit-receive-values asm proc-slot #t nreq)
+ (when rest?
+ (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 f
+ (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
+ ;; FIXME: src on kentry instead?
+ (when src
+ (emit-source asm src))
+ (compile-entry (or meta '()))))))
+
+(define (visit-funs proc exp)
+ (match exp
+ (($ $continue _ _ exp)
+ (visit-funs proc exp))
+
+ (($ $fun src meta free body)
+ (proc exp)
+ (visit-funs proc body))
+
+ (($ $letk conts body)
+ (visit-funs proc body)
+ (for-each (lambda (cont) (visit-funs proc cont)) conts))
+
+ (($ $cont sym ($ $kargs names syms body))
+ (visit-funs proc body))
+
+ (($ $cont sym ($ $kclause arity body))
+ (visit-funs proc body))
+
+ (($ $cont sym ($ $kentry self tail clauses))
+ (for-each (lambda (clause) (visit-funs proc clause)) clauses))
+
+ (_ (values))))
+
+(define (compile-rtl exp env opts)
+ (let* ((exp (fix-arities exp))
+ (exp (optimize exp opts))
+ (exp (convert-closures exp))
+ (exp (reify-primitives exp))
+ (asm (make-assembler)))
+ (visit-funs (lambda (fun)
+ (compile-fun fun asm))
+ exp)
+ (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 Free Software Foundation, 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 ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $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 inline-constructors funs)
+ ,(visit-term body)))
+ (($ $continue k src ($ $primcall 'list args))
+ ,(let-gensyms (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-gensyms (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-gensyms (kalloc vec len init)
+ (define (initialize args n)
+ (match args
+ (()
+ (build-cps-term
+ ($continue k src ($primcall 'values (vec)))))
+ ((arg . args)
+ (let-gensyms (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 ,(inline-constructors fun)))
+ (($ $continue)
+ ,term)))
+
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body)))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; 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 rtl)
+ #:export (contify))
+
+(define (compute-contification fun)
+ (let* ((dfg (compute-dfg fun))
+ (cont-table (dfg-cont-table dfg))
+ (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 cont-table)
+ (($ $kargs (_) (sym))
+ (match (lookup-predecessors k dfg)
+ ((_)
+ ;; K has one predecessor, the one that defined SYM.
+ sym)
+ (_ #f)))
+ (_ #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 cont-table))
+ (($ $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 cont-table)
+ (($ $kentry self tail clauses)
+ ;; K is the tail of some function. If that function
+ ;; has just one clause, return that clause. Otherwise
+ ;; bail.
+ (match clauses
+ ((($ $cont _ ($ $kclause arity ($ $cont kargs))))
+ 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 src meta free body)
+ (visit-cont body))))
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont sym ($ $kargs _ _ body))
+ (visit-term body sym))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (for-each visit-cont clauses))
+ (($ $cont sym ($ $kclause arity body))
+ (visit-cont body))
+ (($ $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 src meta free ($ $cont kentry))))
+ . nsf)
+ (if (recursive? kentry)
+ (lp nsf (cons elt rec))
+ (cons (list elt) (lp nsf rec)))))))
+ (define (visit-component component)
+ (match component
+ (((name sym fun) ...)
+ (match fun
+ ((($ $fun src meta free
+ ($ $cont fun-k
+ ($ $kentry self
+ ($ $cont tail-k ($ $ktail))
+ (($ $cont _ ($ $kclause arity body))
+ ...))))
+ ...)
+ (if (contify-funs term-k sym self tail-k arity body)
+ (for-each (cut for-each visit-cont <>) body)
+ (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 src meta free
+ ($ $cont fun-k
+ ($ $kentry self
+ ($ $cont tail-k ($ $ktail))
+ (($ $cont _ ($ $kclause arity body)) ...))))
+ (if (and=> (bound-symbol k)
+ (lambda (sym)
+ (contify-fun term-k sym self tail-k arity body)))
+ (begin
+ (elide-function! k (lookup-cont k cont-table))
+ (for-each visit-cont body))
+ (visit-fun exp)))
+ (_ #t)))))
+
+ (visit-fun 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 src meta free body)
+ ($fun src meta 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 ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $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-fun 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 Free Software Foundation, 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 (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:export (build-cont-table
+ build-local-cont-table
+ lookup-cont
+
+ compute-dfg
+ dfg-cont-table
+ 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
+
+ ;; Control flow analysis.
+ analyze-control-flow
+ cfa-k-idx cfa-k-count cfa-k-sym cfa-predecessors
+
+ ;; 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-name dfa-var-sym dfa-var-count
+ print-dfa))
+
+(define (build-cont-table fun)
+ (fold-conts (lambda (k cont table)
+ (hashq-set! table k cont)
+ table)
+ (make-hash-table)
+ fun))
+
+(define (build-local-cont-table cont)
+ (fold-local-conts (lambda (k cont table)
+ (hashq-set! table k cont)
+ table)
+ (make-hash-table)
+ cont))
+
+(define (lookup-cont sym conts)
+ (let ((res (hashq-ref conts sym)))
+ (unless res
+ (error "Unknown continuation!" sym (hash-fold acons '() conts)))
+ res))
+
+;; Data-flow graph for CPS: both for values and continuations.
+(define-record-type $dfg
+ (make-dfg conts blocks use-maps)
+ dfg?
+ ;; hash table of sym -> $kif, $kargs, etc
+ (conts dfg-cont-table)
+ ;; hash table of sym -> $block
+ (blocks dfg-blocks)
+ ;; hash table of sym -> $use-map
+ (use-maps dfg-use-maps))
+
+(define-record-type $use-map
+ (make-use-map name sym def uses)
+ use-map?
+ (name use-map-name)
+ (sym use-map-sym)
+ (def use-map-def)
+ (uses use-map-uses set-use-map-uses!))
+
+(define-record-type $block
+ (%make-block scope scope-level preds succs)
+ block?
+ (scope block-scope set-block-scope!)
+ (scope-level block-scope-level set-block-scope-level!)
+ (preds block-preds set-block-preds!)
+ (succs block-succs set-block-succs!))
+
+(define (make-block scope scope-level)
+ (%make-block scope scope-level '() '()))
+
+;; Some analyses assume that the only relevant set of nodes is the set
+;; that is reachable from some start node. Others need to include nodes
+;; that are reachable from an end node as well, or all nodes in a
+;; function. In that case pass an appropriate implementation of
+;; fold-all-conts, as compute-live-variables does.
+(define* (reverse-post-order k0 get-successors #:optional
+ (fold-all-conts (lambda (f seed) seed)))
+ (let ((order '())
+ (visited? (make-hash-table)))
+ (let visit ((k k0))
+ (hashq-set! visited? k #t)
+ (for-each (lambda (k)
+ (unless (hashq-ref visited? k)
+ (visit k)))
+ (get-successors k))
+ (set! order (cons k order)))
+ (list->vector (fold-all-conts
+ (lambda (k seed)
+ (if (hashq-ref visited? k)
+ seed
+ (begin
+ (hashq-set! visited? k #t)
+ (cons k seed))))
+ order))))
+
+(define (make-block-mapping order)
+ (let ((mapping (make-hash-table)))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (hashq-set! mapping (vector-ref order n) n)
+ (lp (1+ n))))
+ mapping))
+
+(define (convert-predecessors order get-predecessors)
+ (let ((preds-vec (make-vector (vector-length order) #f)))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (vector-set! preds-vec n (get-predecessors (vector-ref order n)))
+ (lp (1+ n))))
+ preds-vec))
+
+;; Control-flow analysis.
+(define-record-type $cfa
+ (make-cfa k-map order preds)
+ cfa?
+ ;; Hash table mapping k-sym -> k-idx
+ (k-map cfa-k-map)
+ ;; Vector of k-idx -> k-sym, in reverse post order
+ (order cfa-order)
+ ;; Vector of k-idx -> list of k-idx
+ (preds cfa-preds))
+
+(define* (cfa-k-idx cfa k
+ #:key (default (lambda (k)
+ (error "unknown k" k))))
+ (or (hashq-ref (cfa-k-map cfa) k)
+ (default k)))
+
+(define (cfa-k-count cfa)
+ (vector-length (cfa-order cfa)))
+
+(define (cfa-k-sym cfa n)
+ (vector-ref (cfa-order cfa) n))
+
+(define (cfa-predecessors cfa n)
+ (vector-ref (cfa-preds cfa) n))
+
+(define* (analyze-control-flow fun dfg #:key reverse?)
+ (define (build-cfa kentry block-succs block-preds)
+ (define (block-accessor accessor)
+ (lambda (k)
+ (accessor (lookup-block k (dfg-blocks dfg)))))
+ (define (reachable-preds mapping accessor)
+ ;; It's possible for a predecessor to not be in the mapping, if
+ ;; the predecessor is not reachable from the entry node.
+ (lambda (k)
+ (filter-map (cut hashq-ref mapping <>)
+ ((block-accessor accessor) k))))
+ (let* ((order (reverse-post-order kentry (block-accessor block-succs)))
+ (k-map (make-block-mapping order))
+ (preds (convert-predecessors order
+ (reachable-preds k-map block-preds))))
+ (make-cfa k-map order preds)))
+ (match fun
+ (($ $fun src meta free
+ ($ $cont kentry
+ (and entry
+ ($ $kentry self ($ $cont ktail tail) clauses))))
+ (if reverse?
+ (build-cfa ktail block-preds block-succs)
+ (build-cfa kentry block-succs block-preds)))))
+
+;; Dominator analysis.
+(define-record-type $dominator-analysis
+ (make-dominator-analysis cfa idoms dom-levels loop-header irreducible)
+ dominator-analysis?
+ ;; The corresponding $cfa
+ (cfa dominator-analysis-cfa)
+ ;; Vector of k-idx -> k-idx
+ (idoms dominator-analysis-idoms)
+ ;; Vector of k-idx -> dom-level
+ (dom-levels dominator-analysis-dom-levels)
+ ;; Vector of k-idx -> k-idx or -1
+ (loop-header dominator-analysis-loop-header)
+ ;; Vector of k-idx -> true or false value
+ (irreducible dominator-analysis-irreducible))
+
+(define (compute-dom-levels idoms)
+ (let ((dom-levels (make-vector (vector-length idoms) #f)))
+ (define (compute-dom-level n)
+ (or (vector-ref dom-levels n)
+ (let ((dom-level (1+ (compute-dom-level (vector-ref idoms n)))))
+ (vector-set! dom-levels n dom-level)
+ dom-level)))
+ (vector-set! dom-levels 0 0)
+ (let lp ((n 0))
+ (when (< n (vector-length idoms))
+ (compute-dom-level n)
+ (lp (1+ n))))
+ dom-levels))
+
+(define (compute-idoms preds)
+ (let ((idoms (make-vector (vector-length preds) 0)))
+ (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 d1)))
+ (else (common-idom (vector-ref idoms d0) d1))))
+ (define (compute-idom preds)
+ (match preds
+ (() 0)
+ ((pred . preds)
+ (let lp ((idom pred) (preds preds))
+ (match preds
+ (() idom)
+ ((pred . preds)
+ (lp (common-idom idom pred) 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 (vector-length preds))
+ (let ((idom (vector-ref idoms n))
+ (idom* (compute-idom (vector-ref preds 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)))))
+
+(define-inlinable (vector-push! vec idx val)
+ (let ((v vec) (i idx))
+ (vector-set! v i (cons val (vector-ref v i)))))
+
+;; 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)
+ (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 idom n))
+ (lp (1+ n))))
+ doms))
+
+;; Compute a vector containing, for each node, a list of the successors
+;; of that node that are not dominated by that node. These are the "J"
+;; edges in the DJ tree.
+(define (compute-join-edges preds idoms)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vector-ref idoms n2)))))
+ (let ((joins (make-vector (vector-length idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vector-length preds))
+ (for-each (lambda (pred)
+ (unless (dominates? pred n)
+ (vector-push! joins pred n)))
+ (vector-ref preds n))
+ (lp (1+ n))))
+ joins))
+
+;; Compute a vector containing, for each node, a list of the back edges
+;; to that node. If a node is not the entry of a reducible loop, that
+;; list is empty.
+(define (compute-reducible-back-edges joins idoms)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vector-ref idoms n2)))))
+ (let ((back-edges (make-vector (vector-length idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vector-length joins))
+ (for-each (lambda (succ)
+ (when (dominates? succ n)
+ (vector-push! back-edges succ n)))
+ (vector-ref joins n))
+ (lp (1+ n))))
+ back-edges))
+
+;; Compute the levels in the dominator tree at which there are
+;; irreducible loops, as an integer. If a bit N is set in the integer,
+;; that indicates that at level N in the dominator tree, there is at
+;; least one irreducible loop.
+(define (compute-irreducible-dom-levels doms joins idoms dom-levels)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vector-ref idoms n2)))))
+ (let ((pre-order (make-vector (vector-length doms) #f))
+ (last-pre-order (make-vector (vector-length doms) #f))
+ (res 0)
+ (count 0))
+ ;; Is MAYBE-PARENT an ancestor of N on the depth-first spanning tree
+ ;; computed from the DJ graph? See Havlak 1997, "Nesting of
+ ;; Reducible and Irreducible Loops".
+ (define (ancestor? a b)
+ (let ((w (vector-ref pre-order a))
+ (v (vector-ref pre-order b)))
+ (and (<= w v)
+ (<= v (vector-ref last-pre-order w)))))
+ ;; Compute depth-first spanning tree of DJ graph.
+ (define (recurse n)
+ (unless (vector-ref pre-order n)
+ (visit n)))
+ (define (visit n)
+ ;; Pre-order visitation index.
+ (vector-set! pre-order n count)
+ (set! count (1+ count))
+ (for-each recurse (vector-ref doms n))
+ (for-each recurse (vector-ref joins n))
+ ;; Pre-order visitation index of last descendant.
+ (vector-set! last-pre-order (vector-ref pre-order n) (1- count)))
+
+ (visit 0)
+
+ (let lp ((n 0))
+ (when (< n (vector-length joins))
+ (for-each (lambda (succ)
+ ;; If this join edge is not a loop back edge but it
+ ;; does go to an ancestor on the DFST of the DJ
+ ;; graph, then we have an irreducible loop.
+ (when (and (not (dominates? succ n))
+ (ancestor? succ n))
+ (set! res (logior (ash 1 (vector-ref dom-levels succ))))))
+ (vector-ref joins n))
+ (lp (1+ n))))
+
+ res))
+
+(define (compute-nodes-by-level dom-levels)
+ (let* ((max-level (let lp ((n 0) (max-level 0))
+ (if (< n (vector-length dom-levels))
+ (lp (1+ n) (max (vector-ref dom-levels n) max-level))
+ max-level)))
+ (nodes-by-level (make-vector (1+ max-level) '())))
+ (let lp ((n (1- (vector-length dom-levels))))
+ (when (>= n 0)
+ (vector-push! nodes-by-level (vector-ref dom-levels n) n)
+ (lp (1- n))))
+ nodes-by-level))
+
+;; Collect all predecessors to the back-nodes that are strictly
+;; dominated by the loop header, and mark them as belonging to the loop.
+;; If they already have a loop header, that means they are either in a
+;; nested loop, or they have already been visited already.
+(define (mark-loop-body header back-nodes preds idoms loop-headers)
+ (define (strictly-dominates? n1 n2)
+ (and (< n1 n2)
+ (let ((idom (vector-ref idoms n2)))
+ (or (= n1 idom)
+ (strictly-dominates? n1 idom)))))
+ (define (visit node)
+ (when (strictly-dominates? header node)
+ (cond
+ ((vector-ref loop-headers node) => visit)
+ (else
+ (vector-set! loop-headers node header)
+ (for-each visit (vector-ref preds node))))))
+ (for-each visit back-nodes))
+
+(define (mark-irreducible-loops level idoms dom-levels loop-headers)
+ ;; FIXME: Identify strongly-connected components that are >= LEVEL in
+ ;; the dominator tree, and somehow mark them as irreducible.
+ (warn 'irreducible-loops-at-level level))
+
+;; "Identifying Loops Using DJ Graphs" by Sreedhar, Gao, and Lee, ACAPS
+;; Technical Memo 98, 1995.
+(define (identify-loops preds idoms dom-levels)
+ (let* ((doms (compute-dom-edges idoms))
+ (joins (compute-join-edges preds idoms))
+ (back-edges (compute-reducible-back-edges joins idoms))
+ (irreducible-levels
+ (compute-irreducible-dom-levels doms joins idoms dom-levels))
+ (loop-headers (make-vector (vector-length preds) #f))
+ (nodes-by-level (compute-nodes-by-level dom-levels)))
+ (let lp ((level (1- (vector-length nodes-by-level))))
+ (when (>= level 0)
+ (for-each (lambda (n)
+ (let ((edges (vector-ref back-edges n)))
+ (unless (null? edges)
+ (mark-loop-body n edges preds idoms loop-headers))))
+ (vector-ref nodes-by-level level))
+ (when (logbit? level irreducible-levels)
+ (mark-irreducible-loops level idoms dom-levels loop-headers))
+ (lp (1- level))))
+ loop-headers))
+
+(define (analyze-dominators cfa)
+ (match cfa
+ (($ $cfa k-map order preds)
+ (let* ((idoms (compute-idoms preds))
+ (dom-levels (compute-dom-levels idoms))
+ (loop-headers (identify-loops preds idoms dom-levels)))
+ (make-dominator-analysis cfa idoms dom-levels loop-headers #f)))))
+
+
+;; 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 union?)
+ (define (bitvector-copy! dst src)
+ (bitvector-fill! dst #f)
+ (bit-set*! dst src #t))
+ (define (bitvector-meet! accum src)
+ (bit-set*! accum src union?))
+ (let lp ((n 0) (changed? #f))
+ (cond
+ ((< n (vector-length preds))
+ (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))))
+ (for-each
+ (lambda (pred)
+ (bitvector-meet! in (vector-ref outv pred)))
+ (vector-ref preds n))
+ (bitvector-copy! out in)
+ (for-each (cut bitvector-set! out <> #f) kill)
+ (for-each (cut bitvector-set! out <> #t) gen)
+ (lp (1+ n)
+ (or changed? (not (eqv? out-count (bit-count #t out))))))))
+ (changed?
+ (lp 0 #f)))))
+
+;; Data-flow analysis.
+(define-record-type $dfa
+ (make-dfa k-map order var-map names syms in out)
+ dfa?
+ ;; Hash table mapping k-sym -> k-idx
+ (k-map dfa-k-map)
+ ;; Vector of k-idx -> k-sym
+ (order dfa-order)
+ ;; Hash table mapping var-sym -> var-idx
+ (var-map dfa-var-map)
+ ;; Vector of var-idx -> name
+ (names dfa-names)
+ ;; Vector of var-idx -> var-sym
+ (syms dfa-syms)
+ ;; Vector of k-idx -> bitvector
+ (in dfa-in)
+ ;; Vector of k-idx -> bitvector
+ (out dfa-out))
+
+(define (dfa-k-idx dfa k)
+ (or (hashq-ref (dfa-k-map dfa) k)
+ (error "unknown k" k)))
+
+(define (dfa-k-sym dfa idx)
+ (vector-ref (dfa-order dfa) idx))
+
+(define (dfa-k-count dfa)
+ (vector-length (dfa-order dfa)))
+
+(define (dfa-var-idx dfa var)
+ (or (hashq-ref (dfa-var-map dfa) var)
+ (error "unknown var" var)))
+
+(define (dfa-var-name dfa idx)
+ (vector-ref (dfa-names dfa) idx))
+
+(define (dfa-var-sym dfa idx)
+ (vector-ref (dfa-syms dfa) idx))
+
+(define (dfa-var-count dfa)
+ (vector-length (dfa-syms 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)
+ (define (make-variable-mapping use-maps)
+ (let ((mapping (make-hash-table))
+ (n 0))
+ (hash-for-each (lambda (sym use-map)
+ (hashq-set! mapping sym n)
+ (set! n (1+ n)))
+ use-maps)
+ (values mapping n)))
+ (define (block-accessor blocks accessor)
+ (lambda (k)
+ (accessor (lookup-block k blocks))))
+ (define (renumbering-accessor mapping blocks accessor)
+ (lambda (k)
+ (map (cut hashq-ref mapping <>)
+ ((block-accessor blocks accessor) k))))
+ (match fun
+ (($ $fun src meta free
+ (and entry
+ ($ $cont kentry ($ $kentry self ($ $cont ktail tail)))))
+ (call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
+ (lambda (var-map nvars)
+ (define (fold-all-conts f seed)
+ (fold-local-conts (lambda (k cont seed) (f k seed))
+ seed entry))
+ (let* ((blocks (dfg-blocks dfg))
+ (order (reverse-post-order ktail
+ (block-accessor blocks block-preds)
+ fold-all-conts))
+ (k-map (make-block-mapping order))
+ (succs (convert-predecessors
+ order
+ (renumbering-accessor k-map blocks block-succs)))
+ (syms (make-vector nvars #f))
+ (names (make-vector nvars #f))
+ (usev (make-vector (vector-length order) '()))
+ (defv (make-vector (vector-length order) '()))
+ (live-in (make-vector (vector-length order) #f))
+ (live-out (make-vector (vector-length order) #f)))
+ (define (k->idx k)
+ (or (hashq-ref k-map k) (error "unknown k" k)))
+ ;; Initialize syms, names, defv, and usev.
+ (hash-for-each
+ (lambda (sym use-map)
+ (match use-map
+ (($ $use-map name sym def uses)
+ (let ((v (or (hashq-ref var-map sym)
+ (error "unknown var" sym))))
+ (vector-set! syms v sym)
+ (vector-set! names v name)
+ (for-each (lambda (def)
+ (vector-push! defv (k->idx def) v))
+ ((block-accessor blocks block-preds) def))
+ (for-each (lambda (use)
+ (vector-push! usev (k->idx use) v))
+ uses)))))
+ (dfg-use-maps dfg))
+
+ ;; Initialize live-in and live-out sets.
+ (let lp ((n 0))
+ (when (< n (vector-length live-out))
+ (vector-set! live-in n (make-bitvector nvars #f))
+ (vector-set! live-out n (make-bitvector nvars #f))
+ (lp (1+ n))))
+
+ ;; Liveness is a reverse data-flow problem, so we give
+ ;; compute-maximum-fixed-point a reversed graph, swapping in
+ ;; and out, usev and defv, using successors instead of
+ ;; predecessors, and starting with ktail instead of the
+ ;; entry.
+ (compute-maximum-fixed-point succs live-out live-in defv usev #t)
+
+ (make-dfa k-map order var-map names syms live-in live-out)))))))
+
+(define (print-dfa dfa)
+ (match dfa
+ (($ $dfa k-map order var-map names syms in out)
+ (define (print-var-set bv)
+ (let lp ((n 0))
+ (let ((n (bit-position #t bv n)))
+ (when n
+ (format #t " ~A" (vector-ref syms n))
+ (lp (1+ n))))))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (format #t "~A:\n" (vector-ref order n))
+ (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 (visit-fun fun conts blocks use-maps global?)
+ (define (add-def! name sym def-k)
+ (unless def-k
+ (error "Term outside labelled continuation?"))
+ (hashq-set! use-maps sym (make-use-map name sym def-k '())))
+
+ (define (add-use! sym use-k)
+ (match (hashq-ref use-maps sym)
+ (#f (error "Symbol out of scope?" sym))
+ ((and use-map ($ $use-map name sym def uses))
+ (set-use-map-uses! use-map (cons use-k uses)))))
+
+ (define* (declare-block! label cont parent
+ #:optional (level
+ (1+ (lookup-scope-level parent blocks))))
+ (hashq-set! conts label cont)
+ (hashq-set! blocks label (make-block parent level)))
+
+ (define (link-blocks! pred succ)
+ (let ((pred-block (hashq-ref blocks pred))
+ (succ-block (hashq-ref blocks succ)))
+ (unless (and pred-block succ-block)
+ (error "internal error" pred-block succ-block))
+ (set-block-succs! pred-block (cons succ (block-succs pred-block)))
+ (set-block-preds! succ-block (cons pred (block-preds succ-block)))))
+
+ (define (visit exp exp-k)
+ (define (def! name sym)
+ (add-def! name sym exp-k))
+ (define (use! sym)
+ (add-use! sym exp-k))
+ (define (use-k! k)
+ (link-blocks! exp-k k))
+ (define (recur exp)
+ (visit exp exp-k))
+ (match exp
+ (($ $letk (($ $cont k cont) ...) body)
+ ;; Set up recursive environment before visiting cont bodies.
+ (for-each (lambda (cont k)
+ (declare-block! k cont exp-k))
+ cont k)
+ (for-each visit cont k)
+ (recur body))
+
+ (($ $kargs names syms body)
+ (for-each def! names syms)
+ (recur body))
+
+ (($ $kif kt kf)
+ (use-k! kt)
+ (use-k! kf))
+
+ (($ $ktrunc arity k)
+ (use-k! k))
+
+ (($ $letrec names syms funs body)
+ (unless global?
+ (error "$letrec should not be present when building a local DFG"))
+ (for-each def! names syms)
+ (for-each (cut visit-fun <> conts blocks use-maps global?) funs)
+ (visit body exp-k))
+
+ (($ $continue k src exp)
+ (use-k! k)
+ (match exp
+ (($ $call proc args)
+ (use! proc)
+ (for-each use! args))
+
+ (($ $primcall name args)
+ (for-each use! args))
+
+ (($ $values args)
+ (for-each use! args))
+
+ (($ $prompt escape? tag handler pop)
+ (use! tag)
+ (use-k! handler)
+ ;; Any continuation in the prompt body could cause an abort to
+ ;; the handler, so in theory we could register the handler as
+ ;; a successor of any block in the prompt body. That would be
+ ;; inefficient, though, besides being a hack. Instead we take
+ ;; advantage of the fact that pop continuation post-dominates
+ ;; the prompt body, so we add a link from there to the
+ ;; handler. This creates a primcall node with multiple
+ ;; successors, which is not quite correct, but it does reflect
+ ;; control flow. It is necessary to ensure that the live
+ ;; variables in the handler are seen as live in the body.
+ (link-blocks! pop handler))
+
+ (($ $fun)
+ (when global?
+ (visit-fun exp conts blocks use-maps global?)))
+
+ (_ #f)))))
+
+ (match fun
+ (($ $fun src meta free
+ ($ $cont kentry
+ (and entry
+ ($ $kentry self ($ $cont ktail tail) clauses))))
+ (declare-block! kentry entry #f 0)
+ (add-def! #f self kentry)
+
+ (declare-block! ktail tail kentry)
+
+ (for-each
+ (match-lambda
+ (($ $cont kclause
+ (and clause ($ $kclause arity ($ $cont kbody body))))
+ (declare-block! kclause clause kentry)
+ (link-blocks! kentry kclause)
+
+ (declare-block! kbody body kclause)
+ (link-blocks! kclause kbody)
+
+ (visit body kbody)))
+ clauses))))
+
+(define* (compute-dfg fun #:key (global? #t))
+ (let* ((conts (make-hash-table))
+ (blocks (make-hash-table))
+ (use-maps (make-hash-table)))
+ (visit-fun fun conts blocks use-maps global?)
+ (make-dfg conts blocks use-maps)))
+
+(define (lookup-block k blocks)
+ (let ((res (hashq-ref blocks k)))
+ (unless res
+ (error "Unknown continuation!" k (hash-fold acons '() blocks)))
+ res))
+
+(define (lookup-scope-level k blocks)
+ (match (lookup-block k blocks)
+ (($ $block _ scope-level) scope-level)))
+
+(define (lookup-use-map sym use-maps)
+ (let ((res (hashq-ref use-maps sym)))
+ (unless res
+ (error "Unknown lexical!" sym (hash-fold acons '() use-maps)))
+ res))
+
+(define (lookup-def sym dfg)
+ (match dfg
+ (($ $dfg conts blocks use-maps)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map name sym def uses)
+ def)))))
+
+(define (lookup-uses sym dfg)
+ (match dfg
+ (($ $dfg conts blocks use-maps)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map name sym def uses)
+ uses)))))
+
+(define (lookup-block-scope k dfg)
+ (block-scope (lookup-block k (dfg-blocks dfg))))
+
+(define (lookup-predecessors k dfg)
+ (match (lookup-block k (dfg-blocks dfg))
+ (($ $block _ _ preds succs) preds)))
+
+(define (lookup-successors k dfg)
+ (match (lookup-block k (dfg-blocks dfg))
+ (($ $block _ _ preds succs) succs)))
+
+(define (find-defining-term sym dfg)
+ (match (lookup-predecessors (lookup-def sym dfg) dfg)
+ ((def-exp-k)
+ (lookup-cont def-exp-k (dfg-cont-table 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)
+ (($ $ktrunc) #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? sym val dfg)
+ (define (immediate-u8? val)
+ (and (integer? val) (exact? val) (<= 0 val 255)))
+
+ (define (find-exp term)
+ (match term
+ (($ $kargs names syms body) (find-exp body))
+ (($ $letk conts body) (find-exp body))
+ (else term)))
+ (match dfg
+ (($ $dfg conts blocks use-maps)
+ (match (lookup-use-map sym use-maps)
+ (($ $use-map _ _ def uses)
+ (or-map
+ (lambda (use)
+ (match (find-expression (lookup-cont use conts))
+ (($ $call) #f)
+ (($ $values (_ _ . _)) #f)
+ (($ $primcall 'free-ref (closure slot))
+ (not (eq? sym slot)))
+ (($ $primcall 'free-set! (closure slot value))
+ (not (eq? sym slot)))
+ (($ $primcall 'cache-current-module! (mod . _))
+ (eq? sym mod))
+ (($ $primcall 'cached-toplevel-box _)
+ #f)
+ (($ $primcall 'cached-module-box _)
+ #f)
+ (($ $primcall 'resolve (name bound?))
+ (eq? sym name))
+ (($ $primcall 'make-vector/immediate (len init))
+ (not (eq? sym len)))
+ (($ $primcall 'vector-ref/immediate (v i))
+ (not (eq? sym i)))
+ (($ $primcall 'vector-set!/immediate (v i x))
+ (not (eq? sym i)))
+ (($ $primcall 'allocate-struct/immediate (vtable nfields))
+ (not (eq? sym nfields)))
+ (($ $primcall 'struct-ref/immediate (s n))
+ (not (eq? sym n)))
+ (($ $primcall 'struct-set!/immediate (s n x))
+ (not (eq? sym n)))
+ (($ $primcall 'builtin-ref (idx))
+ #f)
+ (_ #t)))
+ uses))))))
+
+(define (continuation-scope-contains? scope-k k blocks)
+ (let ((scope-level (lookup-scope-level scope-k blocks)))
+ (let lp ((k k))
+ (or (eq? scope-k k)
+ (match (lookup-block k blocks)
+ (($ $block scope level)
+ (and (< scope-level level)
+ (lp scope))))))))
+
+(define (continuation-bound-in? k use-k dfg)
+ (match dfg
+ (($ $dfg conts blocks use-maps)
+ (match (lookup-block k blocks)
+ (($ $block def-k)
+ (continuation-scope-contains? def-k use-k blocks))))))
+
+(define (variable-free-in? var k dfg)
+ (match dfg
+ (($ $dfg conts blocks use-maps)
+ (or-map (lambda (use)
+ (continuation-scope-contains? k use blocks))
+ (match (lookup-use-map var use-maps)
+ (($ $use-map name sym def uses)
+ uses))))))
+
+;; A continuation is a control point if it has multiple predecessors, or
+;; if its single predecessor has multiple successors.
+(define (control-point? k dfg)
+ (match (lookup-predecessors k dfg)
+ ((pred)
+ (match (lookup-successors pred dfg)
+ ((_) #f)
+ (_ #t)))
+ (_ #t)))
+
+(define (lookup-bound-syms k dfg)
+ (match dfg
+ (($ $dfg conts blocks use-maps)
+ (match (lookup-cont k conts)
+ (($ $kargs names syms body)
+ syms)))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; 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
+;;; an RTL 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)
+ (let ((conts (build-local-cont-table
+ (match fun (($ $fun src meta free body) body)))))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $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 elide-values funs)
+ ,(visit-term body)))
+ (($ $continue k src ($ $primcall 'values vals))
+ ,(rewrite-cps-term (lookup-cont k conts)
+ (($ $ktail)
+ ($continue k src ($values vals)))
+ (($ $ktrunc ($ $arity req () rest () #f) kargs)
+ ,(if (or rest (< (length vals) (length req)))
+ term
+ (let ((vals (list-head vals (length req))))
+ (build-cps-term
+ ($continue kargs src ($values vals))))))
+ (($ $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 ,(elide-values fun)))
+ (($ $continue)
+ ,term)))
+
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body))))))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; 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 rtl)
+ #:export (prim-rtl-instruction
+ branching-primitive?
+ prim-arity
+ ))
+
+(define *rtl-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-native-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-native-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-f32-native-ref . bv-f32-ref)
+ (bytevector-f64-native-ref . bv-f64-ref)
+ (bytevector-u8-native-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-native-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-f32-native-set! . bv-f32-set!)
+ (bytevector-f64-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))
+ (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))))
+
+(define (compute-prim-rtl-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)))
+ *rtl-instruction-aliases*)
+ (for-each
+ (match-lambda ((inst . arity) (hashq-set! table inst inst)))
+ *macro-instruction-arities*)
+ table))
+
+(define *prim-rtl-instructions* (delay (compute-prim-rtl-instructions)))
+
+;; prim -> rtl-instruction | #f
+(define (prim-rtl-instruction name)
+ (hashq-ref (force *prim-rtl-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-rtl-instruction name) => rtl-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 Free Software Foundation, 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 rtl)
+ #:export (reify-primitives))
+
+(define (module-box src module name public? bound? val-proc)
+ (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox 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-module name)
+ (case name
+ ((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 @slot-ref @slot-set!) '(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-gensyms (idx-sym)
+ (build-cps-term
+ ($letconst (('idx idx-sym idx))
+ ($continue k src
+ ($primcall 'builtin-ref (idx-sym)))))))
+
+(define (reify-clause ktail)
+ (let-gensyms (kclause kbody wna false str eol kthrow 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))))))))))
+
+;; FIXME: Operate on one function at a time, for efficiency.
+(define (reify-primitives fun)
+ (let ((conts (build-cont-table fun)))
+ (define (visit-fun term)
+ (rewrite-cps-exp term
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body)))))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body))))
+ (($ $cont sym ($ $kentry self (and tail ($ $cont ktail)) ()))
+ ;; A case-lambda with no clauses. Reify a clause.
+ (sym ($kentry self ,tail (,(reify-clause ktail)))))
+ (($ $cont sym ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $cont)
+ ,cont)))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont conts) ,(visit-term body)))
+ (($ $continue k src exp)
+ ,(match exp
+ (($ $prim name)
+ (match (lookup-cont k conts)
+ (($ $kargs (_))
+ (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))))))
+ (($ $fun)
+ (build-cps-term ($continue k src ,(visit-fun exp))))
+ (($ $primcall 'call-thunk/no-inline (proc))
+ (build-cps-term
+ ($continue k src ($call proc ()))))
+ (($ $primcall name args)
+ (cond
+ ((or (prim-rtl-instruction name) (branching-primitive? name))
+ ;; Assume arities are correct.
+ term)
+ (else
+ (let-gensyms (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)))))
+
+ (visit-fun fun)))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; 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)
+ #:export (allocate-slots
+ lookup-slot
+ lookup-maybe-slot
+ lookup-constant-value
+ lookup-maybe-constant-value
+ lookup-nlocals
+ lookup-call-proc-slot
+ lookup-parallel-moves))
+
+(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 two pieces of information: the call's
+ ;; /proc slot/, and a set of /parallel moves/. 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".
+ ;;
+ ;; $ktrunc 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 and a call slot. Multiple-valued
+ ;; returns will have an associated $ktrunc continuation, which records
+ ;; the same proc slot, but has return moves.
+ ;;
+ ;; $prompt handlers are $ktrunc continuations like any other.
+ ;;
+ ;; $values expressions with more than 1 value record moves but have no
+ ;; proc slot.
+ ;;
+ ;; 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.
+ ;;
+ (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)
+ call-allocation?
+ (proc-slot call-allocation-proc-slot)
+ (moves call-allocation-moves))
+
+(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-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? def-k v-idx dfa)
+ (let ((l (dfa-k-idx dfa def-k)))
+ (not (bitvector-ref (dfa-k-in dfa l) v-idx))))
+
+(define (dead-after-use? use-k v-idx dfa)
+ (let ((l (dfa-k-idx dfa use-k)))
+ (not (bitvector-ref (dfa-k-out dfa l) v-idx))))
+
+(define (allocate-slots fun dfg)
+ (let* ((dfa (compute-live-variables fun dfg))
+ (cfa (analyze-control-flow fun dfg))
+ (usev (make-vector (cfa-k-count cfa) '()))
+ (defv (make-vector (cfa-k-count cfa) '()))
+ (contv (make-vector (cfa-k-count cfa) #f))
+ (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 (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)
+ (if (and hint (not (logbit? hint live-slots)))
+ hint
+ (find-first-zero live-slots)))
+
+ (define (compute-call-proc-slot live-slots)
+ (+ 2 (find-first-trailing-zero live-slots)))
+
+ (define (compute-prompt-handler-proc-slot live-slots)
+ (1- (find-first-trailing-zero live-slots)))
+
+ (define (recompute-live-slots k nargs)
+ (let ((in (dfa-k-in dfa (dfa-k-idx dfa k))))
+ (let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs)))))
+ (let ((v (bit-position #t 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)
+ ((and (not hint) (bitvector-ref needs-hintv var-idx)) live)
+ ((vector-ref slots var-idx) => (cut add-live-slot <> 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.
+ (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))))))))
+
+ ;; Transform the DFG's continuation table to a vector, for easy
+ ;; access.
+ (define (compute-conts!)
+ (let ((cont-table (dfg-cont-table dfg)))
+ (let lp ((n 0))
+ (when (< n (vector-length contv))
+ (vector-set! contv n (lookup-cont (cfa-k-sym cfa n) cont-table))
+ (lp (1+ n))))))
+
+ ;; Record uses and defs, as lists of variable indexes, indexed by
+ ;; CFA continuation index.
+ (define (compute-uses-and-defs!)
+ (let lp ((n 0))
+ (when (< n (vector-length usev))
+ (match (vector-ref contv n)
+ (($ $kentry 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))
+ (($ $primcall name args)
+ args)
+ (($ $values args)
+ args)
+ (($ $prompt escape? tag handler pop)
+ (list tag))
+ (_ '())))))
+ (_ #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!)
+ ;; We traverse the graph using reverse-post-order on a forward
+ ;; control-flow graph, but we did the live variable analysis in
+ ;; the opposite direction -- so the continuation numbers don't
+ ;; correspond. This helper adapts them.
+ (define (cfa-k-idx->dfa-k-idx n)
+ (dfa-k-idx dfa (cfa-k-sym cfa n)))
+
+ (define (live-before n)
+ (dfa-k-in dfa (cfa-k-idx->dfa-k-idx n)))
+ (define (live-after n)
+ (dfa-k-out dfa (cfa-k-idx->dfa-k-idx n)))
+
+ ;; 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 (vector-ref contv n)
+ (($ $kargs names syms body)
+ (match (find-expression body)
+ (($ $call)
+ (let ((args (make-bitvector (bitvector-length needs-slotv) #f)))
+ (bit-set*! args (live-before n) #t)
+ (bit-set*! args (live-after n) #f)
+ (bit-set*! args no-slot-needed #f)
+ (if (bit-position #t args 0)
+ (scan-for-hints (1- n) args)
+ (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 (vector-ref contv n)
+ (($ $kargs names syms body)
+ (match (cfa-predecessors cfa (1+ n))
+ (((? (cut eqv? <> 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) ($ $fun)
+ ($ $primcall) ($ $prompt))
+ (let ((dead (make-bitvector (bitvector-length args) #f)))
+ (bit-set*! dead (live-before n) #t)
+ (bit-set*! dead (live-after n) #f)
+ (bit-set*! dead no-slot-needed #f)
+ (if (bit-position #t dead 0)
+ (finish-hints n (live-before n) args)
+ (scan-for-hints (1- n) args))))
+ ((or ($ $call) ($ $values))
+ (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)
+ (bit-invert! args)
+ (bit-set*! args kill #t)
+ (bit-invert! args)
+ (bit-set*! needs-hintv args #t)
+ (scan-for-call n))
+
+ (define no-slot-needed
+ (make-bitvector (bitvector-length needs-slotv) #f))
+
+ (bit-set*! no-slot-needed needs-slotv #t)
+ (bit-invert! no-slot-needed)
+ (scan-for-call (1- (vector-length contv))))
+
+ (define (allocate-call label k uses pre-live post-live)
+ (match (vector-ref contv (cfa-k-idx cfa k))
+ (($ $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))))
+ (($ $ktrunc 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 (cfa-k-idx cfa kargs)))
+ (value-slots (map (cut + proc-slot 1 <>)
+ (iota (length result-vars))))
+ (result-live (fold allocate!
+ post-live result-vars value-slots))
+ (result-slots (map (cut vector-ref slots <>) result-vars))
+ (result-moves (parallel-move value-slots
+ result-slots
+ (compute-tmp-slot result-live
+ value-slots))))
+ (bump-nlocals! (+ proc-slot (length uses)))
+ (hashq-set! call-allocations label
+ (make-call-allocation proc-slot arg-moves))
+ (hashq-set! call-allocations k
+ (make-call-allocation proc-slot result-moves))))
+
+ (_
+ (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))))))
+
+ (define (allocate-values label k uses pre-live post-live)
+ (let* ((src-slots (map (cut vector-ref slots <>) uses))
+ (dst-slots (match (vector-ref contv (cfa-k-idx cfa k))
+ (($ $ktail)
+ (let ((tail-nlocals (1+ (length uses))))
+ (bump-nlocals! tail-nlocals)
+ (cdr (iota tail-nlocals))))
+ (_
+ (let ((dst-vars (vector-ref defv (cfa-k-idx cfa k))))
+ (fold allocate! post-live dst-vars src-slots)
+ (map (cut vector-ref slots <>) dst-vars)))))
+ (moves (parallel-move src-slots
+ dst-slots
+ (compute-tmp-slot pre-live dst-slots))))
+ (hashq-set! call-allocations label
+ (make-call-allocation #f moves))))
+
+ (define (allocate-prompt label k handler nargs)
+ (match (vector-ref contv (cfa-k-idx cfa handler))
+ (($ $ktrunc arity kargs)
+ (let* ((handler-live (recompute-live-slots handler nargs))
+ (proc-slot (compute-prompt-handler-proc-slot handler-live))
+ (result-vars (vector-ref defv (cfa-k-idx cfa 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))
+ (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))))))
+
+ (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 live))
+ (define (kill-dead live vars-by-cfa-idx pred)
+ (fold (lambda (v live)
+ (let ((slot (vector-ref slots v)))
+ (if (and slot
+ (> slot nargs)
+ (pred (cfa-k-sym cfa n) v dfa))
+ (kill-dead-slot slot live)
+ live)))
+ live
+ (vector-ref vars-by-cfa-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 (cfa-k-count cfa))
+ n
+ (let* ((label (cfa-k-sym cfa 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 (vector-ref contv n)
+ (($ $kclause) n)
+ (($ $kargs names syms body)
+ (let ((uses (vector-ref usev n)))
+ (match (find-call body)
+ (($ $continue k src ($ $call))
+ (allocate-call label k uses live post-live))
+ (($ $continue k src ($ $primcall)) #t)
+ ;; We only need to make a call allocation if there
+ ;; are two or more values.
+ (($ $continue k src ($ $values (_ _ . _)))
+ (allocate-values label k uses live post-live))
+ (($ $continue k src ($ $values)) #t)
+ (($ $continue k src ($ $prompt escape? tag handler pop))
+ (allocate-prompt label k handler nargs))
+ (_ #f)))
+ (lp (1+ n) post-live))
+ ((or ($ $ktrunc) ($ $kif) ($ $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 (vector-ref contv n)
+ (($ $kclause arity ($ $cont kbody ($ $kargs names)))
+ (unless (eq? (cfa-k-sym cfa (1+ n)) kbody)
+ (error "Unexpected CFA 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 (cfa-k-sym cfa n) nlocals)
+ (when (< next (cfa-k-count cfa))
+ (visit-clauses next live))))))
+ (match (vector-ref contv 0)
+ (($ $kentry self)
+ (visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
+
+ (compute-conts!)
+ (compute-constants!)
+ (compute-uses-and-defs!)
+ (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-rtl)
+ #: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?
- #:compilers `((bytecode . ,compile-bytecode))
- #:decompilers `((bytecode . ,decompile-bytecode))
+ #:printer write-cps
+ #:parser parse-cps
+ #:compilers `((rtl . ,compile-rtl))
#:for-humans? #f
)
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; Commentary:
+;;;
+;;; Some RTL 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)))
+ (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 ($ $kentry self tail clauses))
+ (sym ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym ($ $kclause arity body))
+ (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $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 an RTL op from a primcall without an RTL 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-gensyms (k* val kvoid)
+ (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-gensyms (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)
+ ;; Unhappily, and undocumentedly, struct-set! returns the value
+ ;; that was set. There is code that relies on this. Hackety
+ ;; hack...
+ (let-gensyms (k*)
+ (build-cps-term
+ ($letk ((k* ($kargs () ()
+ ($continue k src ($primcall 'values (x))))))
+ ($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 src meta free body)
+ ($fun src meta free ,(visit-cont body)))))
+
+ (visit-fun fun)))
--- /dev/null
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+
+;;; 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-gensyms (make-hash-table))
+
+ (define (add sym env)
+ (if (hashq-ref seen-gensyms sym)
+ (error "duplicate gensym" sym)
+ (begin
+ (hashq-set! seen-gensyms sym #t)
+ (cons sym env))))
+
+ (define (add-env new env)
+ (if (null? new)
+ env
+ (add-env (cdr new) (add (car new) env))))
+
+ (define (check-var sym env)
+ (cond
+ ((not (hashq-ref seen-gensyms sym))
+ (error "unbound lexical" sym))
+ ((not (memq sym env))
+ (error "displaced lexical" sym))))
+
+ (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
+ (($ $kif kt kf)
+ (check-var kt k-env)
+ (check-var kf k-env))
+ (($ $ktrunc ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k)
+ (check-var k k-env))
+ (($ $kargs ((? symbol? name) ...) ((? symbol? sym) ...) body)
+ (unless (= (length name) (length sym))
+ (error "name and sym lengths don't match" name sym))
+ (visit-term body k-env (add-env sym v-env)))
+ (_
+ ;; $kclause, $kentry, 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) (? symbol? kwsym)) ...)
+ (or #f #t))
+ ($ $cont kbody (and body ($ $kargs names syms _)))))
+ (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-env (list kclause kbody) k-env)))
+ (visit-cont-body body k-env v-env)))
+ (_
+ (error "unexpected clause" clause))))
+
+ (define (visit-fun fun k-env v-env)
+ (match fun
+ (($ $fun src meta ((? symbol? free) ...)
+ ($ $cont kbody
+ ($ $kentry (? symbol? self) ($ $cont ktail ($ $ktail)) clauses)))
+ (when (and meta (not (and (list? meta) (and-map pair? meta))))
+ (error "meta should be alist" meta))
+ (for-each (cut check-var <> v-env) free)
+ (check-src src)
+ ;; Reset the continuation environment, because Guile's
+ ;; continuations are local.
+ (let ((v-env (add-env (list self) v-env))
+ (k-env (add-env (list ktail) '())))
+ (for-each (cut visit-clause <> k-env v-env) clauses)))
+ (_
+ (error "unexpected $fun" fun))))
+
+ (define (visit-expression exp k-env v-env)
+ (match exp
+ (($ $void)
+ #t)
+ (($ $const val)
+ #t)
+ (($ $prim (? symbol? name))
+ #t)
+ (($ $fun)
+ (visit-fun exp k-env v-env))
+ (($ $call (? symbol? proc) ((? symbol? arg) ...))
+ (check-var proc v-env)
+ (for-each (cut check-var <> v-env) arg))
+ (($ $primcall (? symbol? name) ((? symbol? arg) ...))
+ (for-each (cut check-var <> v-env) arg))
+ (($ $values ((? symbol? arg) ...))
+ (for-each (cut check-var <> v-env) arg))
+ (($ $prompt escape? tag handler pop)
+ (unless (boolean? escape?) (error "escape? should be boolean" escape?))
+ (check-var tag v-env)
+ (check-var handler k-env)
+ (check-var pop k-env))
+ (_
+ (error "unexpected expression" exp))))
+
+ (define (visit-term term k-env v-env)
+ (match term
+ (($ $letk (($ $cont (? symbol? k) cont) ...) body)
+ (let ((k-env (add-env k k-env)))
+ (for-each (cut visit-cont-body <> k-env v-env) cont)
+ (visit-term body k-env v-env)))
+
+ (($ $letrec ((? symbol? name) ...) ((? symbol? sym) ...) (fun ...) body)
+ (unless (= (length name) (length sym) (length fun))
+ (error "letrec syms, names, and funs not same length" term))
+ (let ((v-env (add-env 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-var k k-env)
+ (check-src src)
+ (visit-expression exp k-env v-env))
+
+ (_
+ (error "unexpected term" term))))
+
+ (visit-fun 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
- )
--- /dev/null
+;;; Register Transfer Language (RTL)
+
+;; 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 rtl)
+ #:use-module (ice-9 match)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:export (instruction-list
+ rtl-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-rtl-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-rtl-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-rtl-instruction-arity name args))))
+ ((name op '<- . args)
+ (hashq-set! table name
+ (cons 1 (1- (compute-rtl-instruction-arity name args))))))
+ (instruction-list))
+ (for-each (match-lambda
+ ((name . arity)
+ (hashq-set! table name arity)))
+ *macro-instruction-arities*)
+ table))
+
+(define *rtl-instruction-arities* (delay (compute-rtl-instruction-arities)))
+
+(define (rtl-instruction-arity name)
+ (hashq-ref (force *rtl-instruction-arities*) name))
-;;; Guile Lowlevel Intermediate Language
+;;; Register Transfer Language (RTL)
-;; 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 rtl 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 (rtl))
-(define (write-glil exp . port)
- (apply write (unparse-glil exp) port))
+(define (rtl->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 rtl
+ #:title "Register Transfer Language"
+ #:compilers `((value . ,rtl->value))
+ #:printer (lambda (rtl port) (put-bytevector port rtl))
+ #:reader get-bytevector-all
+ #: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)
(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)))
- ((if ,test ,consequent ,alternate)
+ (('primcall name . args)
+ (make-primcall loc name (map retrans args)))
+
+ (('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)
+(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.
+
+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)
(let lp ((x x))
- (record-case x
- ((<application> proc args)
- (set! (application-proc x) (lp proc))
- (set! (application-args x) (map lp args)))
+ (post
+ (match (pre x)
+ (($ <void> src)
+ (make-void src))
- ((<conditional> test consequent alternate)
- (set! (conditional-test x) (lp test))
- (set! (conditional-consequent x) (lp consequent))
- (set! (conditional-alternate x) (lp alternate)))
+ (($ <const> src exp)
+ (make-const src exp))
- ((<lexical-set> name gensym exp)
- (set! (lexical-set-exp x) (lp exp)))
+ (($ <primitive-ref> src name)
+ (make-primitive-ref src name))
- ((<module-set> mod name public? exp)
- (set! (module-set-exp x) (lp exp)))
+ (($ <lexical-ref> src name gensym)
+ (make-lexical-ref src name gensym))
- ((<toplevel-set> name exp)
- (set! (toplevel-set-exp x) (lp exp)))
+ (($ <lexical-set> src name gensym exp)
+ (make-lexical-set src name gensym (lp exp)))
- ((<toplevel-define> name exp)
- (set! (toplevel-define-exp x) (lp exp)))
+ (($ <module-ref> src mod name public?)
+ (make-module-ref src mod name public?))
- ((<lambda> body)
- (if body
- (set! (lambda-body x) (lp body))))
+ (($ <module-set> src mod name public? exp)
+ (make-module-set src mod name public? (lp exp)))
- ((<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))))
+ (($ <toplevel-ref> src name)
+ (make-toplevel-ref src name))
- ((<sequence> exps)
- (set! (sequence-exps x) (map lp exps)))
+ (($ <toplevel-set> src name exp)
+ (make-toplevel-set src name (lp exp)))
- ((<let> gensyms vals body)
- (set! (let-vals x) (map lp vals))
- (set! (let-body x) (lp body)))
+ (($ <toplevel-define> src name exp)
+ (make-toplevel-define src name (lp exp)))
- ((<letrec> gensyms vals body)
- (set! (letrec-vals x) (map lp vals))
- (set! (letrec-body x) (lp body)))
+ (($ <conditional> src test consequent alternate)
+ (make-conditional src (lp test) (lp consequent) (lp alternate)))
- ((<fix> gensyms vals body)
- (set! (fix-vals x) (map lp vals))
- (set! (fix-body x) (lp body)))
+ (($ <call> src proc args)
+ (make-call src (lp proc) (map lp args)))
- ((<let-values> exp body)
- (set! (let-values-exp x) (lp exp))
- (set! (let-values-body x) (lp body)))
+ (($ <primcall> src name args)
+ (make-primcall src name (map lp args)))
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
- (set! (dynwind-winder x) (lp winder))
- (set! (dynwind-unwinder x) (lp unwinder)))
+ (($ <seq> src head tail)
+ (make-seq src (lp head) (lp tail)))
+
+ (($ <lambda> src meta body)
+ (make-lambda src meta (and body (lp body))))
- ((<dynlet> fluids vals body)
- (set! (dynlet-fluids x) (map lp fluids))
- (set! (dynlet-vals x) (map lp vals))
- (set! (dynlet-body x) (lp body)))
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (make-lambda-case src req opt rest kw (map lp inits) gensyms (lp body)
+ (and alternate (lp alternate))))
- ((<dynref> fluid)
- (set! (dynref-fluid x) (lp fluid)))
+ (($ <let> src names gensyms vals body)
+ (make-let src names gensyms (map lp vals) (lp body)))
- ((<dynset> fluid exp)
- (set! (dynset-fluid x) (lp fluid))
- (set! (dynset-exp x) (lp exp)))
+ (($ <letrec> src in-order? names gensyms vals body)
+ (make-letrec src in-order? names gensyms (map lp vals) (lp body)))
- ((<prompt> tag body handler)
- (set! (prompt-tag x) (lp tag))
- (set! (prompt-body x) (lp body))
- (set! (prompt-handler x) (lp handler)))
+ (($ <fix> src names gensyms vals body)
+ (make-fix src names gensyms (map lp vals) (lp body)))
- ((<abort> tag args tail)
- (set! (abort-tag x) (lp tag))
- (set! (abort-args x) (map lp args))
- (set! (abort-tail x) (lp tail)))
+ (($ <let-values> src exp body)
+ (make-let-values src (lp exp) (lp body)))
- (else #f))
+ (($ <prompt> src escape-only? tag body handler)
+ (make-prompt src escape-only? (lp tag) (lp body) (lp handler)))
- (or (f x) x)))
+ (($ <abort> src tag args tail)
+ (make-abort src (lp tag) (map lp args) (lp tail)))))))
-(define (pre-order! f x)
- (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)))
+(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 Free Software Foundation, Inc.
+;; 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
(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 Free Software Foundation, 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) #:hide (let-gensyms))
+ #: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 (toplevel-box src name bound? val-proc)
+ (let-gensyms (name-sym bound?-sym kbox 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
+ (let-gensyms (scope-sym)
+ (build-cps-term
+ ($letconst (('scope scope-sym scope))
+ ($continue kbox src
+ ($primcall 'cached-toplevel-box
+ (scope-sym name-sym bound?-sym)))))))))))))
+
+(define (module-box src module name public? bound? val-proc)
+ (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox 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 k)
+ (let-gensyms (module scope-sym kmodule)
+ (build-cps-term
+ ($letconst (('scope scope-sym scope))
+ ($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)
+ (unless (eq? var (car gensyms))
+ (error "unexpected keyword arg order"))
+ (proc name var (car inits)
+ (fold-kw kw (cdr gensyms) (cdr inits) seed)))))
+ (fold-req req gensyms seed)))))
+
+(define (unbound? src sym kt kf)
+ (define tc8-iflag 4)
+ (define unbound-val 9)
+ (define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
+ (let-gensyms (unbound ktest)
+ (build-cps-term
+ ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
+ ($letk ((ktest ($kif kt kf)))
+ ($continue ktest src
+ ($primcall 'eq? (sym unbound))))))))
+
+(define (init-default-value name sym subst init body)
+ (match (assq-ref subst sym)
+ ((subst-sym box?)
+ (let ((src (tree-il-src init)))
+ (define (maybe-box k make-body)
+ (if box?
+ (let-gensyms (kbox phi)
+ (build-cps-term
+ ($letk ((kbox ($kargs (name) (phi)
+ ($continue k src ($primcall 'box (phi))))))
+ ,(make-body kbox))))
+ (make-body k)))
+ (let-gensyms (knext kbound kunbound)
+ (build-cps-term
+ ($letk ((knext ($kargs (name) (subst-sym) ,body)))
+ ,(maybe-box
+ knext
+ (lambda (k)
+ (build-cps-term
+ ($letk ((kbound ($kargs () () ($continue k src
+ ($values (sym)))))
+ (kunbound ($kargs () () ,(convert init k subst))))
+ ,(unbound? src sym 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 (assq-ref subst sym)
+ ((box #t)
+ (let-gensyms (kunboxed unboxed)
+ (build-cps-term
+ ($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
+ ($continue kunboxed src ($primcall 'box-ref (box)))))))
+ ((subst #f) (k subst))
+ (#f (k sym))))
+ (else
+ (let-gensyms (karg arg)
+ (build-cps-term
+ ($letk ((karg ($kargs ('arg) (arg) ,(k arg))))
+ ,(convert exp karg 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 (assq-ref subst sym)
+ ((box #t)
+ (let-gensyms (k)
+ (build-cps-term
+ ($letk ((k ($kargs (name) (box) ,body)))
+ ($continue k #f ($primcall 'box (sym)))))))
+ (else body)))
+
+ (match exp
+ (($ <lexical-ref> src name sym)
+ (match (assq-ref subst sym)
+ ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
+ ((subst #f) (build-cps-term ($continue k src ($values (subst)))))
+ (#f (build-cps-term ($continue k src ($values (sym)))))))
+
+ (($ <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 '())
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (let* ((arity (make-$arity req (or opt '()) rest
+ (if kw (cdr kw) '()) (and kw (car kw))))
+ (names (fold-formals (lambda (name sym init names)
+ (cons name names))
+ '()
+ arity gensyms inits)))
+ (cons
+ (let-gensyms (kclause kargs)
+ (build-cps-cont
+ (kclause
+ ($kclause ,arity
+ (kargs
+ ($kargs names gensyms
+ ,(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-gensyms (kentry self ktail)
+ (build-cps-term
+ ($continue k fun-src
+ ($fun fun-src meta '()
+ (kentry ($kentry self (ktail ($ktail))
+ ,(convert-clauses body ktail)))))))
+ (let-gensyms (scope kscope)
+ (build-cps-term
+ ($letk ((kscope ($kargs () ()
+ ,(parameterize ((current-topbox-scope scope))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope fun-src scope 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-gensyms (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 (make-conditional src exp (make-const #f #t)
+ (make-const #f #f))
+ k subst))
+ ((and (eq? name 'vector)
+ (and-map (match-lambda
+ ((or ($ <const>)
+ ($ <void>)
+ ($ <lambda>)
+ ($ <lexical-ref>)) #t)
+ (_ #f))
+ args))
+ ;; 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.
+ (convert (let ((len (length args)))
+ (let-gensyms (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))))))
+ k subst))
+ ((and (eq? name 'list)
+ (and-map (match-lambda
+ ((or ($ <const>)
+ ($ <void>)
+ ($ <lambda>)
+ ($ <lexical-ref>)) #t)
+ (_ #f))
+ args))
+ ;; The same situation occurs with "list".
+ (let lp ((args args) (k k))
+ (match args
+ (()
+ (build-cps-term
+ ($continue k src ($const '()))))
+ ((arg . args)
+ (let-gensyms (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) '()))))
+ (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
+ (build-cps-term
+ ;; FIXME: Attach hsrc to $ktrunc.
+ ($letk* ((khbody ($kargs hnames hsyms
+ ,(fold box-bound-var
+ (convert hbody k subst)
+ hnames hsyms)))
+ (khargs ($ktrunc 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 ($ktrunc '() 'rest kpop)))
+ ,(if escape-only?
+ (build-cps-term
+ ($letk ((kbody ($kargs () ()
+ ,(convert body krest subst))))
+ ($continue kbody src ($prompt #t tag khargs kpop))))
+ (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 kpop))))))))))))))
+
+ ;; Eta-convert prompts without inline handlers.
+ (($ <prompt> src escape-only? tag body handler)
+ (let-gensyms (h args)
+ (convert
+ (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)))))
+ k
+ subst)))
+
+ (($ <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-gensyms (kif kt kf)
+ (build-cps-term
+ ($letk* ((kt ($kargs () () ,(convert consequent k subst)))
+ (kf ($kargs () () ,(convert alternate k subst)))
+ (kif ($kif kt kf)))
+ ,(match test
+ (($ <primcall> src (? branching-primitive? name) args)
+ (convert-args args
+ (lambda (args)
+ (build-cps-term
+ ($continue kif src ($primcall name args))))))
+ (_ (convert-arg test
+ (lambda (test)
+ (build-cps-term
+ ($continue kif src ($values (test))))))))))))
+
+ (($ <lexical-set> src name gensym exp)
+ (convert-arg exp
+ (lambda (exp)
+ (match (assq-ref subst gensym)
+ ((box #t)
+ (build-cps-term
+ ($continue k src ($primcall 'box-set! (box exp)))))))))
+
+ (($ <seq> src head tail)
+ (let-gensyms (ktrunc kseq)
+ (build-cps-term
+ ($letk* ((kseq ($kargs () ()
+ ,(convert tail k subst)))
+ (ktrunc ($ktrunc '() #f kseq)))
+ ,(convert head ktrunc 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-gensyms (klet)
+ (build-cps-term
+ ($letk ((klet ($kargs (name) (sym)
+ ,(box-bound-var name sym
+ (lp names syms vals)))))
+ ,(convert val klet subst))))))))
+
+ (($ <fix> src names gensyms funs body)
+ ;; Some letrecs can be contified; that happens later.
+ (if (current-topbox-scope)
+ (let-gensyms (self)
+ (build-cps-term
+ ($letrec names
+ gensyms
+ (map (lambda (fun)
+ (match (convert fun k subst)
+ (($ $continue _ _ (and fun ($ $fun)))
+ fun)))
+ funs)
+ ,(convert body k subst))))
+ (let-gensyms (scope kscope)
+ (build-cps-term
+ ($letk ((kscope ($kargs () ()
+ ,(parameterize ((current-topbox-scope scope))
+ (convert exp k subst)))))
+ ,(capture-toplevel-scope src scope kscope))))))
+
+ (($ <let-values> src exp
+ ($ <lambda-case> lsrc req #f rest #f () syms body #f))
+ (let ((names (append req (if rest (list rest) '()))))
+ (let-gensyms (ktrunc kargs)
+ (build-cps-term
+ ($letk* ((kargs ($kargs names syms
+ ,(fold box-bound-var
+ (convert body k subst)
+ names syms)))
+ (ktrunc ($ktrunc req rest kargs)))
+ ,(convert exp ktrunc subst))))))))
+
+(define (build-subst exp)
+ "Compute a mapping from lexical gensyms to substituted gensyms. The
+usual reason to replace one variable by another is assignment
+conversion. Default argument values is the other reason.
+
+Returns a list of (ORIG-SYM SUBST-SYM BOXED?). A true value for BOXED?
+indicates that the replacement variable is in a box."
+ (define (box-set-vars exp subst)
+ (match exp
+ (($ <lexical-set> src name sym exp)
+ (if (assq sym subst)
+ subst
+ (cons (list sym (gensym "b") #t) subst)))
+ (_ subst)))
+ (define (default-args exp subst)
+ (match exp
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (fold-formals (lambda (name sym init subst)
+ (if init
+ (let ((box? (match (assq-ref subst sym)
+ ((box #t) #t)
+ (#f #f)))
+ (subst-sym (gensym (symbol->string name))))
+ (cons (list sym subst-sym box?) subst))
+ subst))
+ subst
+ (make-$arity req (or opt '()) rest
+ (if kw (cdr kw) '()) (and kw (car kw)))
+ gensyms
+ inits))
+ (_ subst)))
+ (tree-il-fold box-set-vars default-args '() exp))
+
+(define (cps-convert/thunk exp)
+ (let ((src (tree-il-src exp)))
+ (let-gensyms (kinit init ktail kclause kbody)
+ (build-cps-exp
+ ($fun src '() '()
+ (kinit ($kentry init
+ (ktail ($ktail))
+ ((kclause
+ ($kclause ('() '() #f '() #f)
+ (kbody ($kargs () ()
+ ,(convert exp ktail
+ (build-subst exp))))))))))))))
+
+(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 (compile-cps exp env opts)
+ (values (cps-convert/thunk (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 Free Software Foundation, 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)
- ((@slot-ref . 2) . slot-ref)
- ((@slot-set! . 3) . slot-set)
- ((vector-ref . 2) . vector-ref)
- ((vector-set! . 3) . vector-set)
- ((variable-ref . 1) . variable-ref)
- ;; nb, *not* variable-set! -- the args are switched
- ((variable-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)))))))
;;
(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)
(define (boolean-valued-expression? x ctx)
(match x
- (($ <application> _
- ($ <primitive-ref> _ (? boolean-valued-primitive?))) #t)
+ (($ <primcall> _ (? boolean-valued-primitive?)) #t)
(($ <const> _ (? boolean?)) #t)
(_ (eq? ctx 'test))))
(($ <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)
(_ (eq? ctx 'value))))
(make-const src #f))
(($ <conditional> src test consequent alternate)
(make-conditional src test (negate consequent ctx) (negate alternate ctx)))
- (($ <application> _ ($ <primitive-ref> _ 'not)
+ (($ <primcall> _ '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))
+ (($ <primcall> src (and pred (? negate-primitive)) args)
+ (make-primcall src (negate-primitive pred) args))
(_
- (make-application #f (make-primitive-ref #f 'not) (list exp)))))
+ (make-primcall #f 'not (list exp)))))
(define (hasher n)
exp
(make-const src (not (not val)))))
;; For (not FOO), try to prove FOO, then negate the result.
- (($ <application> src ($ <primitive-ref> _ 'not) (exp*))
+ (($ <primcall> src 'not (exp*))
(match (find-dominating-test exp* effects db)
(($ <const> _ val)
(log 'inferring exp (not val))
((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>)
;; (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)))
+ (visit (make-seq #f test (make-const #f a))
db env ctx))
;; (if FOO #t #f) => FOO for boolean-valued FOO.
(($ <conditional> src
(c
(return c (intersection (concat db++ db+) (concat db-- db-)))))))
- (($ <application> src proc args)
+ (($ <primcall> src primitive args)
+ (let*-values (((args db*) (parallel-visit args db env 'value)))
+ (return (make-primcall src primitive args) db*)))
+ (($ <call> 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)
+ (return (make-call src proc args)
(concat db** db*))))
(($ <lambda> src meta body)
(let*-values (((body _) (if body
(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)
+ (($ <seq> src head tail)
+ (let*-values (((head db*) (visit head db env 'effect)))
+ (cond
+ ((void? head)
+ (visit tail db env ctx))
+ (else
+ (let*-values (((tail db**) (visit tail (concat db* db) env ctx)))
+ (values (make-seq src head tail)
+ (concat db** db*)))))))
+ (($ <prompt> src escape-only? 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)
+ ((body _) (visit body (concat db* db) env
+ (if escape-only? ctx 'value)))
+ ((handler _) (visit handler (concat db* db) env 'value)))
+ (return (make-prompt src escape-only? tag body handler)
db*)))
(($ <abort> src tag args tail)
(let*-values (((tag db*) (visit tag db env 'value))
(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 Free Software 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 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.
;; Disable CSE.
(lambda (x) x))
(_ cse))))
- (fix-letrec!
+ (fix-letrec
(verify-tree-il
(cse
(verify-tree-il
- (peval (expand-primitives! (resolve-primitives! x 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)))
+ ((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)))
+
+ (((? 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)
- (make-let src
- (append req
- (or opt '())
- (if rest (list rest) '()))
- gensyms
- (if (> nargs (+ nreq nopt))
- (append (list-head orig-args (+ nreq nopt))
- (list
- (make-application
- #f
- (make-primitive-ref #f 'list)
- (drop orig-args (+ nreq nopt)))))
- (append orig-args
- (drop inits (- nargs nreq))
- (if rest
- (list (make-const #f '()))
- '())))
- body))
+ (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 required argument values are in the scope
+ ;; of the optional argument initializers.
+ (make-let src
+ (append req rest)
+ (append (list-head gensyms nreq)
+ (last-pair gensyms))
+ (append req-vals rest-vals)
+ (make-let src
+ opt
+ (list-head (drop gensyms nreq) nopt)
+ opt-vals
+ body)))))
(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))
;; A recursive call, or a lambda in the operator
(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 Free Software 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
+ '(apply
+ call-with-values
+ call-with-current-continuation
call/cc
dynamic-wind
- @dynamic-wind
values
eq? eqv? equal?
memq memv
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor lognot
not
- pair? null? list? symbol? vector? string? struct? number? char?
+ pair? null? list? symbol? vector? string? struct? number? char? nil?
+
+ 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!
- @prompt call-with-prompt @abort abort-to-prompt
+ fluid-ref fluid-set! with-fluid*
+
+ 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-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
ash logand logior logxor lognot
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? struct? string? number? char?
+ pair? null? nil? list?
+ symbol? variable? vector? struct? string? number? char?
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
+ ;; 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?
+ 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)
(bytevector-ieee-double-native-set! vec (* i 8) x))
;; 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* 'eqv? (maybe-simplify-to-eq 'eqv?))
+(hashq-set! *primitive-expand-table* 'equal? (maybe-simplify-to-eq 'equal?))
-(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*
- '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 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011, 2013 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>
+
+ ;; 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> <keyword> <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))
(oop goops compile))
\f
+;; FIXME: deprecate.
(eval-when (eval load compile)
(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>)
;; 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 <keyword> (find-subclass <top> '<keyword>))
+(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 Free Software Foundation, Inc.
+;; Copyright 2005,2008,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 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) 'rtl))
(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 `rtl'
-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 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)
- #:renamer (symbol-prefix-proc '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-18.scm --- Multithreading support
-;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 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
(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
(display ">" p))
(define (throw-bad-struct s who)
+ #((definite-bailout? . #t))
(throw 'wrong-type-arg who
"Wrong type argument: ~S" (list s)
(list s)))
((_ 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 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2013 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>
;;;;
(+ 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 ((k (cond
+ ((program? proc) (program-code proc))
+ (else proc))))
+ (or (hashv-ref procedure-data k)
(let ((call-data (make-call-data proc 0 0 0)))
- (hashq-set! procedure-data k call-data)
+ (hashv-set! procedure-data k call-data)
call-data))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)))))
+ (set-vm-trace-level! (1- (vm-trace-level))))
(accumulate-time stop-time)))
(setitimer ITIMER_PROF
(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-vm-trace-level! (1+ (vm-trace-level))))))))
(set! inside-profiler? #f))
(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))))
+ (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.
(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))))
+ (set-vm-trace-level! (1- (vm-trace-level)))
(if %count-calls?
- (remove-hook! (vm-apply-hook (the-vm)) count-call))
+ (remove-hook! (vm-apply-hook) 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))
(if (positive? profile-level)
(error "Can't call statprof-fold-called while profiler is running."))
- (hashq-ref procedure-data proc))
+ (get-call-data proc))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stats
(cond
((eq? a b))
((and (program? a) (program? b))
- (eq? (program-objcode a) (program-objcode b)))
+ (eq? (program-code a) (program-code b)))
(else
#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))))
+ (set-vm-trace-level! (1+ (vm-trace-level)))
#t)))
(define (stop)
(define* (compile-file file #:key
(output-file #f)
(from (current-language))
- (to 'objcode)
+ (to 'rtl)
(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 'rtl)
(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))
;; 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 'rtl #: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 Free Software 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 "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 = #x~x\n" (frame-stack-pointer frame))
(print "fp = #x~x\n" (frame-address frame)))
(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!
(let* ((mod (or (program-module proc) (current-module)))
(mod* (make-module)))
(module-use! mod* mod)
;;; Error handling in the REPL
-;; Copyright (C) 2001, 2009, 2010, 2011, 2012 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
(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
;; 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)
--- /dev/null
+;;; Guile RTL assembler
+
+;;; 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
+
+;;; Commentary:
+;;;
+;;; This module implements an assembler that creates an ELF image from
+;;; RTL 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 RTL 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 rtl)
+ #: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-text
+ link-assembly))
+
+
+\f
+
+;;; RTL code consists of 32-bit units, often subdivided in some way.
+;;; These helpers create one 32-bit unit from multiple components.
+
+(define-inlinable (pack-u8-u24 x y)
+ (unless (<= 0 x 255)
+ (error "out of range" x))
+ (logior x (ash y 8)))
+
+(define-inlinable (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-inlinable (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-inlinable (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-inlinable (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-inlinable (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)))
+
+(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-syntax-rule (u32-ref buf n)
+ (bytevector-u32-native-ref buf (* n 4)))
+
+(define-syntax-rule (u32-set! buf n val)
+ (bytevector-u32-native-set! buf (* n 4) val))
+
+(define-syntax-rule (s32-ref buf n)
+ (bytevector-s32-native-ref buf (* n 4)))
+
+(define-syntax-rule (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 RTL code.
+;;;
+(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 (? 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)
+ 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!))
+
+(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.
+;;;
+;;; RTL code consists of 32-bit units. We emit RTL code 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)
+ asm?
+
+ ;; We write RTL code 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 RTL 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 RTL 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!))
+
+(define-inlinable (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-inlinable (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-inlinable (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-inlinable (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-inlinable (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 compile load eval)
+ (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))
+ ((U8_U8_I16 a b imm)
+ (emit asm (pack-u8-u8-u16 a b (object-address imm))))
+ ((U8_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 a b c)))
+ ((U8_U8_U8_U8 a b c d)
+ (emit asm (pack-u8-u8-u8-u8 a b c d)))
+ ((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_U12_U12 a b)
+ (emit asm (pack-u8-u12-u12 0 a b)))
+ ((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))
+
+(define-syntax define-assembler
+ (lambda (x)
+ (syntax-case x ()
+ ((_ name opcode kind arg ...)
+ (with-syntax ((emit (id-append #'name #'emit- #'name)))
+ #'(begin
+ (define emit
+ (let ((emit (assembler name opcode arg ...)))
+ (hashq-set! assemblers 'name emit)
+ emit))
+ (export 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)
+
+(define (emit-text asm instructions)
+ "Assemble @var{instructions} using the assembler @var{asm}.
+@var{instructions} is a sequence of RTL 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-inlinable (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)
+ `((static-patch! ,label 2
+ ,(recur (make-uniform-vector-backing-store
+ (uniform-array->bytevector obj)
+ (if (bitvector? obj)
+ ;; Bitvectors are addressed in
+ ;; 32-bit units.
+ 4
+ (uniform-vector-element-size 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-constant-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.
+;;;
+
+(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-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 (? 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-high-pc! arity (asm-start asm))))
+
+(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))))
+
+(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))
+
+(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)))
+
+(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 (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?)))
+
+
+\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)
+
+ (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)))
+ (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))))
+ (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 (uniform-vector-element-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"))))
+
+ (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
+
+;;;
+;;; 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* 3)
+
+(define (link-dynamic-section asm text rw rw-init)
+ "Link the dynamic section for an ELF image with RTL 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))
+ (bv (make-bytevector (* word-size (if rw (if rw-init 12 10) 6)) 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)
+ (cond
+ (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)))
+ (cond
+ (rw-init
+ (set-uword! 8 DT_INIT) ; constants
+ (set-label! 9 rw-init)
+ (set-uword! 10 DT_NULL)
+ (set-uword! 11 0))
+ (else
+ (set-uword! 8 DT_NULL)
+ (set-uword! 9 0))))
+ (else
+ (set-uword! 4 DT_NULL)
+ (set-uword! 5 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;
+;;; }
+;;;
+;;; 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 RTL 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. Links for required arguments
+;;; are first, in order, as uint32 values. Next follow the optionals,
+;;; then the rest link if has-rest? is set, then a link to the "keyword
+;;; indices" literal if has-keyword-args? is set. Unlike the other
+;;; links, the kw-indices link points into the data section, and is
+;;; relative to the ELF image as a whole.
+;;;
+;;; 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 (* 6 4))
+
+;; The offset of "offset" within arity header, in bytes.
+(define arity-header-offset-offset (* 2 4))
+
+(define-syntax-rule (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 (meta-arities-size meta)
+ (define (lambda-size arity)
+ (+ arity-header-len
+ (* 4 ;; name pointers
+ (+ (length (arity-req arity))
+ (length (arity-opt arity))
+ (if (arity-rest arity) 1 0)
+ (if (pair? (arity-kw-indices arity)) 1 0)))))
+ (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 (write-arity-headers metas bv endianness)
+ (define (write-arity-header* pos low-pc high-pc flags nreq nopt)
+ (bytevector-u32-set! bv pos (* low-pc 4) endianness)
+ (bytevector-u32-set! bv (+ pos 4) (* high-pc 4) endianness)
+ (bytevector-u32-set! bv (+ pos 8) 0 endianness) ; offset
+ (bytevector-u32-set! bv (+ pos 12) flags endianness)
+ (bytevector-u32-set! bv (+ pos 16) nreq endianness)
+ (bytevector-u32-set! bv (+ pos 20) nopt endianness))
+ (define (write-arity-header pos arity in-case-lambda?)
+ (write-arity-header* pos (arity-low-pc arity)
+ (arity-high-pc arity)
+ (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))))
+ (let lp ((metas metas) (pos arities-prefix-len) (offsets '()))
+ (match metas
+ (()
+ ;; Fill in the prefix.
+ (bytevector-u32-set! bv 0 pos endianness)
+ (values pos (reverse offsets)))
+ ((meta . metas)
+ (match (meta-arities meta)
+ (() (lp metas pos offsets))
+ ((arity)
+ (write-arity-header pos arity #f)
+ (lp metas
+ (+ pos arity-header-len)
+ (acons arity (+ pos arity-header-offset-offset) offsets)))
+ (arities
+ ;; Write a case-lambda header, then individual arities.
+ ;; The case-lambda header's offset link is 0.
+ (write-arity-header* pos (meta-low-pc meta) (meta-high-pc meta)
+ (pack-arity-flags #f #f #f #t #f) 0 0)
+ (let lp* ((arities arities) (pos (+ pos arity-header-len))
+ (offsets offsets))
+ (match arities
+ (() (lp metas pos offsets))
+ ((arity . arities)
+ (write-arity-header pos arity #t)
+ (lp* arities
+ (+ pos arity-header-len)
+ (acons arity
+ (+ pos arity-header-offset-offset)
+ offsets)))))))))))
+
+(define (write-arity-links asm bv pos arity-offset-pairs strtab)
+ (define (write-symbol sym pos)
+ (bytevector-u32-set! bv pos
+ (string-table-intern! strtab (symbol->string sym))
+ (asm-endianness asm))
+ (+ pos 4))
+ (define (write-kw-indices pos kw-indices)
+ ;; FIXME: Assert that kw-indices is already interned.
+ (make-linker-reloc 'abs32/1 pos 0
+ (intern-constant asm kw-indices)))
+ (let lp ((pos pos) (pairs arity-offset-pairs) (relocs '()))
+ (match pairs
+ (()
+ (unless (= pos (bytevector-length bv))
+ (error "expected to fully fill the bytevector"
+ pos (bytevector-length bv)))
+ relocs)
+ (((arity . offset) . pairs)
+ (bytevector-u32-set! bv offset pos (asm-endianness asm))
+ (let ((pos (fold write-symbol
+ pos
+ (append (arity-req arity)
+ (arity-opt arity)
+ (cond
+ ((arity-rest arity) => list)
+ (else '()))))))
+ (match (arity-kw-indices arity)
+ (() (lp pos pairs relocs))
+ (kw-indices
+ (lp (+ pos 4)
+ pairs
+ (cons (write-kw-indices pos kw-indices) relocs)))))))))
+
+(define (link-arities asm)
+ (let* ((endianness (asm-endianness asm))
+ (metas (reverse (asm-meta asm)))
+ (size (fold (lambda (meta size)
+ (+ size (meta-arities-size meta)))
+ arities-prefix-len
+ metas))
+ (strtab (make-string-table))
+ (bv (make-bytevector size 0)))
+ (let ((kw-indices-relocs
+ (call-with-values
+ (lambda ()
+ (write-arity-headers metas bv endianness))
+ (lambda (pos arity-offset-pairs)
+ (write-arity-links asm bv pos arity-offset-pairs strtab)))))
+ (let ((strtab (make-object asm '.guile.arities.strtab
+ (link-string-table! strtab)
+ '() '()
+ #:type SHT_STRTAB #:flags 0)))
+ (values (make-object asm '.guile.arities
+ bv
+ kw-indices-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 (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 (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 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 (exact-integer? val)
+ (and (number? val) (integer? val) (exact? val)))
+
+ (define (choose-form attr val code)
+ (cond
+ ((string? val) 'strp)
+ ((eq? attr 'stmt-list) 'sec-offset)
+ ((exact-integer? code)
+ (cond
+ ((< code 0) 'sleb128)
+ ((<= code #xff) 'data1)
+ ((<= code #xffff) 'data2)
+ ((<= code #xffffffff) 'data4)
+ ((<= code #xffffffffffffffff) 'data8)
+ (else 'uleb128)))
+ ((symbol? val) 'addr)
+ (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))
+ ((dt) (link-dynamic-section asm text rw rw-init))
+ ((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 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 Free Software Foundation, 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 RTL 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))
+ #: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-has-rest?
+ arity-allow-other-keys?
+ arity-has-keyword-args?
+ arity-is-case-lambda?
+
+ 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-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 RTL 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 (* 6 4))
+
+;;; struct arity_header {
+;;; uint32_t low_pc;
+;;; uint32_t high_pc;
+;;; uint32_t offset;
+;;; uint32_t flags;
+;;; uint32_t nreq;
+;;; uint32_t nopt;
+;;; }
+
+(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))))
+
+;;; #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-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-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-arguments-alist arity)
+ (let* ((bv (elf-bytes (debug-context-elf (arity-context arity))))
+ (%load-symbol (arity-load-symbol arity))
+ (header (arity-header-offset arity))
+ (link-offset (arity-offset* bv header))
+ (link (+ (arity-base arity) link-offset))
+ (flags (arity-flags* bv header))
+ (nreq (arity-nreq* bv header))
+ (nopt (arity-nopt* bv header)))
+ (define (load-symbol idx)
+ (%load-symbol (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+ (define (load-symbols skip n)
+ (let lp ((n n) (out '()))
+ (if (zero? n)
+ out
+ (lp (1- n)
+ (cons (load-symbol (+ skip (1- n))) out)))))
+ (define (unpack-scm n)
+ (pointer->scm (make-pointer n)))
+ (define (load-non-immediate idx)
+ (let ((offset (bytevector-u32-native-ref bv (+ link (* idx 4)))))
+ (unpack-scm (+ (debug-context-base (arity-context arity)) offset))))
+ (and (not (is-case-lambda? flags))
+ `((required . ,(load-symbols 0 nreq))
+ (optional . ,(load-symbols nreq nopt))
+ (keyword . ,(if (has-keyword-args? flags)
+ (load-non-immediate
+ (+ nreq nopt (if (has-rest? flags) 1 0)))
+ '()))
+ (allow-other-keys? . ,(allow-other-keys? flags))
+ (rest . ,(and (has-rest? flags) (load-symbol (+ nreq nopt))))))))
+
+(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-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)
+ (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 RTL disassembler
+
+;;; 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 (system vm disassembler)
+ #:use-module (language rtl)
+ #: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))
+
+(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))))
+ ((U8_U8_I16)
+ #'((logand word #xff)
+ (logand (ash word -8) #xff)
+ (ash word -16)))
+ ((U8_U12_U12)
+ #'((logand word #xff)
+ (logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((U8_U8_U8_U8)
+ #'((logand word #xff)
+ (logand (ash word -8) #xff)
+ (logand (ash word -16) #xff)
+ (ash word -24)))
+ ((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_U12_U12)
+ #'((logand (ash word -8) #xfff)
+ (ash word -20)))
+ ((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)
+ ;; 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->=) _ ... 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?")
+ ((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)))
+ ;; FIXME: Disassemble embedded closures as well.
+ (list "~A at 0x~X (~A free var~:p)"
+ (or (and pdi (program-debug-info-name pdi))
+ "(anonymous procedure)")
+ addr
+ nfree)))
+ (('make-non-immediate dst target)
+ (list "~@Y" (reference-scm target)))
+ (('builtin-ref dst idx)
+ (list "~A" (builtin-index->name idx)))
+ (((or 'static-ref 'static-set!) _ target)
+ (list "~@Y" (dereference-scm target)))
+ (('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->=)
+ (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)
+ (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"
+ (source-file source)
+ (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)))
+ (print-info port pos (vector-ref labels pos) elt annotation
+ (lookup-source addr))
+ (lp (+ offset len)))))))))
+
+(define* (disassemble-program program #:optional (port (current-output-port)))
+ (cond
+ ((find-program-debug-info (program-code program))
+ => (lambda (pdi)
+ (format port "Disassembly of ~S at #x~X:\n\n" program
+ (program-debug-info-addr pdi))
+ (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))))
+ (else
+ (format port "Debugging information unavailable.~%")))
+ (values))
+
+(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)
+ (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)))
--- /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 Free Software Foundation, 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
+
+ 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 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_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_STANDALONE 255) ; Standalone (embedded) application
+
+(define ET_DYN 3) ; Shared object 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_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 (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 Free Software 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 vm program)
- #:use-module (system vm instruction)
- #:use-module (system vm objcode)
#:export (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))
- '())))
+ (program-bindings-for-ip p (frame-instruction-pointer frame))))
(define (frame-lookup-binding frame var)
(let lp ((bindings (frame-bindings 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
(opt (or (assq-ref arguments 'optional) '()))
(key (or (assq-ref arguments 'keyword) '()))
(rest (or (assq-ref arguments 'rest) #f))
- (i 0))
+ (i 1))
(cond
((pair? req)
(cons (binding-ref (car req) i)
;; case 2
(map (lambda (i)
(frame-local-ref frame i))
- (iota (frame-num-locals frame))))))))
+ ;; Cdr past the 0th local, which is the procedure.
+ (cdr (iota (frame-num-locals frame)))))))))
\f
(define (frame-object-name frame obj)
(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 Free Software Foundation, 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/4 is a relative signed offset in 32-bit units. 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/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)))
+ (cons (cond
+ ((= (elf-section-type section) SHT_DYNAMIC) PT_DYNAMIC)
+ ;; Sections without SHF_ALLOC don't go in segments.
+ ((zero? flags) #f)
+ (else PT_LOAD))
+ (logior (if (zero? (logand SHF_ALLOC flags))
+ 0
+ PF_R)
+ (if (zero? (logand SHF_EXECINSTR flags))
+ 0
+ PF_X)
+ (if (zero? (logand SHF_WRITE flags))
+ 0
+ PF_W)))))
+
+(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."
+ (length
+ (fold-values (lambda (object kinds)
+ (let ((kind (segment-kind (linker-object-section object))))
+ (if (and (car kind) (not (member kind kinds)))
+ (cons 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 addr)
+ "Return a new section header, just like @var{sec} but with its
+@code{addr} and @code{offset} set to @var{addr}."
+ (make-elf-section #:index (elf-section-index sec)
+ #:name (elf-section-name sec)
+ #:type (elf-section-type sec)
+ #:flags (elf-section-flags sec)
+ #:addr addr
+ #:offset addr
+ #: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
+ #: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)))
+ ((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)))
+ (unless (= offset (elf-section-addr section))
+ (error "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)
+ "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
+ #: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
+ (cons* (make-linker-reloc
+ reloc-kind
+ (+ offset (elf-section-header-addr-offset word-size))
+ 0
+ section-label)
+ (make-linker-reloc
+ reloc-kind
+ (+ offset (elf-section-header-offset-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 (allocate-elf objects page-aligned? endianness word-size)
+ "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)
+ (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)))
+ (()
+ (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)))
+ "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)
+ (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")
;;; 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
+ #:export (make-binding binding:name binding:boxed? binding:index
binding:start binding:end
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-bindings-for-ip
+
program-arities program-arity arity:start arity:end
arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
- program-arguments-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!))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_programs")
+;; 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 (make-binding name boxed? index start end)
(list name boxed? index start end))
(define (binding:name b) (list-ref b 0))
(define (source:line-for-user source)
(1+ (source:line source)))
-;; FIXME: pull this definition from elsewhere.
-(define *bytecode-header-len* 8)
-
-;; 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 (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)))))
+
+(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)))))
;; 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"))))))))
+ (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 (collapse-locals locs)
(let lp ((ret '()) (locs 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 '())))
+ ;; FIXME!
+ '())
(define (program-bindings-for-ip prog ip)
(let lp ((in (program-bindings-by-index prog)) (out '()))
(else (inner (cdr binds)))))))))
(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
;; 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 (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 (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))
- ""
- (string-append
- " " (string-join (map (lambda (a)
- (object->string
- (arguments-alist->lambda-list
- (arity->arguments-alist prog a))))
- arities)
- " | "))))))
+ (define (program-identity-string)
+ (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)))
+ (define (program-formals-string)
+ (let ((arguments (program-arguments-alists prog)))
+ (if (null? arguments)
+ ""
+ (string-append
+ " " (string-join (map (lambda (a)
+ (object->string
+ (arguments-alist->lambda-list a)))
+ arguments)
+ " | ")))))
+
+ (format port "#<procedure ~a~a>"
+ (program-identity-string) (program-formals-string)))
;;; Guile VM tracer
-;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
+;; 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
#: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
width
(frame-call-representation frame))))
-(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 frame 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 frame 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 frame 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 Free Software 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?)
- (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))))))
+;; 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?)
+ (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 in-proc?
(exit-proc frame)))
- (define (pop-cont-hook frame)
+ (define (pop-cont-hook frame . values)
(if in-proc?
(exit-proc frame))
(if (our-frame? (frame-previous frame))
(enter-proc (frame-previous frame))))
- (define (abort-hook frame)
- (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-push-continuation-hook) push-cont-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-push-continuation-hook) push-cont-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)
+ (define (pop-cont-hook frame . values)
(if (and fp (eq? (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?)
(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 Free Software 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
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)
#: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))))
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/cross-compilation.test \
tests/cse.test \
tests/curried-definitions.test \
+ tests/dwarf.test \
tests/ecmascript.test \
tests/elisp.test \
tests/elisp-compiler.test \
tests/optargs.test \
tests/options.test \
tests/parameters.test \
+ tests/peg.test \
tests/peval.test \
tests/print.test \
tests/procprop.test \
tests/reader.test \
tests/receive.test \
tests/regexp.test \
+ tests/rtl.test \
+ tests/rtl-compilation.test \
tests/session.test \
tests/signals.test \
tests/srcprop.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.
-/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010,
+/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010, 2011
* 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#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));
;;;; 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)
-;;;; socket.test --- test socket functions -*- scheme -*-
+;;;; 00-socket.test --- test socket functions -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-;;;; 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 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)
+++ /dev/null
-;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
-;;;;
-;;;; 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
-
-(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)
-
- (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))))
;;; Local Variables:
;;; eval: (put 'with-test-prefix/c&e 'scheme-indent-function 1)
;;;; 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 Free Software 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)))))
(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)))))))
+ (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.
(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)
(+ 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, 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 (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 'rtl)))
+ (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)
+
+ (pass-if-exception "unknown target" exception:miscellaneous-error
+ (with-target "fcpu-unknown-gnu1.0"
+ (lambda ()
+ (compile '(ohai) #:to 'rtl)))))
+
+;; Local Variables:
+;; eval: (put 'with-target 'scheme-indent-function 1)
+;; End:
;;;; 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.
+;;;; 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 (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
((_ in pat)
(pass-if 'in
(let ((evaled (unparse-tree-il
- (canonicalize!
- (fix-letrec!
+ (canonicalize
+ (fix-letrec
(cse
(peval
- (expand-primitives!
- (resolve-primitives!
+ (expand-primitives
+ (resolve-primitives
(compile 'in #:from 'scheme #:to 'tree-il)
(current-module))))))))))
(pmatch evaled
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (apply (primitive eq?) (lexical x _) (lexical y _))))))
+ (primcall eq? (lexical x _) (lexical y _))))))
;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
(pass-if-cse
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (apply (primitive not)
- (apply (primitive eq?) (lexical x _) (lexical y _)))))))
+ (primcall not
+ (primcall eq? (lexical x _) (lexical y _)))))))
;; (if TEST (not TEST) #f)
;; => (if TEST #f #f)
(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 _)))
+ (if (primcall set-car!
+ (lexical x _)
+ (lexical y _))
+ (primcall not
+ (primcall set-car!
+ (lexical x _)
+ (lexical y _)))
(const #f))))))
;; Primitives that access mutable memory can propagate, as long as
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (begin
- (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
- (const #f))))))
+ (seq (primcall string-ref
+ (lexical x _)
+ (lexical y _))
+ (const #f))))))
;; However, expressions with dependencies on effects do not propagate
;; through a lambda.
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (if (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
+ (if (primcall string-ref
+ (lexical x _)
+ (lexical y _))
(lambda _
(lambda-case
((() #f #f #f () ())
- (if (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
+ (if (primcall string-ref
+ (lexical x _)
+ (lexical y _))
(const #t)
(const #f)))))
(const #f))))))
(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 _))))
+ (if (primcall string-ref
+ (lexical x _)
+ (lexical y _))
+ (seq (primcall string-set!
+ (lexical x _)
+ (const #\!))
+ (primcall not
+ (primcall string-ref
+ (lexical x _)
+ (lexical y _))))
(const #f))))))
;; Predicates are only added to the database if they are in a
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (apply (primitive eq?) (lexical x _) (lexical y _))))))
+ (primcall eq? (lexical x _) (lexical y _))))))
;; Conditional bailouts do cause primitives to be added to the DB.
(pass-if-cse
(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))))))
+ (seq (if (primcall eq?
+ (lexical x _) (lexical y _))
+ (void)
+ (primcall throw (const foo)))
+ (const #t))))))
;; A chain of tests in a conditional bailout add data to the DB
;; correctly.
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (begin
+ (seq
(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))
+ (primcall throw (const foo))))))
+ (if (primcall struct? (lexical x _))
+ (if (primcall eq?
+ (primcall struct-vtable (lexical x _))
+ (toplevel x-vtable))
(void)
- (apply (lexical failure _)))
- (apply (lexical failure _))))
- (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
+ (call (lexical failure _)))
+ (call (lexical failure _))))
+ (primcall struct-ref (lexical x _) (lexical y _)))))))
;; Strict argument evaluation also adds info to the DB.
(pass-if-cse
((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))))))))
+ (primcall throw (const foo))))))
+ (if (primcall struct? (lexical x _))
+ (if (primcall eq?
+ (primcall struct-vtable (lexical x _))
+ (toplevel x-vtable))
+ (primcall struct-ref (lexical x _) (const 1))
+ (call (lexical failure _)))
+ (call (lexical failure _)))))
+ (primcall + (lexical z _)
+ (primcall 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 _))))
+ (let (x) (_) ((primcall car (toplevel y)))
+ (primcall cons (lexical x _) (lexical x _))))
;; Dominating expressions only provide predicates when evaluated in
;; test context.
'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))
+ (seq
+ (primcall car (toplevel x))
+ (if (primcall 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))
+ (seq
+ (primcall 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)
+ (procedure?
+ (compile '(lambda (v)
(let ((failure (lambda () (bail-out 'match))))
(if (and (pair? v)
(null? (cdr v)))
#t
(failure)))
(failure))))
- #:from 'scheme
- #:to 'glil))))
+ #:from 'scheme))))
--- /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 'rtl))))
+ (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 Free Software 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-vm))
:use-module (ice-9 documentation)
:use-module (ice-9 local-eval))
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 (lambda (frame)
+ (cons (frame-procedure frame)
+ (frame-arguments frame)))
+ (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? (frame-procedure (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? (frame-procedure (car frames))
+ make-stack)
+ (eq? (frame-procedure (car (last-pair frames)))
+ with-throw-handler)
+ (eq? (car (frame-arguments (car (last-pair frames))))
+ 'wrong-type-arg)))))
;;;
;;; letrec init evaluation
;; 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))))
+ (let ((thunk (let loop () (cons 's (loop)))))
+ (call-with-vm thunk))))
;;;
;;; 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))))))
--- /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
(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))
((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical a _)))))
+ (call (lexical a _)))))
(lambda _
(lambda-case
(((x) #f #f #f () (_))
(lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical a _))))))
+ (call (lexical a _))))))
(let (d)
(_)
- ((apply (toplevel foo) (lexical b _)))
- (apply (lexical c _)
- (lexical d _)))))
+ ((call (toplevel foo) (lexical b _)))
+ (call (lexical c _) (lexical d _)))))
(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))))
+ (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 "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 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
(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))))
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 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)))
-;;;; rdelim.test --- Delimited I/O. -*- mode: scheme; coding: utf-8; -*-
-;;;; Ludovic Courtès <ludo@gnu.org>
-;;;;
-;;;; Copyright (C) 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
-
-(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) "")))))
-
- (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 Free Software Foundation, 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) "")))))
+
+(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, 2002, 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009, 2010, 2011,
+;;;; 2013 Free Software Foundation, Inc.
;;;; Jim Blandy <jimb@red-bean.com>
;;;;
;;;; This library is free software; you can redistribute it and/or
(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 rtl -*- 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 rtl-compilation)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system vm loader))
+
+(define* (compile-via-rtl exp #:key peval? cse? (env (make-fresh-user-module)))
+ (load-thunk-from-memory
+ (compile exp #:env env #:to 'rtl
+ #:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
+
+(define* (run-rtl exp #:key (env (make-fresh-user-module)))
+ (let ((thunk (compile-via-rtl exp #:env env)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module env)
+ (thunk)))))
+
+(with-test-prefix "tail context"
+ (pass-if-equal 1
+ (run-rtl '(let ((x 1)) x)))
+
+ (pass-if-equal 1
+ (run-rtl 1))
+
+ (pass-if-equal (if #f #f)
+ (run-rtl '(if #f #f)))
+
+ (pass-if-equal "top-level define"
+ (list (if #f #f) 1)
+ (let ((mod (make-fresh-user-module)))
+ (let ((result (run-rtl '(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-rtl '(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-rtl '(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-rtl '(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-rtl '(apply proc args) #:env mod))
+ list)))
+
+ (pass-if-equal "call-with-values"
+ '(1 2 3)
+ ((run-rtl '(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-rtl 'cons))
+
+ (pass-if-equal 1
+ ((run-rtl '(lambda () 1))))
+
+ (pass-if-equal 1
+ ((run-rtl '(lambda (x) 1)) 2))
+
+ (pass-if-equal 1
+ ((run-rtl '(lambda (x) x)) 1))
+
+ (pass-if-equal 6
+ ((((run-rtl '(lambda (x)
+ (lambda (y)
+ (lambda (z)
+ (+ x y z))))) 1) 2) 3))
+
+ (pass-if-equal 1
+ (run-rtl '(identity 1)))
+
+ (pass-if-equal '(1 . 2)
+ (run-rtl '(cons 1 2)))
+
+ (pass-if-equal '(1 2)
+ (call-with-values (lambda () (run-rtl '(values 1 2))) list))
+
+ (pass-if-equal 28
+ ((run-rtl '(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-rtl
+ '(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-rtl '(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-rtl '(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-rtl '(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-rtl '(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-rtl '(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-rtl '(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-rtl '(case-lambda))))
+
+ (pass-if-exception "zero clauses called with args"
+ exception:wrong-num-args
+ ((run-rtl '(case-lambda)) 1)))
+
+(with-test-prefix "mixed contexts"
+ (pass-if-equal "sequences" '(3 4 5)
+ (let* ((pair (cons 1 2))
+ (result ((run-rtl '(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-rtl '(let ((n 1)) (set! n 2) n))))
--- /dev/null
+;;;; Low-level tests of the RTL assembler -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; 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
+
+(define-module (tests rtl)
+ #: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 RTL code, 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)
+ (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)
+ (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)
+ (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)
+ (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)
+ (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)
+ (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)
+ (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)
+ (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 rtl) *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 "simply 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)
+ (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)
+ (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"
;;;; 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)))
;;;; 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)))))
(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"
#: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 "~?" "~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")))))
(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")))))))
(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 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
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
;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; 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
(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)))
## 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 'rtl))
-(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