From: Andy Wingo Date: Thu, 28 Nov 2013 13:53:03 +0000 (+0100) Subject: Merge commit '750ac8c592e792e627444f476877f282525b132e' X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/6dd98109020997d22f78d9cd516d7809c4fcc493?hp=750ac8c592e792e627444f476877f282525b132e Merge commit '750ac8c592e792e627444f476877f282525b132e' Conflicts: .gitignore libguile/deprecated.c --- diff --git a/.dir-locals.el b/.dir-locals.el index a24e860ca..0589229cd 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -5,12 +5,27 @@ (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)))) diff --git a/.gitignore b/.gitignore index 064305c46..12cbc32f5 100644 --- a/.gitignore +++ b/.gitignore @@ -66,8 +66,8 @@ guile-procedures.txt 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 @@ -160,3 +160,4 @@ INSTALL /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 diff --git a/GUILE-VERSION b/GUILE-VERSION index 4ebba1e55..4a3f4fcef 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -2,23 +2,21 @@ # 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}" diff --git a/acinclude.m4 b/acinclude.m4 index 8ef6e99ec..6a1470f24 100644 --- a/acinclude.m4 +++ b/acinclude.m4 @@ -1,7 +1,7 @@ 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 @@ -462,13 +462,6 @@ AC_DEFUN([GUILE_READLINE], [ 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 diff --git a/am/guilec b/am/guilec index f5849d079..5ef07faa4 100644 --- a/am/guilec +++ b/am/guilec @@ -1,14 +1,14 @@ # -*- 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) @@ -24,11 +24,20 @@ AM_V_GUILEC = $(AM_V_GUILEC_$(V)) 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 "$@" "$<" diff --git a/benchmark-suite/benchmarks/ports.bm b/benchmark-suite/benchmarks/ports.bm index 630ece290..0b1d7f5f3 100644 --- a/benchmark-suite/benchmarks/ports.bm +++ b/benchmark-suite/benchmarks/ports.bm @@ -1,6 +1,6 @@ ;;; 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 @@ -34,16 +34,15 @@ (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 "안녕하세요"))) (with-benchmark-prefix "peek-char" @@ -87,6 +86,5 @@ (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))))) diff --git a/configure.ac b/configure.ac index e5f3a4c84..92dcb1e00 100644 --- a/configure.ac +++ b/configure.ac @@ -29,7 +29,7 @@ Floor, Boston, MA 02110-1301, USA. 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]) @@ -1240,41 +1240,17 @@ main (int argc, char **argv) # 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_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 ]) +# 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 ]) +# Functions from GC 7.3. +AC_CHECK_FUNCS([GC_move_disappearing_link]) LIBS="$save_LIBS" @@ -1657,8 +1633,8 @@ AC_CONFIG_FILES([ 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]) diff --git a/doc/example-smob/Makefile b/doc/example-smob/Makefile index 3736dc01f..d368d7b21 100644 --- a/doc/example-smob/Makefile +++ b/doc/example-smob/Makefile @@ -1,5 +1,5 @@ -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 diff --git a/doc/guile.1 b/doc/guile.1 index e36c2aac7..5d8b4e158 100644 --- a/doc/guile.1 +++ b/doc/guile.1 @@ -4,7 +4,7 @@ .\" 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 diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index d0ea94d51..75b1745fa 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -44,6 +44,7 @@ guile_TEXINFOS = preface.texi \ api-foreign.texi \ api-regex.texi \ api-lalr.texi \ + api-peg.texi \ api-languages.texi \ api-evaluation.texi \ api-memory.texi \ @@ -118,8 +119,7 @@ EXTRA_DIST = ChangeLog-2008 $(PICTURES) 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)/$@ diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 7ffb3f740..026308cac 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -494,14 +494,17 @@ those passed to @code{abort-to-prompt}. @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{} diff --git a/doc/ref/api-coverage.texi b/doc/ref/api-coverage.texi index 680997711..5081d343b 100644 --- a/doc/ref/api-coverage.texi +++ b/doc/ref/api-coverage.texi @@ -1,6 +1,6 @@ @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. @@ -14,10 +14,10 @@ part of the code is @dfn{covered} by the test suite. The @code{(system vm 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 @@ -43,7 +43,7 @@ Here's an example use: (system vm vm)) (call-with-values (lambda () - (with-code-coverage (the-vm) + (with-code-coverage (lambda () (do-something-tricky)))) (lambda (data result) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 096970cb5..760318028 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -4448,6 +4448,19 @@ returned is the number of bytes for @code{scm_to_latin1_stringn} and 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 diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index f6c706c78..32f32caba 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -716,7 +716,7 @@ a thunk, gives us the following: @lisp scheme@@(guile-user)> (use-modules (system vm vm)) scheme@@(guile-user)> (debug-set! stack 10000) -scheme@@(guile-user)> (let lp () (call-with-vm (the-vm) lp)) +scheme@@(guile-user)> (let lp () (call-with-vm lp)) ERROR: In procedure call-with-vm: ERROR: Stack overflow @end lisp @@ -799,10 +799,11 @@ To digress, Guile's VM has 6 different hooks (@pxref{Hooks}) that can be 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 @@ -815,31 +816,28 @@ The interface to hooks is provided by the @code{(system vm vm)} module: @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. @@ -850,13 +848,16 @@ whereas a tail call will run without having fired a push-continuation 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. @@ -874,12 +875,12 @@ level temporarily set to 0. That way the hooks don't fire while you're 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 @@ -1177,7 +1178,7 @@ procedure calls and returns within the thunk. @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 diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 63b1d6059..1810fe854 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -573,18 +573,6 @@ Call @var{proc} with the array of arguments @var{argv}, as a @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 @@ -676,13 +664,13 @@ Use @var{lang} as the source language of @var{file}. If this option is omitted, @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 @@ -707,7 +695,7 @@ the Virtual Machine}. @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] @@ -936,8 +924,8 @@ When @code{primitive-load-path} searches the @code{%load-compiled-path} 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 @@ -1179,7 +1167,7 @@ it contains, splicing them into the location of the @code{include}, 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 diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index f1170eb2c..5ca3506a9 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1066,28 +1066,6 @@ away from its default. 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 @@ -1101,8 +1079,6 @@ read. The value yielded by the @var{proc} is returned. 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 diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index a3fa83f5a..82a2c071e 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.texi @@ -726,7 +726,7 @@ Return the name of the module whose source contains the identifier @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 @@ -739,6 +739,12 @@ of @code{eq?}) identifying this binding. @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. diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi index 8fa4f98a5..b09ae8952 100644 --- a/doc/ref/api-options.texi +++ b/doc/ref/api-options.texi @@ -60,14 +60,14 @@ The @code{effective-version} function returns the version name that 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 @@ -87,7 +87,7 @@ party package) are installed. On Unix-like systems this is usually @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 diff --git a/doc/ref/api-peg.texi b/doc/ref/api-peg.texi new file mode 100644 index 000000000..0e16aab7e --- /dev/null +++ b/doc/ref/api-peg.texi @@ -0,0 +1,1036 @@ +@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{} +# +(match-pattern as-or-bs-tag "aabbcc") @result{} +# +@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{} +# +(match-pattern as-or-bs-tag "aabbcc") @result{} +# +@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{} +# +@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{} +# + +(define-peg-pattern as body (+ "a")) +(match-pattern as "aabbcc") @result{} +# + +(define-peg-pattern as none (+ "a")) +(match-pattern as "aabbcc") @result{} +# + +(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{} +# +(search-for-pattern (+ "a") "aabbcc") @result{} +# +(search-for-pattern "'a'+" "aabbcc") @result{} +# + +(define-peg-pattern as all (+ "a")) +(search-for-pattern as "aabbcc") @result{} +# + +(define-peg-pattern bs body (+ "b")) +(search-for-pattern bs "aabbcc") @result{} +# +(search-for-pattern (+ "b") "aabbcc") @result{} +# +(search-for-pattern "'b'+" "aabbcc") @result{} +# + +(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{} +# + +(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. diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index bfc633e57..553c270e7 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -1,6 +1,6 @@ @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. @@ -161,12 +161,11 @@ different worlds indefinitely, as shown by the following quine: @node The Scheme Compiler @subsection The Scheme Compiler -The job of the Scheme compiler is to expand all macros and all of -Scheme to its most primitive expressions. The definition of -``primitive'' is given by the inventory of constructs provided by -Tree-IL, the target language of the Scheme compiler: procedure -applications, conditionals, lexical references, etc. This is described -more fully in the next section. +The job of the Scheme compiler is to expand all macros and all of Scheme +to its most primitive expressions. The definition of ``primitive'' 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 @@ -184,10 +183,10 @@ The Scheme-to-Tree-IL expander may be invoked using the generic @lisp (compile '(+ 1 2) #:from 'scheme #:to 'tree-il) @result{} - #< src: #f - proc: #< src: #f name: +> - args: (#< src: #f exp: 1> - #< src: #f exp: 2>)> + #< src: #f + proc: #< src: #f name: +> + args: (#< src: #f exp: 1> + #< src: #f exp: 2>)> @end lisp Or, since Tree-IL is so close to Scheme, it is often useful to expand @@ -342,9 +341,9 @@ instruction. Compilation of Tree-IL usually begins with a pass that resolves some @code{} and @code{} expressions to -@code{} expressions. The actual compilation pass -has special cases for applications of certain primitives, like -@code{apply} or @code{cons}. +@code{} expressions. The actual compilation pass has +special cases for calls to certain primitives, like @code{apply} or +@code{cons}. @end deftp @deftp {Scheme Variable} src name gensym @deftpx {External Representation} (lexical @var{name} @var{gensym}) @@ -388,10 +387,19 @@ Defines a new top-level variable in the current procedure's module. @deftpx {External Representation} (if @var{test} @var{then} @var{else}) A conditional. Note that @var{else} is not optional. @end deftp -@deftp {Scheme Variable} src proc args -@deftpx {External Representation} (apply @var{proc} . @var{args}) +@deftp {Scheme Variable} src proc args +@deftpx {External Representation} (call @var{proc} . @var{args}) A procedure call. @end deftp +@deftp {Scheme Variable} 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{}. + +As part of the compilation process, instances of @code{(call (primitive +@var{name}) . @var{args})} are transformed into primcalls. +@end deftp @deftp {Scheme Variable} src exps @deftpx {External Representation} (begin . @var{exps}) Like Scheme's @code{begin}. @@ -450,31 +458,6 @@ original binding names, @var{gensyms} are gensyms corresponding to the A version of @code{} that creates recursive bindings, like Scheme's @code{letrec}, or @code{letrec*} if @var{in-order?} is true. @end deftp -@deftp {Scheme Variable} 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} 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} 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} 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} tag body handler @deftpx {External Representation} (prompt @var{tag} @var{body} @var{handler}) A dynamic prompt. Instates a prompt named @var{tag}, an expression, @@ -509,7 +492,7 @@ Like Scheme's @code{receive} -- binds the values returned by evaluating @code{exp} to the @code{lambda}-like bindings described by @var{gensyms}. That is to say, @var{gensyms} may be an improper list. -@code{} is an optimization of @code{} of the +@code{} is an optimization of a @code{} to the primitive, @code{call-with-values}. @end deftp @deftp {Scheme Variable} src names gensyms vals body @@ -792,29 +775,36 @@ objcode)} module. 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 diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi index 29f3c93c8..29292869f 100644 --- a/doc/ref/guile-invoke.texi +++ b/doc/ref/guile-invoke.texi @@ -335,9 +335,7 @@ explicitly enable it by setting the variable to @code{1}. 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 @@ -367,7 +365,7 @@ Here is an example using the Bash shell that adds the current directory, @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 @@ -386,8 +384,8 @@ directory to @code{%load-path}, and adds the relative directory @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) diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 1e4a95a99..c3170ce46 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -308,6 +308,7 @@ available through both Scheme and C interfaces. * 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. @@ -336,6 +337,7 @@ available through both Scheme and C interfaces. @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 diff --git a/doc/ref/libguile-concepts.texi b/doc/ref/libguile-concepts.texi index 50c435584..0103ad173 100644 --- a/doc/ref/libguile-concepts.texi +++ b/doc/ref/libguile-concepts.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 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 @@ -449,16 +449,18 @@ that are stored in local variables. When a thread puts itself into 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 diff --git a/doc/ref/libguile-parallel.texi b/doc/ref/libguile-parallel.texi index 37a713929..a0e1ea978 100644 --- a/doc/ref/libguile-parallel.texi +++ b/doc/ref/libguile-parallel.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 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. @@ -11,10 +11,10 @@ @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 diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index b3a6a048f..40c20e7e9 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1867,10 +1867,11 @@ the integer process ID of the child. 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 diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index b6d524879..32ff271b7 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -146,6 +146,7 @@ guile-2 ;; starting from Guile 2.x r5rs srfi-0 srfi-4 +srfi-6 srfi-13 srfi-14 srfi-23 @@ -177,8 +178,8 @@ how to load it with the Guile mechanism. @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 @@ -1851,19 +1852,11 @@ uniform numeric vector, it is returned unchanged. @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 diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 9936ad97d..1e10eb02e 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -1,6 +1,6 @@ @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. @@ -79,9 +79,9 @@ but it is not normally used at runtime.) The upside of implementing the interpreter in Scheme is that we preserve tail calls and multiple-value handling between interpreted and compiled -code. The downside is that the interpreter in Guile 2.0 is slower than -the interpreter in 1.8. We hope the that the compiler's speed makes up -for the loss! +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 @@ -1120,18 +1120,17 @@ wind/unwind thunk pair. @code{unwind} instructions should be properly paired with their winding instructions, like @code{wind}. @end deffn -@deffn Instruction wind-fluids n -Pop off @var{n} values and @var{n} fluids from the stack, in that order. -Set the fluids to the values by creating a with-fluids object and -pushing that object on the dynamic stack. @xref{Fluids and Dynamic -States}. +@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 diff --git a/guile-readline/LIBGUILEREADLINE-VERSION b/guile-readline/LIBGUILEREADLINE-VERSION deleted file mode 100644 index dfd515e29..000000000 --- a/guile-readline/LIBGUILEREADLINE-VERSION +++ /dev/null @@ -1,14 +0,0 @@ -# -*-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}" diff --git a/guile-readline/Makefile.am b/guile-readline/Makefile.am index 0c4ca773e..ade7dd09d 100644 --- a/guile-readline/Makefile.am +++ b/guile-readline/Makefile.am @@ -1,7 +1,7 @@ ## 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. ## @@ -42,17 +42,16 @@ AM_CPPFLAGS = -I. -I.. -I$(srcdir)/.. \ 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 @@ -64,10 +63,9 @@ SUFFIXES += .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 diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index a9f7cdc6d..1b2fa5650 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -1,6 +1,6 @@ ;;;; 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 @@ -40,7 +40,7 @@ ;;; 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 diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 68c8e60c5..aac6e18c2 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -1,6 +1,7 @@ /* 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 @@ -247,12 +248,7 @@ internal_readline (SCM text) 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; diff --git a/libguile.h b/libguile.h index fefca435b..b067b28a5 100644 --- a/libguile.h +++ b/libguile.h @@ -1,7 +1,7 @@ #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 @@ -54,7 +54,6 @@ extern "C" { #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" @@ -116,7 +115,9 @@ extern "C" { #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" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index dcbdba12a..3f66d9d8d 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -134,6 +134,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ debug.c \ deprecated.c \ deprecation.c \ + dynstack.c \ dynwind.c \ eq.c \ error.c \ @@ -150,7 +151,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ frames.c \ gc-malloc.c \ gc.c \ - gdbint.c \ gettext.c \ generalized-arrays.c \ generalized-vectors.c \ @@ -168,13 +168,13 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ 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 \ @@ -220,7 +220,9 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ version.c \ vm.c \ vports.c \ - weaks.c + weak-set.c \ + weak-table.c \ + weak-vector.c DOT_X_FILES = \ alist.x \ @@ -252,6 +254,7 @@ DOT_X_FILES = \ fluids.x \ foreign.x \ fports.x \ + frames.x \ gc-malloc.x \ gc.x \ gettext.x \ @@ -265,10 +268,12 @@ DOT_X_FILES = \ hooks.x \ i18n.x \ init.x \ + instructions.x \ ioext.x \ keywords.x \ list.x \ load.x \ + loader.x \ macros.x \ mallocs.x \ memoize.x \ @@ -281,6 +286,7 @@ DOT_X_FILES = \ print.x \ procprop.x \ procs.x \ + programs.x \ promises.x \ r6rs-ports.x \ random.x \ @@ -315,11 +321,11 @@ DOT_X_FILES = \ 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@ @@ -417,18 +423,24 @@ DOT_DOC_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. @@ -453,13 +465,14 @@ install-exec-hook: ## 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@ @@ -529,6 +542,7 @@ modinclude_HEADERS = \ deprecated.h \ deprecation.h \ dynl.h \ + dynstack.h \ dynwind.h \ eq.h \ error.h \ @@ -544,8 +558,6 @@ modinclude_HEADERS = \ fports.h \ frames.h \ gc.h \ - gdb_interface.h \ - gdbint.h \ gettext.h \ generalized-arrays.h \ generalized-vectors.h \ @@ -564,6 +576,7 @@ modinclude_HEADERS = \ keywords.h \ list.h \ load.h \ + loader.h \ macros.h \ mallocs.h \ memoize.h \ @@ -571,7 +584,6 @@ modinclude_HEADERS = \ net_db.h \ null-threads.h \ numbers.h \ - objcodes.h \ objprop.h \ options.h \ pairs.h \ @@ -621,11 +633,13 @@ modinclude_HEADERS = \ 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 @@ -708,8 +722,7 @@ load.x: libpath.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) @@ -783,7 +796,6 @@ chknew-E chknew-SIG: \ 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 diff --git a/libguile/__scm.h b/libguile/__scm.h index a0b02b685..31e395285 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -146,37 +146,6 @@ #endif -/* {Supported Options} - * - * These may be defined or undefined. - */ - -/* #define GUILE_DEBUG_FREELIST */ - - -/* Use engineering notation when converting numbers strings? - */ -#undef ENGNOT - - -/* {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 - - - -/* Random options (not yet supported or in final form). */ - -#define STACK_CHECKING -#undef NO_CEVAL_STACK_CHECKING - - /* SCM_API is a macro prepended to all function and data definitions which should be exported from libguile. */ @@ -279,14 +248,6 @@ #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, @@ -296,13 +257,6 @@ #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. @@ -345,22 +299,6 @@ #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 - /* {Feature Options} @@ -456,12 +394,6 @@ #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) @@ -470,10 +402,6 @@ #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) - #include "libguile/tags.h" @@ -492,64 +420,35 @@ typedef void *scm_t_subr; #endif -#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 -# 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 -# include - 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 -# 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 +# include +typedef struct { + ucontext_t ctx; + int fresh; +} scm_i_jmp_buf; + #else -# define SCM_FLUSH_REGISTER_WINDOWS /* empty */ +# include +typedef jmp_buf scm_i_jmp_buf; #endif + + + /* If stack is not longword aligned then */ @@ -575,147 +474,14 @@ typedef long SCM_STACKITEM; #define SCM_STACK_PTR(ptr) ((SCM_STACKITEM *) (void *) (ptr)) -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) - -/** 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 @@ -738,27 +504,6 @@ SCM_API SCM scm_apply_generic (SCM gf, SCM args); -/* 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 ). - */ - -#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. diff --git a/libguile/_scm.h b/libguile/_scm.h index a5c2ba800..429861233 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -190,12 +190,69 @@ #define scm_to_off64_t scm_to_int64 #define scm_from_off64_t scm_from_int64 + + + +#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 + + + +#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) + + + + #if (defined __GNUC__) # define SCM_NOINLINE __attribute__ ((__noinline__)) #else # define SCM_NOINLINE /* noinline */ #endif + + /* The endianness marker in objcode. */ #ifdef WORDS_BIGENDIAN # define SCM_OBJCODE_ENDIANNESS "BE" @@ -210,8 +267,8 @@ #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 \ @@ -221,13 +278,6 @@ #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 */ /* diff --git a/libguile/alist.c b/libguile/alist.c index f33aa4146..82c70a03c 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -1,4 +1,4 @@ -/* 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 @@ -40,9 +40,7 @@ SCM_DEFINE (scm_acons, "acons", 3, 0, 0, "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 diff --git a/libguile/arbiters.c b/libguile/arbiters.c index 5923c718a..831e0a230 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -1,4 +1,4 @@ -/* 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 @@ -89,11 +89,11 @@ static scm_t_bits scm_tc16_arbiter; static int arbiter_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts ("#', port); + scm_putc_unlocked ('>', port); return !0; } diff --git a/libguile/array-handle.c b/libguile/array-handle.c index 08778f369..62d8520f3 100644 --- a/libguile/array-handle.c +++ b/libguile/array-handle.c @@ -1,4 +1,5 @@ -/* 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 @@ -173,7 +174,7 @@ void 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); diff --git a/libguile/array-map.c b/libguile/array-map.c index 1c443ac47..e47fb5641 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -1,6 +1,6 @@ /* 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 @@ -100,7 +100,7 @@ scm_ra_matchp (SCM ra0, SCM ras) else return 0; - while (SCM_NIMP (ras)) + while (scm_is_pair (ras)) { ra1 = SCM_CAR (ras); @@ -205,7 +205,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) } 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); @@ -263,7 +263,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) } 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); @@ -296,7 +296,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) { 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; diff --git a/libguile/arrays.c b/libguile/arrays.c index 1eb10b981..98c8075e9 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -1,5 +1,5 @@ /* 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 @@ -242,8 +242,9 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, } 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 @@ -472,7 +473,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, 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)) { @@ -727,15 +728,15 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, 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; } @@ -752,7 +753,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) 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) @@ -773,12 +774,12 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) { 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); } @@ -806,9 +807,9 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) 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 diff --git a/libguile/async.c b/libguile/async.c index 66f0b04cd..80f561d10 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,4 +1,4 @@ -/* 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 @@ -22,8 +22,6 @@ # include #endif -#define SCM_BUILDING_DEPRECATED_CODE - #include "libguile/_scm.h" #include "libguile/eval.h" #include "libguile/throw.h" @@ -139,7 +137,7 @@ static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; /* System asyncs. */ void -scm_async_click () +scm_async_tick (void) { scm_i_thread *t = SCM_I_CURRENT_THREAD; SCM asyncs; @@ -170,23 +168,6 @@ scm_async_click () } } -#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) { @@ -341,47 +322,6 @@ SCM_DEFINE (scm_noop, "noop", 0, 0, 1, -#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) { @@ -394,7 +334,7 @@ decrease_block (void *data) { scm_i_thread *t = data; if (--t->block_asyncs == 0) - scm_async_click (); + scm_async_tick (); } void @@ -504,12 +444,6 @@ scm_critical_section_end (void) SCM_CRITICAL_SECTION_END; } -void -scm_async_tick (void) -{ - SCM_ASYNC_TICK; -} - void diff --git a/libguile/async.h b/libguile/async.h index ceb2b960b..68952b055 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -3,7 +3,7 @@ #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 @@ -29,7 +29,7 @@ -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); @@ -75,7 +75,7 @@ SCM_API void scm_critical_section_end (void); 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) #else /* !BUILDING_LIBGUILE */ @@ -87,14 +87,6 @@ SCM_API void scm_critical_section_end (void); 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 */ /* diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 7dd66ad2e..11a0cb1ee 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -59,9 +59,9 @@ static SCM 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; } @@ -220,14 +220,14 @@ indent (int n, SCM port) { 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; @@ -236,7 +236,7 @@ display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, S { 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 { @@ -341,19 +341,19 @@ display_backtrace_file (frame, last_file, port, pstate) *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 @@ -368,9 +368,9 @@ display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate) if (scm_is_false (file)) { if (scm_is_false (line)) - scm_putc ('?', port); + scm_putc_unlocked ('?', port); else - scm_puts ("", port); + scm_puts_unlocked ("", port); } else { @@ -385,7 +385,7 @@ display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate) pstate -> writingp = 1; } - scm_putc (':', port); + scm_putc_unlocked (':', port); } else if (scm_is_true (line)) { @@ -396,10 +396,10 @@ display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate) } 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 @@ -426,7 +426,7 @@ display_frame (SCM frame, int n, int nfield, int indentation, /* 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 { @@ -524,9 +524,9 @@ display_backtrace_body (struct display_backtrace_args *a) 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; @@ -557,7 +557,7 @@ SCM_DEFINE (scm_display_backtrace_with_highlights, "display-backtrace", 2, 3, 0, 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; } @@ -587,7 +587,7 @@ SCM_DEFINE (scm_backtrace_with_highlights, "backtrace", 0, 1, 0, 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); diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index 01584906c..2eef1dc56 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011, 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 @@ -39,8 +39,8 @@ */ #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) @@ -50,12 +50,12 @@ 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; @@ -110,7 +110,7 @@ scm_c_make_bitvector (size_t len, SCM fill) 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); diff --git a/libguile/boolean.c b/libguile/boolean.c index 3bf672d6d..f8c773839 100644 --- a/libguile/boolean.c +++ b/libguile/boolean.c @@ -62,6 +62,14 @@ SCM_DEFINE (scm_not, "not", 1, 0, 0, } #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), diff --git a/libguile/boolean.h b/libguile/boolean.h index 8f55f1ee5..df72728ef 100644 --- a/libguile/boolean.h +++ b/libguile/boolean.h @@ -3,7 +3,7 @@ #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 @@ -126,6 +126,7 @@ SCM_API int scm_to_bool (SCM x); 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); diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index be8b654cb..064c427ed 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -1,4 +1,4 @@ -/* 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 @@ -192,6 +192,9 @@ 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) \ @@ -209,7 +212,7 @@ make_bytevector (size_t len, scm_t_array_element_type element_type) 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 (); @@ -225,13 +228,14 @@ make_bytevector (size_t len, scm_t_array_element_type element_type) 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; @@ -252,7 +256,7 @@ make_bytevector_from_buffer (size_t len, void *contents, { 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); @@ -261,6 +265,7 @@ make_bytevector_from_buffer (size_t len, void *contents, 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; @@ -281,19 +286,31 @@ scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type) return make_bytevector (len, element_type); } -/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to - by CONTENTS must have been allocated using `scm_gc_malloc ()'. */ +/* 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 @@ -397,17 +414,17 @@ scm_i_print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED) 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; } @@ -632,8 +649,9 @@ SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector", 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); @@ -1102,7 +1120,11 @@ SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0, 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 \ { \ @@ -2009,8 +2031,7 @@ SCM_DEFINE (scm_string_to_utf32, "string->utf32", 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); @@ -2031,8 +2052,7 @@ SCM_DEFINE (scm_utf8_to_string, "utf8->string", 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); } diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index 8bafff3a3..a5eeaea0c 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -28,12 +28,14 @@ /* 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; @@ -115,7 +117,7 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM); /* 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) \ @@ -132,13 +134,13 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM); 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 *); diff --git a/libguile/chars.c b/libguile/chars.c index 2e1610566..fbedb0fe2 100644 --- a/libguile/chars.c +++ b/libguile/chars.c @@ -1,4 +1,4 @@ -/* 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 @@ -492,7 +492,7 @@ SCM_DEFINE (scm_char_general_category, "char-general-category", 1, 0, 0, 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 diff --git a/libguile/continuations.c b/libguile/continuations.c index d9912783d..1d677610b 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -1,4 +1,4 @@ -/* 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 @@ -24,6 +24,7 @@ #include "libguile/_scm.h" +#include #include #include @@ -33,7 +34,7 @@ #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" @@ -52,113 +53,31 @@ static scm_t_bits tc16_continuation; #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) -/* 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; } @@ -173,20 +92,31 @@ continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED) { scm_t_contregs *continuation = SCM_CONTREGS (obj); - scm_puts ("#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; @@ -200,7 +130,6 @@ scm_i_make_continuation (int *first, SCM vm, SCM vm_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 @@ -208,7 +137,7 @@ scm_i_make_continuation (int *first, SCM vm, SCM vm_cont) #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); @@ -236,43 +165,31 @@ scm_i_make_continuation (int *first, SCM vm, SCM vm_cont) } #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 @@ -323,33 +240,25 @@ grow_stack (SCM cont) * 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); } @@ -486,7 +395,7 @@ print_exception_and_backtrace (SCM port, SCM tag, SCM args) 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); @@ -531,7 +440,7 @@ pre_unwind_handler (void *error_port, SCM tag, SCM args) { /* 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; } @@ -545,7 +454,7 @@ scm_c_with_continuation_barrier (void *(*func) (void *), void *data) 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; } @@ -589,7 +498,7 @@ SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0, 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 diff --git a/libguile/continuations.h b/libguile/continuations.h index e0a455632..7d5e0dbc5 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -3,7 +3,7 @@ #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 @@ -45,14 +45,13 @@ 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 @@ -71,14 +70,14 @@ typedef struct -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 *); diff --git a/libguile/control.c b/libguile/control.c dissimilarity index 76% index f8d2d60ae..347d69715 100644 --- a/libguile/control.c +++ b/libguile/control.c @@ -1,286 +1,221 @@ -/* 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 -#endif - -#include - -#include "libguile/_scm.h" -#include "libguile/control.h" -#include "libguile/objcodes.h" -#include "libguile/instructions.h" -#include "libguile/vm.h" - - - - -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 ("#', 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 +#endif + +#include + +#include "libguile/_scm.h" +#include "libguile/control.h" +#include "libguile/programs.h" +#include "libguile/instructions.h" +#include "libguile/vm.h" + + + +#define PROMPT_ESCAPE_P(p) \ + (SCM_DYNSTACK_TAG_FLAGS (SCM_DYNSTACK_TAG (p)) \ + & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY) + + + + +/* 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: +*/ diff --git a/libguile/control.h b/libguile/control.h dissimilarity index 60% index 2167ffa08..4b76591aa 100644 --- a/libguile/control.h +++ b/libguile/control.h @@ -1,60 +1,35 @@ -/* 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 */ diff --git a/libguile/debug.c b/libguile/debug.c index 9e6328b3a..9e63f2c67 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -1,5 +1,5 @@ /* 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 @@ -108,61 +108,13 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, 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 - -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 - diff --git a/libguile/debug.h b/libguile/debug.h index 4155d1981..e535a6a79 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -3,7 +3,7 @@ #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 @@ -44,8 +44,6 @@ typedef union scm_t_debug_info 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); @@ -54,18 +52,6 @@ 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 */ /* diff --git a/libguile/deprecated.c b/libguile/deprecated.c dissimilarity index 97% index 600b984a7..8de28ada0 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -1,2950 +1,87 @@ -/* 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 -#endif - -#include -#include -#include - -#include - -#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[] = -{ - "#@" -}; - - -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{#}).\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); -} - - -/* 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 */ - - -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); -} - - -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 - - -/* 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 - - -/* 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); -} - - - -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 - - - - - -SCM -scm_raequal (SCM ra0, SCM ra1) -{ - return scm_array_equal_p (ra0, ra1); -} - - - - - -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 - - - - - -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; -} - - - -/* 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); -} - - - -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 */ - - - -#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 */ - - - -/* {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 - - - -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); -} - - - -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)); -} - - - -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; -} - - - -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); -} - - - - -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; -} - - - - - -/* 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 - - - - -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 - - - - -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 - - - - -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); -} - - - - -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 +#endif + +#define SCM_BUILDING_DEPRECATED_CODE + +#include "libguile/_scm.h" +#include "libguile/deprecation.h" + +#if (SCM_ENABLE_DEPRECATED == 1) + + + +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; +} + + + +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); +} + + + + +void +scm_i_init_deprecated () +{ +#include "libguile/deprecated.x" +} + +#endif diff --git a/libguile/deprecated.h b/libguile/deprecated.h dissimilarity index 91% index 6c7bfcc53..d02fc7976 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -1,868 +1,153 @@ -/* 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) "#@" - - -/* 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); - - -/* 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 - - - -/* 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); - - - -/* 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) - - - -/* 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)) - - - -/* 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); - - - -/* 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); - - - -/* 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 - -/* Deprecated because the cuserid call is deprecated. - */ -SCM_DEPRECATED SCM scm_cuserid (void); - - - -/* 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); - - - -/* {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); - - - - -/* 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); - - - - -/* 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); - - - -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) - - - -/* 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); - - - -/* 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); - - - -SCM_DEPRECATED SCM scm_struct_vtable_tag (SCM handle); - - - -#ifdef UCHAR_MAX -# define SCM_CHAR_CODE_LIMIT (UCHAR_MAX + 1L) -#else -# define SCM_CHAR_CODE_LIMIT 256L -#endif - - - -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); - - - -SCM_DEPRECATED SCM scm_c_program_source (SCM program, size_t ip); - - - -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 + + + + +/* 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); + + + +void scm_i_init_deprecated (void); + +#endif + +#endif /* SCM_DEPRECATED_H */ diff --git a/libguile/deprecation.c b/libguile/deprecation.c index aa50eaf8c..1be3aea7e 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -83,7 +83,7 @@ scm_c_issue_deprecation_warning (const char *msg) 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 ()); } } diff --git a/libguile/dynl.c b/libguile/dynl.c index 0061234e8..79198e64c 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -229,11 +229,11 @@ scm_t_bits scm_tc16_dynamic_obj; static int dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts ("#', port); + scm_puts_unlocked (" (unlinked)", port); + scm_putc_unlocked ('>', port); return 1; } diff --git a/libguile/dynstack.c b/libguile/dynstack.c new file mode 100644 index 000000000..9235ec495 --- /dev/null +++ b/libguile/dynstack.c @@ -0,0 +1,549 @@ +/* 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 + */ + + + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#include "libguile/_scm.h" +#include "libguile/control.h" +#include "libguile/eval.h" +#include "libguile/fluids.h" +#include "libguile/dynstack.h" + + + + +#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])) + + + + +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: +*/ diff --git a/libguile/dynstack.h b/libguile/dynstack.h new file mode 100644 index 000000000..7b31acedf --- /dev/null +++ b/libguile/dynstack.h @@ -0,0 +1,210 @@ +/* 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 + */ + + + +#include "libguile/__scm.h" + + + +typedef struct +{ + scm_t_bits *base; + scm_t_bits *top; + scm_t_bits *limit; +} scm_t_dynstack; + + + +/* 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 *); + + + + +/* 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 *); + + + + +/* 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 *); + + + + +/* 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: +*/ diff --git a/libguile/dynwind.c b/libguile/dynwind.c dissimilarity index 70% index 14dd861dc..4a0b0dd2b 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -1,307 +1,144 @@ -/* 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 - */ - - - - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include - -#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" - - -/* {Dynamic wind} - - Things that can be on the wind list: - - # - # - # - # - (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 # 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 + */ + + + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#include "libguile/_scm.h" +#include "libguile/dynstack.h" +#include "libguile/eval.h" +#include "libguile/ports.h" + +#include "libguile/dynwind.h" + + + + +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: +*/ diff --git a/libguile/dynwind.h b/libguile/dynwind.h index 6e952c4db..9ade05c0b 100644 --- a/libguile/dynwind.h +++ b/libguile/dynwind.h @@ -3,7 +3,7 @@ #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 @@ -24,25 +24,22 @@ #include "libguile/__scm.h" +#include "libguile/dynstack.h" -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); @@ -60,9 +57,6 @@ SCM_API void scm_dynwind_rewind_handler_with_scm (void (*func) (SCM), SCM data, 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 */ diff --git a/libguile/elf.h b/libguile/elf.h new file mode 100644 index 000000000..9d537215b --- /dev/null +++ b/libguile/elf.h @@ -0,0 +1,2794 @@ +/* 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 + +/* 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 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 */ diff --git a/libguile/eq.c b/libguile/eq.c index 02ce0a9b5..5a6f574d2 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -372,7 +372,7 @@ scm_equal_p (SCM x, SCM y) 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; } diff --git a/libguile/error.h b/libguile/error.h index 8cc68b752..1611fd529 100644 --- a/libguile/error.h +++ b/libguile/error.h @@ -3,7 +3,7 @@ #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 @@ -36,6 +36,16 @@ SCM_API SCM scm_misc_error_key; +#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) + + + + 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, diff --git a/libguile/eval.c b/libguile/eval.c index 6047d6d75..3e828a178 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,4 +1,5 @@ -/* 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 @@ -39,7 +40,6 @@ #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" @@ -153,6 +153,48 @@ static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc, #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"); @@ -203,18 +245,6 @@ truncate_values (SCM x) } #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) { @@ -224,16 +254,13 @@ 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: @@ -246,17 +273,19 @@ eval (SCM x, SCM env) 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; @@ -265,41 +294,8 @@ eval (SCM x, SCM env) 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. */ @@ -316,7 +312,7 @@ eval (SCM x, SCM env) goto loop; } else - return scm_call_with_vm (scm_the_vm (), proc, args); + return scm_apply_0 (proc, args); case SCM_M_CALL: /* Evaluate the procedure to be applied. */ @@ -338,7 +334,7 @@ eval (SCM x, SCM env) 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: @@ -352,7 +348,7 @@ eval (SCM x, SCM env) 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 @@ -362,11 +358,15 @@ eval (SCM x, SCM env) 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 */ @@ -376,11 +376,16 @@ eval (SCM x, SCM env) 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; } @@ -389,10 +394,8 @@ eval (SCM x, SCM env) 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: @@ -406,11 +409,8 @@ eval (SCM x, SCM env) } 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; } } @@ -436,31 +436,40 @@ eval (SCM x, SCM env) 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; } @@ -477,41 +486,41 @@ eval (SCM x, SCM env) 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 @@ -519,7 +528,7 @@ scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, 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 @@ -527,7 +536,7 @@ scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, 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 @@ -535,7 +544,7 @@ scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, 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 @@ -543,14 +552,10 @@ scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, 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, ...) @@ -570,7 +575,7 @@ 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 @@ -579,68 +584,41 @@ scm_call (SCM proc, ...) 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 @@ -652,8 +630,8 @@ scm_map (SCM proc, SCM arg1, SCM args) 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 @@ -665,8 +643,8 @@ scm_for_each (SCM proc, SCM arg1, SCM args) 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))); } @@ -675,15 +653,15 @@ scm_c_primitive_eval (SCM exp) { 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); } @@ -728,24 +706,18 @@ static SCM f_apply; /* Apply a function to a list of arguments. - This function is exported to the Scheme level as taking two - required arguments and a tail argument, as if it were: + 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 @@ -754,15 +726,18 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, { 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; } @@ -770,15 +745,18 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, { 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); @@ -806,25 +784,46 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, 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 { @@ -833,45 +832,27 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, 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)) @@ -882,10 +863,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, 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; } @@ -897,15 +875,17 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, /* Now fill in unbound values, evaluating init expressions in their appropriate environment. */ - for (i = imax - kw_start_idx; scm_is_pair (inits); i--, inits = CDR (inits)) - { - SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i)); - if (SCM_UNBNDP (CAR (tail))) - SCM_SETCAR (tail, EVAL1 (CAR (inits), CDR (tail))); - } + 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; } @@ -917,32 +897,32 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc, { 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; } @@ -968,16 +948,16 @@ static int boot_closure_print (SCM closure, SCM port, scm_print_state *pstate) { SCM args; - scm_puts ("#', port); + scm_putc_unlocked ('>', port); return 1; } diff --git a/libguile/evalext.c b/libguile/evalext.c index c1d46b56d..48a9eff3c 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -1,4 +1,4 @@ -/* 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 @@ -76,11 +76,11 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, 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: diff --git a/libguile/evalext.h b/libguile/evalext.h index fc3f1e617..7718ec621 100644 --- a/libguile/evalext.h +++ b/libguile/evalext.h @@ -3,7 +3,7 @@ #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 @@ -31,12 +31,6 @@ SCM_API SCM scm_defined_p (SCM sym, SCM env); 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 */ /* diff --git a/libguile/expand.c b/libguile/expand.c index cae552086..7d6a6ed32 100644 --- a/libguile/expand.c +++ b/libguile/expand.c @@ -1,4 +1,4 @@ -/* 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 @@ -56,8 +56,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES]; SCM_MAKE_EXPANDED_VOID(src) #define CONST_(src, exp) \ SCM_MAKE_EXPANDED_CONST(src, exp) -#define PRIMITIVE_REF_TYPE(src, name) \ - SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name) +#define PRIMITIVE_REF(src, name) \ + SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name) #define LEXICAL_REF(src, name, gensym) \ SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym) #define LEXICAL_SET(src, name, gensym, exp) \ @@ -74,10 +74,12 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES]; 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) \ @@ -86,8 +88,6 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES]; 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) @@ -153,7 +153,6 @@ SCM_SYNTAX ("@", expand_at); 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); @@ -174,19 +173,13 @@ SCM_SYNTAX ("case-lambda", expand_case_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"); @@ -195,12 +188,13 @@ SCM_GLOBAL_SYMBOL (scm_sym_let, "let"); SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec"); SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*"); SCM_GLOBAL_SYMBOL (scm_sym_or, "or"); -SCM_GLOBAL_SYMBOL (scm_sym_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"); @@ -356,17 +350,22 @@ expand (SCM exp, SCM env) { 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)) @@ -399,7 +398,9 @@ expand_sequence (const SCM forms, const SCM env) 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)); } @@ -421,9 +422,12 @@ static SCM 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); } @@ -490,10 +494,10 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env) 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 */ @@ -555,30 +559,6 @@ expand_define (SCM expr, SCM env) 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) { @@ -996,9 +976,9 @@ expand_named_let (const 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 @@ -1215,13 +1195,13 @@ make_exp_vtable (size_t n) (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, @@ -1246,13 +1226,13 @@ scm_init_expand () 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"), diff --git a/libguile/expand.h b/libguile/expand.h index 02e6e179e..8a578ae54 100644 --- a/libguile/expand.h +++ b/libguile/expand.h @@ -3,7 +3,7 @@ #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 @@ -47,13 +47,13 @@ typedef enum 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; @@ -228,30 +228,44 @@ enum #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 \ @@ -316,20 +330,6 @@ enum #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 */ diff --git a/libguile/feature.c b/libguile/feature.c index 464697508..9eb82ee7d 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -45,7 +45,7 @@ void scm_add_feature (const char *str) { SCM old = SCM_VARIABLE_REF (features_var); - SCM new = scm_cons (scm_from_locale_symbol (str), old); + SCM new = scm_cons (scm_from_utf8_symbol (str), old); SCM_VARIABLE_SET (features_var, new); } @@ -110,15 +110,9 @@ scm_init_feature() #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 diff --git a/libguile/filesys.c b/libguile/filesys.c index 5f6208d82..8597f9096 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -44,7 +44,6 @@ #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" @@ -141,6 +140,10 @@ 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)) + #ifdef HAVE_POSIX @@ -982,7 +985,7 @@ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0, if (SCM_OPFPORTP (object)) { - scm_flush (object); + scm_flush_unlocked (object); fdes = SCM_FPORT_FDES (object); } else @@ -1192,7 +1195,7 @@ SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0, { 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) { @@ -1743,11 +1746,11 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, 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 @@ -1761,15 +1764,15 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, 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; @@ -1849,12 +1852,12 @@ SCM_DEFINE (scm_closedir, "closedir", 1, 0, 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; } diff --git a/libguile/filesys.h b/libguile/filesys.h index 776b263cc..fc66e40b2 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -4,7 +4,7 @@ #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 @@ -32,7 +32,7 @@ SCM_API scm_t_bits scm_tc16_dir; #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) diff --git a/libguile/finalizers.c b/libguile/finalizers.c index a179479f5..eaea1392f 100644 --- a/libguile/finalizers.c +++ b/libguile/finalizers.c @@ -1,4 +1,4 @@ -/* 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 @@ -23,6 +23,13 @@ # include #endif +#ifdef HAVE_UNISTD_H +#include +#endif +#include + +#include + #include "libguile/bdw-gc.h" #include "libguile/_scm.h" #include "libguile/finalizers.h" @@ -161,13 +168,194 @@ queue_finalizer_async (void) -#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 */ + + + + +void +scm_i_finalizer_pre_fork (void) +{ +#if SCM_USE_PTHREAD_THREADS + stop_finalization_thread (); + GC_set_finalizer_notifier (spawn_finalizer_thread); #endif +} + + + + +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); +} + + + void scm_init_finalizers (void) @@ -180,3 +368,13 @@ 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 +} diff --git a/libguile/finalizers.h b/libguile/finalizers.h index bad96e145..2ef075197 100644 --- a/libguile/finalizers.h +++ b/libguile/finalizers.h @@ -1,7 +1,7 @@ #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 @@ -34,6 +34,14 @@ SCM_INTERNAL void scm_i_add_finalizer (void *obj, scm_t_finalizer_proc, 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 */ diff --git a/libguile/fluids.c b/libguile/fluids.c index 327d12f4c..4e0684af8 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -21,7 +21,6 @@ # include #endif -#include #include #include @@ -80,25 +79,17 @@ grow_dynamic_state (SCM state) void scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts ("#', port); + scm_putc_unlocked ('>', port); } void scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts ("#', port); -} - -void -scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) -{ - scm_puts ("#', port); + scm_putc_unlocked ('>', port); } @@ -125,7 +116,7 @@ new_fluid (SCM init) 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 @@ -157,7 +148,7 @@ new_fluid (SCM init) 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], @@ -311,79 +302,27 @@ apply_thunk (void *thunk) 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, @@ -403,63 +342,51 @@ SCM 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; } diff --git a/libguile/fluids.h b/libguile/fluids.h index 2b91ff3d1..a550d9a34 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -3,7 +3,7 @@ #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 @@ -27,17 +27,6 @@ #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. @@ -54,7 +43,7 @@ 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)) @@ -70,8 +59,7 @@ SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value); 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); @@ -83,7 +71,7 @@ SCM_API SCM scm_with_fluid (SCM fluid, SCM val, SCM thunk); 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 @@ -101,7 +89,6 @@ SCM_INTERNAL SCM scm_i_make_initial_dynamic_state (void); SCM_INTERNAL void scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate); SCM_INTERNAL void scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate); -SCM_INTERNAL void scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate); SCM_INTERNAL void scm_init_fluids (void); #endif /* SCM_FLUIDS_H */ diff --git a/libguile/foreign.c b/libguile/foreign.c index 01af90019..5ee225da4 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -65,16 +65,6 @@ SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error"); /* The cell representing the null pointer. */ static SCM null_pointer; -#if SIZEOF_VOID_P == 4 -# define scm_to_uintptr scm_to_uint32 -# define scm_from_uintptr scm_from_uint32 -#elif SIZEOF_VOID_P == 8 -# define scm_to_uintptr scm_to_uint64 -# define scm_from_uintptr scm_from_uint64 -#else -# error unsupported pointer size -#endif - /* Raise a null pointer dereference error. */ static void @@ -89,22 +79,19 @@ static SCM cif_to_procedure (SCM cif, SCM func_ptr); 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, @@ -128,7 +115,7 @@ SCM_DEFINE (scm_make_pointer, "make-pointer", 1, 1, 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 @@ -176,7 +163,7 @@ SCM_DEFINE (scm_pointer_address, "pointer-address", 1, 0, 0, { 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 @@ -201,7 +188,7 @@ SCM_DEFINE (scm_scm_to_pointer, "scm->pointer", 1, 0, 0, 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; @@ -273,8 +260,8 @@ SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0, 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 @@ -326,9 +313,9 @@ SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0, void scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate) { - scm_puts ("#', port); + scm_puts_unlocked ("#', port); } @@ -547,13 +534,14 @@ SCM_DEFINE (scm_sizeof, "sizeof", 1, 0, 0, (SCM type), { /* 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); @@ -775,182 +763,68 @@ SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0, -/* 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; } @@ -1171,7 +1045,7 @@ invoke_closure (ffi_cif *cif, void *ret, void **args, void *data) size_t i; SCM proc, *argv, result; - proc = PTR2SCM (data); + proc = SCM_PACK_POINTER (data); argv = alloca (cif->nargs * sizeof (*argv)); @@ -1202,7 +1076,7 @@ SCM_DEFINE (scm_procedure_to_pointer, "procedure->pointer", 3, 0, 0, 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) { @@ -1368,7 +1242,7 @@ scm_register_foreign (void) "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); } /* diff --git a/libguile/foreign.h b/libguile/foreign.h index 41c0b657d..fbb97640b 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -1,7 +1,7 @@ #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 @@ -48,8 +48,7 @@ typedef enum scm_t_foreign_type scm_t_foreign_type; typedef void (*scm_t_pointer_finalizer) (void *); -#define SCM_POINTER_P(x) \ - (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_pointer) +#define SCM_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) \ @@ -61,6 +60,8 @@ SCM_API SCM scm_from_pointer (void *, scm_t_pointer_finalizer); SCM_API SCM scm_alignof (SCM type); SCM_API SCM scm_sizeof (SCM type); SCM_API SCM scm_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); @@ -97,6 +98,8 @@ SCM_API SCM scm_pointer_to_procedure (SCM return_type, SCM func_ptr, 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); diff --git a/libguile/fports.c b/libguile/fports.c index 70732e5a0..dc3d45ce4 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -207,7 +207,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, ndrained = 0; if (SCM_OUTPUT_PORT_P (port)) - scm_flush (port); + scm_flush_unlocked (port); if (pt->read_buf == pt->putback_buf) { @@ -470,6 +470,8 @@ scm_open_file (SCM filename, SCM mode) 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" @@ -541,7 +543,7 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) #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 @@ -563,26 +565,21 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) 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 @@ -607,11 +604,108 @@ fport_input_waiting (SCM port) return pollfd.revents & POLLIN ? 1 : 0; } + + + +/* 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 + + 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)) { @@ -620,8 +714,8 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) 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) @@ -633,11 +727,11 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) } 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; } @@ -692,7 +786,7 @@ fport_seek (SCM port, scm_t_off offset, int whence) 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 @@ -826,32 +920,38 @@ fport_end_input (SCM port, int offset) 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 diff --git a/libguile/fports.h b/libguile/fports.h index c32ed9579..092b43ee8 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -3,7 +3,7 @@ #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 @@ -32,6 +32,9 @@ /* 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; @@ -39,7 +42,7 @@ 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)) @@ -56,6 +59,15 @@ SCM_API SCM scm_open_file_with_encoding (SCM filename, SCM modes, 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); + + +/* 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); + + SCM_INTERNAL void scm_init_fports_keywords (void); SCM_INTERNAL void scm_init_fports (void); diff --git a/libguile/frames.c b/libguile/frames.c index a7143c411..b0f451f7d 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -1,4 +1,4 @@ -/* 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 @@ -24,11 +24,12 @@ #include #include "_scm.h" #include "frames.h" +#include "vm.h" #include /* 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); @@ -36,30 +37,78 @@ verify (offsetof (struct scm_vm_frame, dynamic_link) == 0); (((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 ("#", 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 + /* Scheme interface */ @@ -104,81 +153,45 @@ SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0, "") #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 @@ -189,31 +202,21 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0, "") #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 @@ -224,7 +227,7 @@ SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0, #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 @@ -235,7 +238,7 @@ SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0, { 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 @@ -244,18 +247,9 @@ SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0, "") #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 @@ -265,21 +259,8 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0, #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 @@ -290,8 +271,8 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, { 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)))); } @@ -312,12 +293,13 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, 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)) diff --git a/libguile/frames.h b/libguile/frames.h index eaed79d43..e48bb48e6 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -1,4 +1,4 @@ -/* 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 @@ -23,106 +23,156 @@ #include "programs.h" -/* - * 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. */ + + /* 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)) /* * 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); @@ -134,7 +184,6 @@ SCM_API SCM scm_frame_address (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); diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index 2aff4c31a..63e670564 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -1,5 +1,5 @@ /* 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 @@ -45,7 +45,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/root.h" #include "libguile/strings.h" #include "libguile/vectors.h" -#include "libguile/weaks.h" #include "libguile/hashtab.h" #include "libguile/tags.h" @@ -53,8 +52,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/deprecation.h" #include "libguile/gc.h" -#include "libguile/private-gc.h" - #ifdef GUILE_DEBUG_MALLOC #include "libguile/debug-malloc.h" #endif @@ -135,11 +132,7 @@ scm_realloc (void *mem, size_t size) 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) @@ -265,102 +258,3 @@ scm_gc_strdup (const char *str, const char *what) { 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 */ diff --git a/libguile/gc.c b/libguile/gc.c index 6e459c3f9..d13d89b72 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -23,8 +23,6 @@ # include #endif -#define SCM_BUILDING_DEPRECATED_CODE - #include "libguile/gen-scmconfig.h" #include @@ -48,13 +46,12 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #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" @@ -73,6 +70,12 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include #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; @@ -83,14 +86,10 @@ int scm_expensive_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) @@ -195,35 +194,6 @@ SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, -/* 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 - - /* Hooks. */ scm_t_c_hook scm_before_gc_c_hook; scm_t_c_hook scm_before_mark_c_hook; @@ -267,6 +237,7 @@ SCM_SYMBOL (sym_times, "gc-times"); /* {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) { @@ -318,13 +289,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, 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)), @@ -408,9 +373,6 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0, void scm_i_gc (const char *what) { -#ifndef HAVE_GC_SET_START_CALLBACK - run_before_gc_c_hook (); -#endif GC_gcollect (); } @@ -606,43 +568,10 @@ scm_gc_unregister_roots (SCM *b, unsigned long n) -/* - 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; @@ -652,14 +581,7 @@ scm_storage_prehistory () 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 @@ -821,7 +743,7 @@ get_image_size (void) } /* 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, @@ -966,7 +888,7 @@ scm_gc_register_allocation (size_t size) -char const * +static char const * scm_i_tag_name (scm_t_bits tag) { switch (tag & 0x7f) /* 7 bits */ @@ -981,16 +903,16 @@ scm_i_tag_name (scm_t_bits tag) 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: @@ -1061,19 +983,11 @@ scm_init_gc () scm_c_hook_add (&scm_before_gc_c_hook, start_gc_timer, NULL, 0); scm_c_hook_add (&scm_after_gc_c_hook, accumulate_gc_timer, NULL, 0); -#if HAVE_GC_GET_HEAP_USAGE_SAFE /* GC_get_heap_usage does not take a lock, and so can run in the GC start hook. */ scm_c_hook_add (&scm_before_gc_c_hook, adjust_gc_frequency, NULL, 0); -#else - /* GC_get_heap_usage might take a lock (and did from 7.2alpha1 to - 7.2alpha7), so call it in the after_gc_hook. */ - scm_c_hook_add (&scm_after_gc_c_hook, adjust_gc_frequency, NULL, 0); -#endif -#ifdef HAVE_GC_SET_START_CALLBACK GC_set_start_callback (run_before_gc_c_hook); -#endif #include "libguile/gc.x" } diff --git a/libguile/gc.h b/libguile/gc.h index a9a499bca..085778118 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -4,7 +4,7 @@ #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 @@ -36,22 +36,9 @@ typedef struct scm_t_cell 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 @@ -139,20 +126,6 @@ void *scm_ia64_ar_bsp (const void *); -#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; @@ -223,14 +196,14 @@ SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what) 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 @@ -248,7 +221,7 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr, { 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 @@ -283,11 +256,11 @@ scm_double_cell (scm_t_bits car, scm_t_bits cbr, } 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? */ @@ -354,35 +327,10 @@ SCM_API void scm_gc_register_root (SCM *p); 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 */ /* diff --git a/libguile/gdb_interface.h b/libguile/gdb_interface.h deleted file mode 100644 index 2278fc2c2..000000000 --- a/libguile/gdb_interface.h +++ /dev/null @@ -1,154 +0,0 @@ -/* 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: -*/ diff --git a/libguile/gdbint.c b/libguile/gdbint.c deleted file mode 100644 index 7a0ebc985..000000000 --- a/libguile/gdbint.c +++ /dev/null @@ -1,266 +0,0 @@ -/* 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 -#endif - -#include "libguile/_scm.h" - -#include -#include -#ifdef HAVE_UNISTD_H -#include -#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" - -/* {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" - - - -/* 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: -*/ diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 2f6fa6e6a..11020cfb2 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -54,9 +54,9 @@ - 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 @@ -399,15 +399,6 @@ main (int argc, char *argv[]) #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"); diff --git a/libguile/goops.c b/libguile/goops.c index 9a4027714..013a65c14 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1,4 +1,4 @@ -/* 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 @@ -53,7 +53,6 @@ #include "libguile/strings.h" #include "libguile/strports.h" #include "libguile/vectors.h" -#include "libguile/weaks.h" #include "libguile/vm.h" #include "libguile/validate.h" @@ -85,13 +84,6 @@ SCM_SYMBOL (sym_change_class, "change-class"); 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 @@ -163,8 +155,6 @@ static SCM class_hashtable; 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; @@ -172,7 +162,6 @@ static SCM class_array; 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 @@ -200,17 +189,15 @@ scm_i_define_class_for_vtable (SCM vtable) { 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)) { @@ -229,9 +216,7 @@ scm_i_define_class_for_vtable (SCM vtable) /* 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; @@ -279,10 +264,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, 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: @@ -934,7 +915,6 @@ SCM_SYMBOL (sym_cpl, "cpl"); 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"); @@ -969,7 +949,6 @@ build_class_class_slots (void) 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); } @@ -1000,21 +979,21 @@ create_basic_classes (void) prep_hashsets (scm_class_class); - DEFVAR(name, scm_class_class); + scm_module_define (scm_module_goops, name, scm_class_class); /**** ****/ name = scm_from_latin1_symbol (""); 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); /**** ****/ name = scm_from_latin1_symbol (""); 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); /* and were partially initialized. Correct them here */ SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class)); @@ -1733,36 +1712,6 @@ SCM_KEYWORD (k_name, "name"); 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) @@ -1906,6 +1855,47 @@ setup_extended_primitive_generics () } } +/* 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 @@ -2367,12 +2357,12 @@ fix_cpl (SCM c, SCM before, SCM after) 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); } @@ -2519,10 +2509,6 @@ create_standard_classes (void) scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&class_frame, "", scm_class_class, scm_class_top, SCM_EOL); - make_stdcls (&class_objcode, "", - scm_class_class, scm_class_top, SCM_EOL); - make_stdcls (&class_vm, "", - scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&class_vm_cont, "", scm_class_class, scm_class_top, SCM_EOL); make_stdcls (&class_bytevector, "", @@ -2572,30 +2558,25 @@ create_standard_classes (void) 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 ("<"), @@ -2606,14 +2587,8 @@ make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep) 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 @@ -2721,7 +2696,7 @@ create_port_classes (void) { 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)); } @@ -2851,7 +2826,7 @@ scm_init_goops_builtins (void) 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; diff --git a/libguile/goops.h b/libguile/goops.h index 47a6e4eca..b3071b039 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -79,7 +79,6 @@ "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) @@ -99,11 +98,9 @@ #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; @@ -299,13 +296,14 @@ SCM_API SCM scm_make (SCM args); SCM_API SCM scm_find_method (SCM args); SCM_API SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs); SCM_API void scm_change_object_class (SCM, SCM, SCM); -/* The following are declared in __scm.h -SCM_API SCM scm_call_generic_0 (SCM gf); -SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1); -SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2); -SCM_API SCM scm_apply_generic (SCM gf, SCM args); -*/ -SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3); + +/* 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); diff --git a/libguile/gsubr.c b/libguile/gsubr.c dissimilarity index 85% index b6f261faf..650ea668b 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -1,889 +1,341 @@ -/* 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 - */ - - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include -#include - -#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" - -/* - * gsubr.c - * Provide `gsubrs' -- subrs taking a prescribed number of required, optional, - * and rest arguments. - */ - -/* #define GSUBR_TEST */ - - - -/* 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 + */ + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include +#include + +#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" + +/* + * gsubr.c + * Provide `gsubrs' -- subrs taking a prescribed number of required, optional, + * and rest arguments. + */ + + + +/* 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: +*/ diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 5adffa4fe..065b94766 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -4,7 +4,7 @@ #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 @@ -30,11 +30,6 @@ -SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq, - unsigned int nopt, - unsigned int rest); - - /* Subrs */ @@ -46,20 +41,22 @@ SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq, #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)) +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, diff --git a/libguile/guardians.c b/libguile/guardians.c index 6ba8c0b59..7619acf27 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -58,7 +58,6 @@ #include "libguile/validate.h" #include "libguile/root.h" #include "libguile/hashtab.h" -#include "libguile/weaks.h" #include "libguile/deprecation.h" #include "libguile/eval.h" @@ -88,16 +87,16 @@ guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED) { t_guardian *g = GUARDIAN_DATA (guardian); - scm_puts ("#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; } @@ -110,9 +109,9 @@ finalize_guarded (void *ptr, void *finalizer_data) 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", @@ -132,9 +131,12 @@ finalize_guarded (void *ptr, void *finalizer_data) 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 @@ -143,7 +145,7 @@ finalize_guarded (void *ptr, void *finalizer_data) continue; } - g = GUARDIAN_DATA (SCM_CAR (guardian_list)); + g = GUARDIAN_DATA (guardian); if (g->live == 0) abort (); @@ -167,8 +169,8 @@ finalize_guarded (void *ptr, void *finalizer_data) 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 (); @@ -192,7 +194,7 @@ scm_i_guard (SCM guardian, SCM obj) { 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 @@ -210,13 +212,15 @@ scm_i_guard (SCM guardian, SCM obj) 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) @@ -228,7 +232,7 @@ scm_i_guard (SCM guardian, SCM obj) 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 (); @@ -245,8 +249,8 @@ scm_i_guard (SCM guardian, SCM obj) `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); } } @@ -351,13 +355,7 @@ void 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); diff --git a/libguile/guile.c b/libguile/guile.c index 2c3be8e2f..f827d2642 100644 --- a/libguile/guile.c +++ b/libguile/guile.c @@ -43,11 +43,6 @@ #include #endif -/* Debugger interface (don't change the order of the following lines) */ -#define GDB_TYPE SCM -#include -GDB_INTERFACE; - static void inner_main (void *closure SCM_UNUSED, int argc, char **argv) { @@ -55,7 +50,6 @@ 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 */ @@ -86,11 +80,10 @@ get_integer_from_environment (const char *var, int def) 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 diff --git a/libguile/hash.c b/libguile/hash.c index 8b00a0cb1..740dac11f 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -1,6 +1,6 @@ /* 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 @@ -46,234 +46,320 @@ extern double floor(); #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)); } - } } - unsigned long scm_ihashq (SCM obj, unsigned long n) { - return (SCM_UNPACK (obj) >> 1) % n; + return scm_raw_ihashq (SCM_UNPACK (obj)) % n; } @@ -303,13 +389,10 @@ SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0, 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; } @@ -339,7 +422,7 @@ SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0, 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, diff --git a/libguile/hash.h b/libguile/hash.h index 307748617..d3e42f1c1 100644 --- a/libguile/hash.h +++ b/libguile/hash.h @@ -36,7 +36,6 @@ SCM_INTERNAL unsigned long scm_i_utf8_string_hash (const char *str, size_t len); SCM_INTERNAL unsigned long scm_i_string_hash (SCM str); -SCM_API unsigned long scm_hasher (SCM obj, unsigned long n, size_t d); SCM_API unsigned long scm_ihashq (SCM obj, unsigned long n); SCM_API SCM scm_hashq (SCM obj, SCM n); SCM_API unsigned long scm_ihashv (SCM obj, unsigned long n); diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 88cb199c5..30d781fe7 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -1,5 +1,5 @@ /* 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 @@ -54,9 +54,6 @@ * 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. */ @@ -76,201 +73,8 @@ static unsigned long hashtable_size[] = { static char *s_hashtable = "hashtable"; - - -/* 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; -} - - - -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; @@ -279,9 +83,6 @@ make_hash_table (int flags, unsigned long k, const char *func_name) ++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); @@ -289,8 +90,6 @@ make_hash_table (int flags, unsigned long k, const char *func_name) 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), @@ -323,13 +122,6 @@ scm_i_rehash (SCM table, 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; @@ -343,13 +135,6 @@ scm_i_rehash (SCM table, 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); @@ -369,10 +154,6 @@ scm_i_rehash (SCM table, 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)); @@ -387,28 +168,21 @@ scm_i_rehash (SCM table, 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 ("#", 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, @@ -416,171 +190,18 @@ 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 @@ -606,69 +227,7 @@ scm_hash_fn_get_handle (SCM table, SCM obj, 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; } @@ -694,11 +253,7 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, 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; @@ -706,29 +261,9 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, 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)) @@ -764,36 +299,6 @@ scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, 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, @@ -805,24 +310,7 @@ scm_hash_fn_set_x (SCM table, SCM obj, SCM val, 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; } @@ -849,11 +337,7 @@ scm_hash_fn_remove_x (SCM table, SCM obj, 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)) { @@ -872,6 +356,12 @@ SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0, "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); @@ -891,9 +381,6 @@ SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0, "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, @@ -909,9 +396,6 @@ SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, "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, @@ -930,6 +414,10 @@ SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0, { 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, @@ -945,6 +433,12 @@ SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0, "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, @@ -960,6 +454,16 @@ SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, "@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, @@ -978,9 +482,6 @@ SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0, "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, @@ -996,9 +497,6 @@ SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, "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, @@ -1007,6 +505,12 @@ SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, #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" @@ -1017,6 +521,12 @@ SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, { 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, @@ -1032,6 +542,14 @@ SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0, "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, @@ -1046,6 +564,14 @@ SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, "@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, @@ -1063,9 +589,6 @@ SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0, "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, @@ -1081,9 +604,6 @@ SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, "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, @@ -1092,6 +612,12 @@ SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, #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" @@ -1102,6 +628,12 @@ SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, { 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, @@ -1118,6 +650,14 @@ SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0, "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, @@ -1133,6 +673,14 @@ SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0, "@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, @@ -1147,10 +695,9 @@ typedef struct scm_t_ihashx_closure { SCM hash; SCM assoc; + SCM key; } scm_t_ihashx_closure; - - static unsigned long scm_ihashx (SCM obj, unsigned long n, void *arg) { @@ -1160,8 +707,6 @@ 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) { @@ -1169,6 +714,20 @@ 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), @@ -1183,9 +742,7 @@ SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, 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); @@ -1206,9 +763,7 @@ SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, 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); @@ -1235,6 +790,15 @@ SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, 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); } @@ -1259,6 +823,16 @@ SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, 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); } @@ -1280,6 +854,17 @@ SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0, 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); } @@ -1300,6 +885,10 @@ SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, #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); @@ -1321,6 +910,13 @@ SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0, #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, @@ -1339,9 +935,6 @@ SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0, 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); @@ -1364,6 +957,10 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0, #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), @@ -1409,6 +1006,9 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure, 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); @@ -1421,14 +1021,7 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure, 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); } } diff --git a/libguile/hashtab.h b/libguile/hashtab.h index dcebcb81e..82ed22e66 100644 --- a/libguile/hashtab.h +++ b/libguile/hashtab.h @@ -3,7 +3,7 @@ #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 @@ -25,29 +25,14 @@ #include "libguile/__scm.h" -#include "weaks.h" - -#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)++) @@ -70,10 +55,6 @@ typedef unsigned long (*scm_t_hash_fn) (SCM obj, unsigned long max, 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); @@ -83,7 +64,6 @@ typedef SCM (*scm_t_hash_fold_fn) (void *closure, SCM key, SCM value, 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 */ @@ -97,14 +77,8 @@ typedef struct scm_t_hashtable { 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); @@ -114,10 +88,6 @@ SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj, scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn, void *closure); -SCM_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, diff --git a/libguile/hooks.c b/libguile/hooks.c index abba606f7..782636e4e 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -1,4 +1,4 @@ -/* 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 @@ -134,22 +134,22 @@ static int hook_print (SCM hook, SCM port, scm_print_state *pstate) { SCM ls, name; - scm_puts ("#', port); + scm_putc_unlocked ('>', port); return 1; } @@ -269,7 +269,7 @@ void 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); @@ -280,7 +280,7 @@ void 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); diff --git a/libguile/init.c b/libguile/init.c index 455a772d8..54f73a92d 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -64,7 +64,6 @@ #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" @@ -85,7 +84,7 @@ #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" @@ -134,7 +133,6 @@ #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" @@ -166,8 +164,7 @@ stream_body (void *data) { 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; } @@ -384,16 +381,16 @@ scm_i_init_guile (void *base) 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 (); @@ -440,7 +437,6 @@ scm_i_init_guile (void *base) 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 */ @@ -492,7 +488,9 @@ scm_i_init_guile (void *base) 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 */ @@ -518,9 +516,7 @@ scm_i_init_guile (void *base) scm_initialized_p = 1; -#ifdef STACK_CHECKING scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; -#endif scm_init_rdelim (); scm_init_rw (); @@ -533,6 +529,9 @@ scm_i_init_guile (void *base) /* 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 (); } /* diff --git a/libguile/inline.c b/libguile/inline.c index 591679413..6e7688c37 100644 --- a/libguile/inline.c +++ b/libguile/inline.c @@ -1,4 +1,4 @@ -/* 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 @@ -26,3 +26,5 @@ #include "libguile/array-handle.h" #include "libguile/gc.h" #include "libguile/smob.h" +#include "libguile/pairs.h" +#include "libguile/ports.h" diff --git a/libguile/inline.h b/libguile/inline.h dissimilarity index 60% index 0d1a63485..3c9b09b6a 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -1,137 +1,57 @@ -/* 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 -#include - -#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 diff --git a/libguile/instructions.c b/libguile/instructions.c dissimilarity index 73% index ef4a9ce17..e474cf5d5 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -1,225 +1,190 @@ -/* 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 -#endif - -#include - -#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 -#include -#include -#include -#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 +#endif + +#include + +#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: +*/ diff --git a/libguile/instructions.h b/libguile/instructions.h index a2263228f..ad058cd9d 100644 --- a/libguile/instructions.h +++ b/libguile/instructions.h @@ -1,4 +1,4 @@ -/* 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 @@ -20,26 +20,30 @@ #define _SCM_INSTRUCTIONS_H_ #include +#include + +#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 -#include -#include -#include -#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); diff --git a/libguile/ioext.c b/libguile/ioext.c index 089ef1a01..94b0f4f0f 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -1,4 +1,4 @@ -/* 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 @@ -89,13 +89,13 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, { 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; @@ -269,7 +269,7 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, #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); @@ -292,11 +292,9 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0, 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 diff --git a/libguile/iselect.h b/libguile/iselect.h index 092fb07bf..1c7b12db0 100644 --- a/libguile/iselect.h +++ b/libguile/iselect.h @@ -3,7 +3,8 @@ #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 diff --git a/libguile/keywords.c b/libguile/keywords.c index f7a395da3..f630259d9 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -1,5 +1,5 @@ /* 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 @@ -49,7 +49,7 @@ scm_t_bits scm_tc16_keyword; 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; } diff --git a/libguile/list.c b/libguile/list.c index d30f9e847..1f44ad032 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -90,7 +90,7 @@ scm_list_n (SCM elt, ...) 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); diff --git a/libguile/load.c b/libguile/load.c index c46072512..16e3fb2a6 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -28,7 +28,6 @@ #include #include "libguile/_scm.h" -#include "libguile/private-gc.h" /* scm_getenv_int */ #include "libguile/libpath.h" #include "libguile/fports.h" #include "libguile/read.h" @@ -747,11 +746,11 @@ compiled_is_fresh (SCM full_filename, SCM compiled_filename, 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; @@ -766,10 +765,10 @@ SCM_SYMBOL (sym_auto_compilation_options, "%auto-compilation-options"); 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 ()); @@ -798,16 +797,16 @@ do_try_auto_compile (void *data) /* 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; } @@ -816,22 +815,22 @@ do_try_auto_compile (void *data) 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 ()); } @@ -849,7 +848,7 @@ SCM_DEFINE (scm_sys_warn_auto_compilation_enabled, "%warn-auto-compilation-enabl 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; @@ -868,9 +867,9 @@ scm_try_auto_compile (SCM source) 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); } @@ -1033,7 +1032,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, 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); @@ -1098,7 +1097,7 @@ init_build_info () 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); } diff --git a/libguile/loader.c b/libguile/loader.c new file mode 100644 index 000000000..ce5699167 --- /dev/null +++ b/libguile/loader.c @@ -0,0 +1,715 @@ +/* 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 +#endif + +#include +#include +#include + +#ifdef HAVE_SYS_MMAN_H +#include +#endif + +#include +#include +#include +#include +#include + +#include + +#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 + + + +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; +} + + +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: +*/ diff --git a/libguile/gdbint.h b/libguile/loader.h similarity index 68% rename from libguile/gdbint.h rename to libguile/loader.h index d7c6cf31e..194faff22 100644 --- a/libguile/gdbint.h +++ b/libguile/loader.h @@ -1,9 +1,4 @@ -/* 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 @@ -21,17 +16,18 @@ * 02110-1301 USA */ - - -#include "libguile/__scm.h" +#ifndef _SCM_LOADER_H_ +#define _SCM_LOADER_H_ - +#include -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: diff --git a/libguile/macros.c b/libguile/macros.c index fe33e7e48..47b252d85 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -49,11 +49,11 @@ static int macro_print (SCM macro, SCM port, scm_print_state *pstate) { if (scm_is_false (SCM_MACRO_TYPE (macro))) - scm_puts ("#', port); + scm_putc_unlocked ('>', port); return 1; } @@ -64,7 +64,7 @@ scm_i_make_primitive_macro (const char *name, scm_t_macro_primitive fn) { 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; diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 05c6a8529..b4499bc6d 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -1,5 +1,5 @@ /* 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 @@ -45,9 +45,9 @@ scm_t_bits scm_tc16_malloc; static int malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts("#', port); + scm_putc_unlocked('>', port); return 1; } diff --git a/libguile/memoize.c b/libguile/memoize.c index dfbeea781..5c7129feb 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -54,22 +54,65 @@ #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*"); +/* 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; +} + + + + /* {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) \ @@ -79,19 +122,17 @@ scm_t_bits scm_tc16_memoized; #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) \ @@ -100,10 +141,10 @@ scm_t_bits scm_tc16_memoized; 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) \ @@ -112,28 +153,22 @@ scm_t_bits scm_tc16_memoized; 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)) - /* 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", @@ -144,33 +179,52 @@ static const char *const memoized_tags[] = "toplevel-set!", "module-ref", "module-set!", - "prompt", + "call-with-prompt", }; + + + + static int -scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate) +try_lookup_rib (SCM x, SCM rib) { - 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; +} - - +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))) @@ -188,6 +242,22 @@ memoize_exps (SCM exps, SCM env) 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) { @@ -204,7 +274,9 @@ 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); @@ -228,11 +300,15 @@ memoize (SCM exp, SCM env) 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), @@ -243,38 +319,75 @@ memoize (SCM exp, SCM env) 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)) @@ -292,24 +405,21 @@ memoize (SCM exp, SCM env) 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))); @@ -322,38 +432,16 @@ memoize (SCM exp, SCM env) 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)) @@ -366,7 +454,7 @@ memoize (SCM exp, SCM env) 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)); @@ -386,82 +474,87 @@ memoize (SCM exp, SCM env) 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 (); } @@ -476,109 +569,7 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0, #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 - - - - -#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); - - - - -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 @@ -608,27 +599,23 @@ unmemoize_exprs (SCM exprs) 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 @@ -636,42 +623,29 @@ unmemoize (const SCM expr) { SCM args; - if (!SCM_MEMOIZED_P (expr)) - abort (); - args = SCM_MEMOIZED_ARGS (expr); switch (SCM_MEMOIZED_TAG (expr)) { case SCM_M_APPLY: - return scm_cons (scm_sym_atapply, unmemoize_exprs (args)); - case SCM_M_BEGIN: - return scm_cons (scm_sym_begin, unmemoize_exprs (args)); + 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))); @@ -741,8 +715,8 @@ unmemoize (const SCM expr) 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))); @@ -754,47 +728,15 @@ unmemoize (const SCM expr) -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}.") @@ -825,9 +767,11 @@ SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0, "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: @@ -838,7 +782,7 @@ SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0, 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; } @@ -869,7 +813,7 @@ SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0, 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; } @@ -901,13 +845,13 @@ SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0, 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")); } diff --git a/libguile/memoize.h b/libguile/memoize.h index 26bd5b1c1..68dcd2167 100644 --- a/libguile/memoize.h +++ b/libguile/memoize.h @@ -3,7 +3,7 @@ #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 @@ -44,16 +44,10 @@ SCM_API SCM scm_sym_quote; SCM_API SCM scm_sym_quasiquote; SCM_API SCM scm_sym_unquote; SCM_API SCM scm_sym_uq_splicing; -SCM_API SCM scm_sym_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; @@ -64,22 +58,18 @@ SCM_API SCM scm_sym_args; /* {Memoized Source} */ -SCM_INTERNAL scm_t_bits scm_tc16_memoized; - -#define SCM_MEMOIZED_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoized, (x))) -#define SCM_MEMOIZED_TAG(x) (SCM_SMOB_FLAGS (x)) -#define SCM_MEMOIZED_ARGS(x) (SCM_SMOB_OBJECT (x)) +#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, @@ -90,7 +80,7 @@ enum SCM_M_TOPLEVEL_SET, SCM_M_MODULE_REF, SCM_M_MODULE_SET, - SCM_M_PROMPT + SCM_M_CALL_WITH_PROMPT }; @@ -98,11 +88,8 @@ enum 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); diff --git a/libguile/modules.c b/libguile/modules.c index 7b42a3d43..d87ec7a64 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -154,7 +154,7 @@ convert_module_name (const char *name) 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); } @@ -219,7 +219,7 @@ scm_c_export (const char *name, ...) 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) @@ -227,7 +227,7 @@ scm_c_export (const char *name, ...) 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); @@ -601,7 +601,7 @@ scm_module_public_interface (SCM module) 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 @@ -619,7 +619,7 @@ scm_module_lookup (SCM module, SCM sym) SCM scm_c_lookup (const char *name) { - return scm_lookup (scm_from_locale_symbol (name)); + return scm_lookup (scm_from_utf8_symbol (name)); } SCM @@ -668,14 +668,14 @@ 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 @@ -710,14 +710,14 @@ 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 @@ -736,20 +736,20 @@ 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 @@ -768,7 +768,7 @@ scm_module_define (SCM module, SCM sym, SCM value) 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, @@ -819,16 +819,8 @@ SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 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); } @@ -867,7 +859,7 @@ SCM_SYMBOL (scm_sym_system_module, "system-module"); 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 diff --git a/libguile/numbers.c b/libguile/numbers.c index 22b53a502..2ed98d3f6 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -214,7 +214,7 @@ finalize_bignum (void *ptr, void *data) { SCM bignum; - bignum = PTR2SCM (ptr); + bignum = SCM_PACK_POINTER (ptr); mpz_clear (SCM_I_BIG_MPZ (bignum)); } @@ -651,7 +651,7 @@ scm_i_from_double (double val) { 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; @@ -670,7 +670,7 @@ SCM_PRIMITIVE_GENERIC (scm_exact_p, "exact?", 1, 0, 0, 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 @@ -691,7 +691,7 @@ SCM_PRIMITIVE_GENERIC (scm_inexact_p, "inexact?", 1, 0, 0, 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 @@ -730,7 +730,7 @@ SCM_PRIMITIVE_GENERIC (scm_odd_p, "odd?", 1, 0, 0, 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 @@ -764,7 +764,7 @@ SCM_PRIMITIVE_GENERIC (scm_even_p, "even?", 1, 0, 0, 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 @@ -779,7 +779,7 @@ SCM_PRIMITIVE_GENERIC (scm_finite_p, "finite?", 1, 0, 0, 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 @@ -794,7 +794,7 @@ SCM_PRIMITIVE_GENERIC (scm_inf_p, "inf?", 1, 0, 0, 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 @@ -809,7 +809,7 @@ SCM_PRIMITIVE_GENERIC (scm_nan_p, "nan?", 1, 0, 0, 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 @@ -937,7 +937,7 @@ SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, 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 @@ -952,10 +952,10 @@ SCM_PRIMITIVE_GENERIC (scm_quotient, "quotient", 2, 0, 0, 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 @@ -973,10 +973,10 @@ SCM_PRIMITIVE_GENERIC (scm_remainder, "remainder", 2, 0, 0, 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 @@ -995,10 +995,10 @@ SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0, 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 @@ -1097,10 +1097,9 @@ static void 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, @@ -1232,8 +1231,8 @@ SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-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)) { @@ -1273,8 +1272,8 @@ SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-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_REALP (x)) { @@ -1283,8 +1282,8 @@ SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0, 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)) { @@ -1294,12 +1293,12 @@ SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0, 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 @@ -1392,8 +1391,8 @@ SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0, 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)) { @@ -1428,8 +1427,8 @@ SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0, 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)) { @@ -1438,8 +1437,8 @@ SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0, 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)) { @@ -1449,12 +1448,12 @@ SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0, 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 @@ -1765,8 +1764,8 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0, 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)) { @@ -1806,8 +1805,8 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0, 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)) { @@ -1816,8 +1815,8 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0, 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)) { @@ -1827,12 +1826,12 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0, 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 @@ -1935,8 +1934,8 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0, 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)) { @@ -1971,8 +1970,8 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0, 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)) { @@ -1981,8 +1980,8 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0, 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)) { @@ -1992,12 +1991,12 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0, 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 @@ -2297,8 +2296,8 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0, 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)) { @@ -2338,8 +2337,8 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0, 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)) { @@ -2348,8 +2347,8 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0, 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)) { @@ -2359,12 +2358,12 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0, 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 @@ -2432,8 +2431,8 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0, 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)) { @@ -2466,8 +2465,8 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0, 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)) { @@ -2476,8 +2475,8 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0, 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)) { @@ -2487,12 +2486,12 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0, 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 @@ -2779,8 +2778,8 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0, 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)) { @@ -2828,8 +2827,8 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0, 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)) { @@ -2838,8 +2837,8 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0, 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)) { @@ -2849,12 +2848,12 @@ SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0, 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 @@ -2993,8 +2992,8 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0, 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)) { @@ -3034,8 +3033,8 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0, 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)) { @@ -3044,8 +3043,8 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0, 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)) { @@ -3055,12 +3054,12 @@ SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0, 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 @@ -3475,8 +3474,8 @@ SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0, 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)) { @@ -3526,8 +3525,8 @@ SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0, 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)) { @@ -3536,8 +3535,8 @@ SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0, 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)) { @@ -3547,12 +3546,12 @@ SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0, 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 @@ -3679,8 +3678,8 @@ SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0, 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)) { @@ -3727,8 +3726,8 @@ SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0, 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)) { @@ -3737,8 +3736,8 @@ SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0, 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)) { @@ -3748,12 +3747,12 @@ SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0, 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 @@ -4145,7 +4144,7 @@ scm_gcd (SCM x, SCM y) 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)) { @@ -4177,7 +4176,7 @@ scm_gcd (SCM x, SCM y) 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)) { @@ -4189,10 +4188,10 @@ scm_gcd (SCM x, SCM y) 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, @@ -4246,7 +4245,7 @@ scm_lcm (SCM n1, SCM n2) 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))) { @@ -4269,7 +4268,7 @@ scm_lcm (SCM n1, SCM n2) 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)) { @@ -4281,10 +4280,10 @@ scm_lcm (SCM n1, SCM n2) 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: @@ -5687,7 +5686,7 @@ int 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; } @@ -5695,7 +5694,7 @@ void 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 @@ -5703,7 +5702,7 @@ scm_print_complex (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; } @@ -5711,7 +5710,7 @@ void 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 @@ -5732,7 +5731,7 @@ scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) 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; } @@ -5802,20 +5801,25 @@ enum t_exactness {NO_EXACTNESS, INEXACT, EXACT}; 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 @@ -6601,7 +6605,8 @@ scm_num_eq_p (SCM x, SCM y) 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)) { @@ -6636,7 +6641,8 @@ scm_num_eq_p (SCM x, SCM y) 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)) { @@ -6671,7 +6677,8 @@ scm_num_eq_p (SCM x, SCM y) 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)) { @@ -6714,7 +6721,8 @@ scm_num_eq_p (SCM x, SCM y) 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)) { @@ -6744,10 +6752,12 @@ scm_num_eq_p (SCM x, SCM y) 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); } @@ -6824,7 +6834,8 @@ scm_less_p (SCM x, SCM y) 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)) { @@ -6852,7 +6863,8 @@ scm_less_p (SCM x, SCM y) 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)) { @@ -6898,7 +6910,8 @@ scm_less_p (SCM x, SCM y) 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)) { @@ -6931,10 +6944,12 @@ scm_less_p (SCM x, SCM y) 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); } @@ -6963,9 +6978,9 @@ SCM 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); } @@ -6997,9 +7012,9 @@ SCM 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 @@ -7033,9 +7048,9 @@ SCM 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 @@ -7062,7 +7077,7 @@ SCM_PRIMITIVE_GENERIC (scm_zero_p, "zero?", 1, 0, 0, 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 @@ -7086,7 +7101,7 @@ SCM_PRIMITIVE_GENERIC (scm_positive_p, "positive?", 1, 0, 0, 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 @@ -7110,7 +7125,7 @@ SCM_PRIMITIVE_GENERIC (scm_negative_p, "negative?", 1, 0, 0, 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 @@ -7144,11 +7159,11 @@ scm_max (SCM x, SCM y) 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)) @@ -7187,7 +7202,7 @@ scm_max (SCM x, SCM y) 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)) { @@ -7217,7 +7232,7 @@ scm_max (SCM x, SCM y) 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)) { @@ -7271,7 +7286,7 @@ scm_max (SCM x, SCM y) 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)) { @@ -7294,10 +7309,10 @@ scm_max (SCM x, SCM y) 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); } @@ -7324,11 +7339,11 @@ scm_min (SCM x, SCM y) 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)) @@ -7357,7 +7372,7 @@ scm_min (SCM x, SCM y) 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)) { @@ -7387,7 +7402,7 @@ scm_min (SCM x, SCM y) 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)) { @@ -7430,7 +7445,7 @@ scm_min (SCM x, SCM y) 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)) { @@ -7453,10 +7468,10 @@ scm_min (SCM x, SCM y) 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); } @@ -7485,7 +7500,7 @@ scm_sum (SCM x, SCM y) { 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))) @@ -7518,7 +7533,7 @@ scm_sum (SCM x, SCM 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_BIGP (x)) { if (SCM_I_INUMP (y)) @@ -7583,7 +7598,7 @@ scm_sum (SCM x, SCM 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)) { @@ -7603,7 +7618,7 @@ scm_sum (SCM x, SCM y) 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)) { @@ -7627,7 +7642,7 @@ scm_sum (SCM x, SCM y) 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)) { @@ -7650,10 +7665,10 @@ scm_sum (SCM x, SCM y) 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); } @@ -7693,7 +7708,7 @@ scm_difference (SCM x, SCM y) 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)) { @@ -7717,7 +7732,7 @@ scm_difference (SCM x, SCM y) (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))) @@ -7804,7 +7819,7 @@ scm_difference (SCM x, SCM y) 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)) { @@ -7868,7 +7883,8 @@ scm_difference (SCM x, SCM y) 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)) { @@ -7888,7 +7904,7 @@ scm_difference (SCM x, SCM y) 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)) { @@ -7912,7 +7928,7 @@ scm_difference (SCM x, SCM y) 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)) { @@ -7936,10 +7952,10 @@ scm_difference (SCM x, SCM y) 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 @@ -7982,7 +7998,7 @@ scm_product (SCM x, SCM y) 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))) @@ -8015,7 +8031,7 @@ scm_product (SCM x, SCM y) 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: /* @@ -8066,7 +8082,7 @@ scm_product (SCM x, SCM y) 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)) { @@ -8101,7 +8117,7 @@ scm_product (SCM x, SCM y) 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)) { @@ -8124,7 +8140,7 @@ scm_product (SCM x, SCM y) 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)) { @@ -8157,7 +8173,7 @@ scm_product (SCM x, SCM y) 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)) { @@ -8182,10 +8198,10 @@ scm_product (SCM x, SCM y) 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)) \ @@ -8249,7 +8265,7 @@ scm_divide (SCM x, SCM y) 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); @@ -8295,7 +8311,7 @@ scm_divide (SCM x, SCM y) 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))) @@ -8364,7 +8380,7 @@ scm_divide (SCM x, SCM y) 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)) { @@ -8446,7 +8462,7 @@ scm_divide (SCM x, SCM y) 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)) { @@ -8491,7 +8507,7 @@ scm_divide (SCM x, SCM y) 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)) { @@ -8558,7 +8574,7 @@ scm_divide (SCM x, SCM y) 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)) { @@ -8603,10 +8619,10 @@ scm_divide (SCM x, SCM y) 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 @@ -8672,7 +8688,7 @@ SCM_PRIMITIVE_GENERIC (scm_truncate_number, "truncate", 1, 0, 0, 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 @@ -8692,8 +8708,8 @@ SCM_PRIMITIVE_GENERIC (scm_round_number, "round", 1, 0, 0, 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 @@ -8710,7 +8726,7 @@ SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0, 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 @@ -8727,7 +8743,7 @@ SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0, 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 @@ -8766,9 +8782,9 @@ SCM_PRIMITIVE_GENERIC (scm_expt, "expt", 2, 0, 0, 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 @@ -8795,7 +8811,7 @@ SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0, 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 @@ -8816,7 +8832,7 @@ SCM_PRIMITIVE_GENERIC (scm_cos, "cos", 1, 0, 0, -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 @@ -8841,7 +8857,7 @@ SCM_PRIMITIVE_GENERIC (scm_tan, "tan", 1, 0, 0, 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 @@ -8862,7 +8878,7 @@ SCM_PRIMITIVE_GENERIC (scm_sinh, "sinh", 1, 0, 0, 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 @@ -8883,7 +8899,7 @@ SCM_PRIMITIVE_GENERIC (scm_cosh, "cosh", 1, 0, 0, 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 @@ -8908,7 +8924,7 @@ SCM_PRIMITIVE_GENERIC (scm_tanh, "tanh", 1, 0, 0, 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 @@ -8936,7 +8952,7 @@ SCM_PRIMITIVE_GENERIC (scm_asin, "asin", 1, 0, 0, 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 @@ -8966,7 +8982,7 @@ SCM_PRIMITIVE_GENERIC (scm_acos, "acos", 1, 0, 0, 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 @@ -8993,17 +9009,17 @@ SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0, 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 @@ -9021,7 +9037,7 @@ SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0, 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 @@ -9039,7 +9055,7 @@ SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0, 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 @@ -9057,7 +9073,7 @@ SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0, 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 @@ -9066,7 +9082,7 @@ scm_c_make_rectangular (double re, double im) { 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; @@ -9158,7 +9174,7 @@ SCM_PRIMITIVE_GENERIC (scm_real_part, "real-part", 1, 0, 0, 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 @@ -9173,7 +9189,7 @@ SCM_PRIMITIVE_GENERIC (scm_imag_part, "imag-part", 1, 0, 0, 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 @@ -9197,7 +9213,7 @@ SCM_PRIMITIVE_GENERIC (scm_numerator, "numerator", 1, 0, 0, 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 @@ -9222,7 +9238,8 @@ SCM_PRIMITIVE_GENERIC (scm_denominator, "denominator", 1, 0, 0, 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 @@ -9265,7 +9282,8 @@ SCM_PRIMITIVE_GENERIC (scm_magnitude, "magnitude", 1, 0, 0, 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 @@ -9312,7 +9330,7 @@ SCM_PRIMITIVE_GENERIC (scm_angle, "angle", 1, 0, 0, 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 @@ -9331,7 +9349,8 @@ SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact, "exact->inexact", 1, 0, 0, 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 @@ -9352,7 +9371,8 @@ SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, 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); @@ -9848,46 +9868,6 @@ scm_from_double (double val) 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) { @@ -10030,7 +10010,7 @@ SCM_PRIMITIVE_GENERIC (scm_log, "log", 1, 0, 0, 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 @@ -10077,7 +10057,7 @@ SCM_PRIMITIVE_GENERIC (scm_log10, "log10", 1, 0, 0, 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 @@ -10105,7 +10085,7 @@ SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0, 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 @@ -10352,7 +10332,7 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0, } } 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 diff --git a/libguile/numbers.h b/libguile/numbers.h index 912f287bb..5cdfbacea 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -126,8 +126,8 @@ typedef scm_t_int32 scm_t_wchar; #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) @@ -135,13 +135,12 @@ typedef scm_t_int32 scm_t_wchar; /* 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)) @@ -515,6 +514,34 @@ SCM_API SCM scm_from_mpz (mpz_t rop); #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); diff --git a/libguile/objcodes.c b/libguile/objcodes.c deleted file mode 100644 index e315f3e6e..000000000 --- a/libguile/objcodes.c +++ /dev/null @@ -1,480 +0,0 @@ -/* 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 -#endif - -#include -#include -#include - -#ifdef HAVE_SYS_MMAN_H -#include -#endif - -#include -#include -#include -#include -#include - -#include - -#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; - - -/* - * 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 - - -/* - * 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 ("#", port); -} - - -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: -*/ diff --git a/libguile/objcodes.h b/libguile/objcodes.h deleted file mode 100644 index 0cfc8e027..000000000 --- a/libguile/objcodes.h +++ /dev/null @@ -1,83 +0,0 @@ -/* 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 - -/* 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: -*/ diff --git a/libguile/objprop.c b/libguile/objprop.c index 7b50d71d0..b45c9aa26 100644 --- a/libguile/objprop.c +++ b/libguile/objprop.c @@ -27,7 +27,6 @@ #include "libguile/hashtab.h" #include "libguile/alist.h" #include "libguile/root.h" -#include "libguile/weaks.h" #include "libguile/objprop.h" @@ -36,20 +35,13 @@ */ 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 @@ -59,9 +51,7 @@ SCM_DEFINE (scm_set_object_properties_x, "set-object-properties!", 2, 0, 0, "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; } @@ -74,7 +64,7 @@ SCM_DEFINE (scm_object_property, "object-property", 2, 0, 0, { 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 @@ -87,14 +77,14 @@ SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0, 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; } @@ -104,7 +94,7 @@ SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0, 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" } diff --git a/libguile/options.c b/libguile/options.c index 0e083143c..2d7e18f65 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -1,4 +1,4 @@ -/* 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 @@ -93,8 +93,6 @@ 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 @@ -133,7 +131,7 @@ get_documented_option_setting (const scm_t_option options[]) 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: @@ -177,16 +175,17 @@ change_option_setting (SCM args, scm_t_option options[], const char *s, 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)) @@ -201,15 +200,15 @@ change_option_setting (SCM args, scm_t_option options[], const char *s, 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; @@ -226,20 +225,7 @@ change_option_setting (SCM args, scm_t_option options[], const char *s, 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]; } @@ -278,7 +264,7 @@ scm_init_opts (SCM (*func) (SCM), scm_t_option options[]) 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); @@ -288,8 +274,6 @@ scm_init_opts (SCM (*func) (SCM), scm_t_option options[]) void scm_init_options () { - scm_gc_register_root (&protected_objects); - #include "libguile/options.x" } diff --git a/libguile/pairs.c b/libguile/pairs.c index 5dbbab566..1a3c5a18c 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -1,4 +1,4 @@ -/* 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 @@ -67,18 +67,6 @@ void scm_error_pair_access (SCM non_pair) #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) { @@ -143,14 +131,6 @@ SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0, 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 */ @@ -270,6 +250,9 @@ void 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); } diff --git a/libguile/pairs.h b/libguile/pairs.h index 6edfc9c3e..130bf28a6 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -3,7 +3,7 @@ #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 @@ -25,6 +25,8 @@ #include "libguile/__scm.h" +#include "libguile/gc.h" + #if (SCM_DEBUG_PAIR_ACCESSES == 1) @@ -115,11 +117,67 @@ 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); diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 8a3a00bc9..bff89cb5e 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -27,14 +27,14 @@ 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 */ @@ -58,8 +58,7 @@ typedef struct scm_port_internal scm_t_port_internal; #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); diff --git a/libguile/ports.c b/libguile/ports.c index 6f219d6d2..960dfa8e7 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,5 +1,5 @@ -/* 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 @@ -35,7 +35,6 @@ #include #include #include -#include #include @@ -58,7 +57,7 @@ #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" @@ -92,6 +91,56 @@ #endif +/* 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; +} + + + /* The port kind table --- a dynamically resized array of port types. */ @@ -100,19 +149,79 @@ * 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; } /* @@ -136,110 +245,89 @@ scm_make_port_type (char *name, 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 @@ -268,130 +356,6 @@ scm_i_set_port_alist_x (SCM port, SCM alist) -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 - - /* Standard ports --- current input, output, error, and more(!). */ static SCM cur_inport_fluid = SCM_BOOL_F; @@ -558,323 +522,285 @@ scm_i_dynwind_current_load_port (SCM port) scm_dynwind_fluid (cur_loadport_fluid, port); } - -/* 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; -/* 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. */ - - - -/* 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; + - 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 + -#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 + -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; - -/* 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); +} -/* 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 + /* 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. @@ -889,7 +815,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, "descriptors.") #define FUNC_NAME s_scm_close_port { - size_t i; + scm_t_port_internal *pti; int rv; port = SCM_COERCE_OUTPORT (port); @@ -897,13 +823,28 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, 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 @@ -939,661 +880,543 @@ SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0, } #undef FUNC_NAME -static SCM -collect_keys (void *unused, SCM key, SCM value, SCM result) -{ - return scm_cons (key, result); -} + + +/* 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); - -/* 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 + ). */ - *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); + - 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); + - 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 @@ -1621,19 +1444,23 @@ swap_buffer (void *data) 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; @@ -1653,25 +1480,23 @@ scm_c_read (SCM port, void *buffer, size_t size) 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 @@ -1686,9 +1511,9 @@ scm_c_read (SCM port, void *buffer, size_t size) 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; @@ -1712,7 +1537,7 @@ scm_c_read (SCM port, void *buffer, size_t size) 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); @@ -1727,197 +1552,596 @@ scm_c_read (SCM port, void *buffer, size_t size) } #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; } - - - -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 + + + + +/* Pushback. */ + + + +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); @@ -1934,9 +2158,19 @@ scm_ungetc (scm_t_wchar c, SCM port) } #undef FUNC_NAME +void +scm_ungetc (scm_t_wchar c, SCM port) +{ + scm_i_pthread_mutex_t *lock; + scm_c_lock_port (port, &lock); + scm_ungetc_unlocked (c, port); + if (lock) + scm_i_pthread_mutex_unlock (lock); + +} void -scm_ungets (const char *s, int n, SCM port) +scm_ungets_unlocked (const char *s, int n, SCM port) { /* This is simple minded and inefficient, but unreading strings is * probably not a common operation, and remember that line and @@ -1945,9 +2179,19 @@ scm_ungets (const char *s, int n, SCM port) * 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), @@ -1977,812 +2221,786 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, 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 + + + +/* 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 - ). */ - /* Assume opening an iconv descriptor causes about 16 KB of - allocation. */ - scm_gc_register_allocation (16 * 1024); + - 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, + + + +/* 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 + + +/* 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) @@ -2800,15 +3018,91 @@ scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) 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; } + + + +/* 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 + + /* Void ports. */ @@ -2830,18 +3124,13 @@ write_void_port (SCM port SCM_UNUSED, 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 @@ -2862,7 +3151,9 @@ SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0, } #undef FUNC_NAME + + /* Initialization. */ void @@ -2881,7 +3172,7 @@ scm_init_ports () 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" diff --git a/libguile/ports.h b/libguile/ports.h index 39317f8b1..806448980 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -3,8 +3,8 @@ #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 @@ -26,7 +26,12 @@ #include "libguile/__scm.h" +#include +#include #include +#include "libguile/gc.h" +#include "libguile/tags.h" +#include "libguile/error.h" #include "libguile/print.h" #include "libguile/struct.h" #include "libguile/threads.h" @@ -43,14 +48,19 @@ typedef enum scm_t_port_rw_active { 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; @@ -58,10 +68,6 @@ typedef struct 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 @@ -112,27 +118,13 @@ typedef struct 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) @@ -152,22 +144,19 @@ SCM_INTERNAL SCM scm_i_port_weak_hash; #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)) @@ -175,8 +164,6 @@ SCM_INTERNAL SCM scm_i_port_weak_hash; #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) @@ -189,6 +176,10 @@ SCM_INTERNAL SCM scm_i_port_weak_hash; +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 { @@ -209,24 +200,18 @@ 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 - - - -/* 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) - - -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, @@ -241,11 +226,10 @@ SCM_API void scm_set_port_print (scm_t_bits tc, 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, @@ -254,10 +238,8 @@ SCM_API void scm_set_port_truncate (scm_t_bits tc, 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); @@ -270,45 +252,107 @@ SCM_API SCM scm_set_current_warning_port (SCM port); 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); @@ -317,43 +361,96 @@ SCM_API SCM scm_port_column (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 */ diff --git a/libguile/posix.c b/libguile/posix.c index 3e03c86c0..0443f95ea 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1225,6 +1225,7 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0, #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 diff --git a/libguile/print.c b/libguile/print.c index 4e68fd6c4..a8f220b63 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -30,7 +30,6 @@ #include #include -#include #include "libguile/_scm.h" #include "libguile/chars.h" @@ -41,7 +40,6 @@ #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" @@ -163,7 +161,7 @@ do \ { \ if (pstate->top - pstate->list_offset >= pstate->level) \ { \ - scm_putc ('#', port); \ + scm_putc_unlocked ('#', port); \ return; \ } \ } \ @@ -307,9 +305,9 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref) 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. */ @@ -338,6 +336,7 @@ quote_keywordish_symbols (void) (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) { @@ -350,26 +349,56 @@ 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 `;'. */ @@ -388,7 +417,16 @@ symbol_has_extended_read_syntax (SCM sym) 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 @@ -400,7 +438,7 @@ print_extended_symbol (SCM sym, SCM port) 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++) { @@ -424,12 +462,12 @@ print_extended_symbol (SCM sym, SCM port) } } - 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); @@ -440,8 +478,8 @@ scm_i_print_symbol_name (SCM sym, SCM 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. @@ -460,7 +498,7 @@ static void iprin1 (SCM exp, SCM port, scm_print_state *pstate); scm_intprint (i, 8, port); \ else \ { \ - scm_puts ("x", port); \ + scm_puts_unlocked ("x", port); \ scm_intprint (i, 16, port); \ } \ } \ @@ -515,7 +553,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) else if (SCM_IFLAGP (exp) && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *)))) { - scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port); + scm_puts_unlocked (iflagnames [SCM_IFLAGNUM (exp)], port); } else { @@ -536,7 +574,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) 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 { @@ -571,6 +609,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) break; } break; + case scm_tc7_stringbuf: + scm_i_print_stringbuf (exp, port, pstate); + break; case scm_tc7_string: if (SCM_WRITINGP (pstate)) { @@ -604,16 +645,16 @@ iprin1 (SCM exp, SCM port, scm_print_state *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 ("#', port); + scm_putc_unlocked ('>', port); } break; case scm_tc7_variable: @@ -628,6 +669,12 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) 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; @@ -637,21 +684,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) 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); @@ -665,14 +700,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *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; @@ -684,43 +716,26 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) 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; } @@ -865,7 +880,7 @@ display_string_as_utf8 (const void *str, int narrow_p, size_t len, /* 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; } @@ -874,6 +889,54 @@ display_string_as_utf8 (const void *str, int narrow_p, size_t len, 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 @@ -897,8 +960,8 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, 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); } @@ -942,7 +1005,7 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, 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. */ @@ -977,7 +1040,7 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, { /* 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; } @@ -997,7 +1060,6 @@ static size_t 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; @@ -1005,9 +1067,10 @@ display_string (const void *str, int narrow_p, 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 @@ -1052,7 +1115,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) /* 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) { @@ -1062,7 +1125,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) 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) { @@ -1072,7 +1135,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) 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) { @@ -1084,7 +1147,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) 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 @@ -1107,7 +1170,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) buf[i] = 'x'; i --; buf[i] = '\\'; - scm_lfwrite (buf + i, 9 - i, port); + scm_lfwrite_unlocked (buf + i, 9 - i, port); } } else @@ -1117,7 +1180,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) 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); } @@ -1211,14 +1274,14 @@ void 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. @@ -1227,19 +1290,19 @@ scm_uintprint (scm_t_uintmax n, int radix, SCM port) void scm_ipruk (char *hdr, SCM ptr, SCM port) { - scm_puts ("#', port); + scm_putc_unlocked ('>', port); } @@ -1250,7 +1313,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) { 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; @@ -1280,18 +1343,18 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) 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; @@ -1312,7 +1375,7 @@ fancy_printing: { if (n == 0) { - scm_puts (" ...", port); + scm_puts_unlocked (" ...", port); goto skip_tail; } else @@ -1320,14 +1383,14 @@ fancy_printing: } 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: @@ -1338,7 +1401,7 @@ fancy_circref: pstate->list_offset -= pstate->top - floor - 2; circref: - scm_puts (" . ", port); + scm_puts_unlocked (" . ", port); print_circref (port, pstate, exp); goto end; } @@ -1363,7 +1426,11 @@ scm_write (SCM obj, SCM port) 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; } @@ -1378,7 +1445,11 @@ scm_display (SCM obj, SCM port) 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; } @@ -1491,7 +1562,7 @@ SCM_DEFINE (scm_newline, "newline", 0, 1, 0, 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 @@ -1536,7 +1607,7 @@ static int 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 @@ -1583,8 +1654,6 @@ scm_init_print () { 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")); diff --git a/libguile/print.h b/libguile/print.h index 4c60b52f1..80a9922f2 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -85,7 +85,6 @@ SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port); 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); diff --git a/libguile/private-gc.h b/libguile/private-gc.h deleted file mode 100644 index 42514c1e2..000000000 --- a/libguile/private-gc.h +++ /dev/null @@ -1,66 +0,0 @@ -/* - * 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 diff --git a/libguile/procprop.c b/libguile/procprop.c index 36228d3f3..d45536062 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -1,6 +1,5 @@ -/* 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 @@ -23,34 +22,27 @@ # include #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" 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; @@ -59,9 +51,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) { 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)) { @@ -73,16 +63,18 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) 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 @@ -90,14 +82,9 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) *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); @@ -115,9 +102,7 @@ SCM_DEFINE (scm_set_procedure_minimum_arity_x, "set-procedure-minimum-arity!", 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 @@ -152,25 +137,25 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0, "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; } @@ -183,14 +168,7 @@ SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0 { 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; } @@ -201,14 +179,24 @@ SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0, "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); } @@ -220,40 +208,135 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, "@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_i_pthread_mutex_lock (&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_i_pthread_mutex_unlock (&overrides_lock); + 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 + +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 + + + 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 (); } diff --git a/libguile/procprop.h b/libguile/procprop.h index 919fa4d3a..41d0753e3 100644 --- a/libguile/procprop.h +++ b/libguile/procprop.h @@ -3,7 +3,7 @@ #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 @@ -28,10 +28,8 @@ 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; @@ -43,6 +41,9 @@ SCM_API SCM scm_procedure_properties (SCM proc); 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 */ diff --git a/libguile/procs.c b/libguile/procs.c index 59caed1b4..1be7fd10c 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -1,5 +1,5 @@ /* 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 @@ -33,7 +33,7 @@ #include "libguile/validate.h" #include "libguile/procs.h" #include "libguile/procprop.h" -#include "libguile/objcodes.h" +#include "libguile/loader.h" #include "libguile/programs.h" @@ -47,21 +47,10 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, "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 @@ -76,21 +65,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, } #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 */ @@ -114,18 +88,10 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, "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 @@ -147,14 +113,15 @@ SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0, "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 diff --git a/libguile/procs.h b/libguile/procs.h index a35872e3d..c4c78f23e 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -4,7 +4,7 @@ #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 @@ -30,15 +30,12 @@ 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 */ /* diff --git a/libguile/programs.c b/libguile/programs.c dissimilarity index 65% index d2b2e755b..fae95d0ab 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -1,427 +1,282 @@ -/* 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 -#endif - -#include -#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" - - -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 ("#', port); - } - else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program)) - { - /* twingliness */ - scm_puts ("#', port); - } - else if (scm_is_false (write_program) || print_error) - { - scm_puts ("#', port); - } - else - { - print_error = 1; - scm_call_2 (SCM_VARIABLE_REF (write_program), program, port); - print_error = 0; - } -} - - -/* - * 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; -} - - - -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 +#endif + +#include +#include "_scm.h" +#include "modules.h" +#include "programs.h" +#include "procprop.h" /* scm_sym_name */ +#include "vm.h" + + +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 ("#', port); + } + else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program)) + { + /* twingliness */ + scm_puts_unlocked ("#', port); + } + else if (scm_is_false (write_program) || print_error) + { + scm_puts_unlocked ("#', port); + } + else + { + print_error = 1; + scm_call_2 (SCM_VARIABLE_REF (write_program), program, port); + print_error = 0; + } +} + + +/* + * 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; +} + + + +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: +*/ diff --git a/libguile/programs.h b/libguile/programs.h index be2077b77..096c2c02a 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -1,4 +1,4 @@ -/* 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 @@ -20,50 +20,57 @@ #define _SCM_PROGRAMS_H_ #include -#include /* * 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); diff --git a/libguile/promises.c b/libguile/promises.c index 3bbb489d2..dcd0ac383 100644 --- a/libguile/promises.c +++ b/libguile/promises.c @@ -88,11 +88,11 @@ static int promise_print (SCM exp, SCM port, scm_print_state *pstate) { int writingp = SCM_WRITINGP (pstate); - scm_puts ("#', port); + scm_putc_unlocked ('>', port); return !0; } diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h index 4c67b1857..b5fae4e89 100644 --- a/libguile/pthread-threads.h +++ b/libguile/pthread-threads.h @@ -29,27 +29,15 @@ #include #include -/* `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 @@ -57,11 +45,7 @@ /* 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 */ diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index fecc5bd46..3f936e71b 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -84,17 +84,14 @@ make_bip (SCM bv) 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); @@ -103,11 +100,6 @@ make_bip (SCM 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; } @@ -312,27 +304,19 @@ make_cbip (SCM read_proc, SCM get_position_proc, 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; } @@ -491,7 +475,7 @@ SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, 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; @@ -533,7 +517,7 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 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; @@ -565,14 +549,14 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 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; } @@ -620,7 +604,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, /* `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); @@ -640,7 +624,8 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 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; @@ -665,7 +650,7 @@ SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0, 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; } @@ -708,7 +693,7 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0, 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; } @@ -833,26 +818,19 @@ make_bop (void) 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); @@ -925,7 +903,7 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure, 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) @@ -936,7 +914,7 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure, 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; @@ -992,26 +970,18 @@ make_cbop (SCM write_proc, SCM get_position_proc, 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; } @@ -1109,13 +1079,8 @@ make_tp (SCM binary_port, unsigned long mode) 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)) { @@ -1128,15 +1093,13 @@ make_tp (SCM binary_port, unsigned long mode) 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 @@ -1154,7 +1117,7 @@ tp_fill_input (SCM port) 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) @@ -1191,7 +1154,7 @@ tp_flush (SCM port) 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; @@ -1218,6 +1181,8 @@ initialize_transcoded_ports (void) 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), @@ -1273,7 +1238,7 @@ SCM_DEFINE (scm_get_string_n_x, 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; diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h index 2ae3e765b..3dde4d5f1 100644 --- a/libguile/r6rs-ports.h +++ b/libguile/r6rs-ports.h @@ -1,7 +1,7 @@ #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 @@ -34,6 +34,7 @@ SCM_API SCM scm_get_bytevector_n (SCM, SCM); 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); diff --git a/libguile/rdelim.c b/libguile/rdelim.c index 9d1496795..c8c7d8b43 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -79,13 +79,13 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, { 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)); @@ -149,7 +149,7 @@ SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0, } else { - buf[index] = scm_getc (port); + buf[index] = scm_getc_unlocked (port); switch (buf[index]) { case EOF: diff --git a/libguile/read.c b/libguile/read.c index e2e2e4a2e..c8db81277 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -25,7 +25,6 @@ #endif #include -#include #include #include #include @@ -44,6 +43,7 @@ #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" @@ -259,13 +259,13 @@ read_token (SCM port, scm_t_read_opts *opts, { 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 @@ -331,7 +331,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) { scm_t_wchar c; while (1) - switch (c = scm_getc (port)) + switch (c = scm_getc_unlocked (port)) { case EOF: goteof: @@ -346,7 +346,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) case ';': lp: - switch (c = scm_getc (port)) + switch (c = scm_getc_unlocked (port)) { case EOF: goto goteof; @@ -358,7 +358,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) break; case '#': - switch (c = scm_getc (port)) + switch (c = scm_getc_unlocked (port)) { case EOF: eoferr = "read_sharp"; @@ -377,7 +377,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) } /* fall through */ default: - scm_ungetc (c, port); + scm_ungetc_unlocked (c, port); return '#'; } break; @@ -431,7 +431,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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 @@ -459,7 +459,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) "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. */ @@ -548,7 +548,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) c = 0; \ while (i < ndigits) \ { \ - a = scm_getc (port); \ + a = scm_getc_unlocked (port); \ if (a == EOF) \ goto str_eof; \ if (terminator \ @@ -578,13 +578,13 @@ skip_intraline_whitespace (SCM port) 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 @@ -602,7 +602,7 @@ scm_read_string (int chr, SCM port, scm_t_read_opts *opts) 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) { @@ -619,7 +619,7 @@ scm_read_string (int chr, SCM port, scm_t_read_opts *opts) if (c == '\\') { - switch (c = scm_getc (port)) + switch (c = scm_getc_unlocked (port)) { case EOF: goto str_eof; @@ -705,17 +705,16 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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)) @@ -740,10 +739,9 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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) @@ -751,8 +749,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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); @@ -760,8 +757,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) } 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); @@ -781,7 +777,6 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) char local_buffer[READER_BUFFER_SIZE], *buffer; unsigned int radix; SCM str; - scm_t_port *pt; switch (chr) { @@ -806,16 +801,15 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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)); @@ -851,12 +845,12 @@ scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) { 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; @@ -898,12 +892,12 @@ scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) { 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; @@ -940,9 +934,9 @@ scm_read_semicolon_comment (int chr, SCM port) /* 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; } @@ -976,7 +970,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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); @@ -985,7 +979,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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); @@ -994,12 +988,14 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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]); @@ -1007,8 +1003,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) /* 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); @@ -1116,14 +1111,14 @@ read_decimal_integer (SCM port, int c, ssize_t *resp) 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) @@ -1154,11 +1149,11 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) /* 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; @@ -1181,7 +1176,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) && 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; @@ -1205,7 +1200,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) if (c == '@') { - c = scm_getc (port); + c = scm_getc_unlocked (port); c = read_decimal_integer (port, c, &lbnd); } @@ -1213,7 +1208,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) 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, @@ -1275,15 +1270,15 @@ static SCM 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; @@ -1306,15 +1301,15 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, 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)), @@ -1328,7 +1323,7 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) for (;;) { - int c = scm_getc (port); + int c = scm_getc_unlocked (port); if (c == EOF) scm_i_input_error ("skip_block_comment", port, @@ -1361,7 +1356,7 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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); @@ -1369,7 +1364,7 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) 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 */ @@ -1391,12 +1386,12 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) } 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); } @@ -1407,7 +1402,7 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM 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, @@ -1415,7 +1410,7 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM 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, @@ -1448,7 +1443,7 @@ scm_read_commented_expression (scm_t_wchar chr, SCM 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; } @@ -1467,7 +1462,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) buf = scm_i_string_start_writing (buf); - while ((chr = scm_getc (port)) != EOF) + while ((chr = scm_getc_unlocked (port)) != EOF) { if (saw_brace) { @@ -1494,7 +1489,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) 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; @@ -1583,7 +1578,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, { 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)) @@ -1614,29 +1609,10 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, 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': @@ -1692,7 +1668,7 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) { scm_t_wchar chr; - chr = scm_getc (port); + chr = scm_getc_unlocked (port); switch (chr) { @@ -1812,7 +1788,7 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) 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); } @@ -1825,7 +1801,7 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) 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 ...) */ @@ -1847,7 +1823,7 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) else { if (chr != EOF) - scm_ungetc (chr, port); + scm_ungetc_unlocked (chr, port); break; } maybe_annotate_source (expr, port, opts, line, column); @@ -1881,7 +1857,7 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, 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)); } @@ -1976,6 +1952,15 @@ scm_get_hash_procedure (int c) #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 ()'. */ @@ -1992,7 +1977,7 @@ scm_i_scan_for_encoding (SCM port) 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; @@ -2000,7 +1985,7 @@ scm_i_scan_for_encoding (SCM port) 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; @@ -2025,7 +2010,7 @@ scm_i_scan_for_encoding (SCM port) 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)); } @@ -2056,8 +2041,7 @@ scm_i_scan_for_encoding (SCM port) 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; @@ -2065,8 +2049,6 @@ scm_i_scan_for_encoding (SCM port) 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; @@ -2122,7 +2104,7 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 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; } diff --git a/libguile/root.c b/libguile/root.c index 8c8fd1aa5..c83da1c3c 100644 --- a/libguile/root.c +++ b/libguile/root.c @@ -1,4 +1,4 @@ -/* 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 @@ -109,12 +109,14 @@ scm_internal_cwdr (scm_t_catch_body body, void *body_data, 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)); @@ -128,7 +130,7 @@ scm_internal_cwdr (scm_t_catch_body body, void *body_data, /* 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) diff --git a/libguile/rw.c b/libguile/rw.c index a9b4a329a..677e0d8df 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -1,4 +1,4 @@ -/* 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 @@ -248,7 +248,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, 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); } { diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 701beb56d..9fefa83fd 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -160,6 +160,11 @@ signal_delivery_thread (void *data) #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 diff --git a/libguile/script.c b/libguile/script.c index 83daf8ac1..052ab8d42 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -1,4 +1,4 @@ -/* 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 @@ -33,7 +33,6 @@ #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" diff --git a/libguile/simpos.c b/libguile/simpos.c index 8859d4f15..7865da647 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -1,5 +1,5 @@ /* 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 @@ -190,6 +190,21 @@ SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, } #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), diff --git a/libguile/simpos.h b/libguile/simpos.h index b391a28d8..1e2076870 100644 --- a/libguile/simpos.h +++ b/libguile/simpos.h @@ -3,7 +3,7 @@ #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 @@ -32,6 +32,7 @@ SCM_API SCM scm_system_star (SCM cmds); 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 */ diff --git a/libguile/smob.c b/libguile/smob.c index 90849a89d..768257840 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -32,7 +32,6 @@ #include "libguile/async.h" #include "libguile/goops.h" #include "libguile/instructions.h" -#include "libguile/objcodes.h" #include "libguile/programs.h" #include "libguile/smob.h" @@ -106,14 +105,14 @@ int 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; } @@ -206,11 +205,11 @@ scm_make_smob_type (char const *name, size_t size) { 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); @@ -258,8 +257,7 @@ scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (), 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)]); @@ -299,7 +297,7 @@ smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, 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 @@ -336,7 +334,7 @@ smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, 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, @@ -355,7 +353,7 @@ smob_mark (GC_word *addr, struct GC_ms_entry *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; @@ -381,7 +379,7 @@ finalize_smob (void *ptr, void *data) 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)); @@ -405,9 +403,9 @@ scm_i_new_smob (scm_t_bits tc, scm_t_bits data) 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); @@ -430,9 +428,9 @@ scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1, /* 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); @@ -445,26 +443,6 @@ scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1, return ret; } - - - -/* 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); -} - - void scm_smob_prehistory () @@ -491,7 +469,7 @@ 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; } } diff --git a/libguile/smob.h b/libguile/smob.h index 60abe3733..37ea64247 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -40,8 +40,7 @@ typedef struct scm_smob_descriptor 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; @@ -51,7 +50,7 @@ typedef struct 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) @@ -73,14 +72,6 @@ SCM_INLINE SCM scm_new_smob (scm_t_bits tc, scm_t_bits); 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) diff --git a/libguile/snarf.h b/libguile/snarf.h index 1c072babb..afc4d8f2a 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -4,7 +4,7 @@ #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 @@ -96,48 +96,9 @@ scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \ )\ 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(\ @@ -209,11 +170,11 @@ SCM_SNARF_INIT( \ # 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 */ @@ -364,28 +325,6 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));) #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 */ diff --git a/libguile/socket.c b/libguile/socket.c index ee84fa358..34bc21a73 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1416,33 +1416,12 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, 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; @@ -1482,35 +1461,12 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, 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; @@ -1568,52 +1524,28 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0, ((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; @@ -1683,35 +1615,12 @@ SCM_DEFINE (scm_sendto, "sendto", 3, 1, 1, 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) { diff --git a/libguile/srcprop.c b/libguile/srcprop.c index c632bb0c5..dbebf779f 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -34,7 +34,6 @@ #include "libguile/hash.h" #include "libguile/ports.h" #include "libguile/root.h" -#include "libguile/weaks.h" #include "libguile/gc.h" #include "libguile/validate.h" @@ -62,7 +61,6 @@ SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); 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; /* @@ -106,11 +104,11 @@ static int srcprops_print (SCM obj, SCM port, scm_print_state *pstate) { int writingp = SCM_WRITINGP (pstate); - scm_puts ("#', port); + scm_putc_unlocked ('>', port); return 1; } @@ -187,11 +185,7 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, 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); @@ -212,9 +206,7 @@ SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, { 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; } @@ -227,15 +219,7 @@ scm_i_has_source_properties (SCM obj) 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 @@ -246,14 +230,12 @@ scm_i_set_source_properties_x (SCM obj, long line, int col, SCM fname) { 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 @@ -263,32 +245,27 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, "@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 @@ -302,44 +279,44 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, 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; } @@ -355,12 +332,10 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0, { 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 @@ -372,7 +347,7 @@ scm_init_srcprop () 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, diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index 54c7e2aa3..aaa3efe6c 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -1,7 +1,7 @@ /* 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 @@ -258,7 +258,7 @@ SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1, 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)); } } diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c index af7c1d95b..bf95ce982 100644 --- a/libguile/srfi-14.c +++ b/libguile/srfi-14.c @@ -597,27 +597,27 @@ charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED) p = SCM_CHARSET_DATA (charset); - scm_puts ("#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; } @@ -630,16 +630,16 @@ charset_cursor_print (SCM cursor, SCM port, cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor); - scm_puts ("#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; } diff --git a/libguile/srfi-14.h b/libguile/srfi-14.h index 4b1a4b298..dc9718d70 100644 --- a/libguile/srfi-14.h +++ b/libguile/srfi-14.h @@ -3,7 +3,7 @@ /* 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 @@ -45,7 +45,7 @@ typedef struct #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; diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index af8126d03..ff0c414d7 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -1,6 +1,6 @@ /* 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 @@ -113,7 +113,8 @@ #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) \ { \ diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index b55fd1d09..0e5afc35a 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -2,7 +2,7 @@ #define SCM_SRFI_4_H /* srfi-4.c --- Homogeneous numeric vector datatypes. * - * Copyright (C) 2001, 2004, 2006, 2008, 2009, 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 @@ -279,16 +279,6 @@ SCM_INTERNAL const char *scm_i_uniform_vector_tag (SCM uvec); SCM_INTERNAL scm_i_t_array_ref scm_i_uniform_vector_ref_proc (SCM uvec); SCM_INTERNAL scm_i_t_array_set scm_i_uniform_vector_set_proc (SCM uvec); -#if SCM_ENABLE_DEPRECATED - -/* Deprecated because we want people to use the scm_t_array_handle - interface. -*/ - -SCM_DEPRECATED size_t scm_uniform_element_size (SCM obj); - -#endif - SCM_INTERNAL void scm_init_srfi_4 (void); #endif /* SCM_SRFI_4_H */ diff --git a/libguile/stackchk.c b/libguile/stackchk.c index 6cfb783b1..208ba97ed 100644 --- a/libguile/stackchk.c +++ b/libguile/stackchk.c @@ -1,4 +1,4 @@ -/* 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 @@ -34,7 +34,6 @@ /* {Stack Checking} */ -#ifdef STACK_CHECKING int scm_stack_checking_enabled_p; SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow"); @@ -65,8 +64,6 @@ scm_report_stack_overflow () scm_dynwind_end (); } -#endif - long scm_stack_size (SCM_STACKITEM *start) { @@ -89,11 +86,11 @@ scm_stack_report () 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); } diff --git a/libguile/stackchk.h b/libguile/stackchk.h index aa6a1d493..1ed170fef 100644 --- a/libguile/stackchk.h +++ b/libguile/stackchk.h @@ -3,7 +3,7 @@ #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 @@ -34,7 +34,7 @@ */ #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)\ diff --git a/libguile/stacks.c b/libguile/stacks.c index 37a9161cd..360b35f7b 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -1,5 +1,5 @@ /* 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 @@ -95,23 +95,21 @@ stack_depth (SCM frame) * 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; @@ -120,75 +118,75 @@ narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key) 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); } @@ -257,12 +255,13 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, 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; @@ -313,10 +312,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, } 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); } diff --git a/libguile/strings.c b/libguile/strings.c index 1b241e52c..1f492bd0c 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011, 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 @@ -29,6 +29,7 @@ #include #include #include +#include #include "striconveh.h" @@ -36,6 +37,8 @@ #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" @@ -126,7 +129,7 @@ make_stringbuf (size_t len) 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); @@ -153,7 +156,7 @@ make_wide_stringbuf (size_t len) #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); @@ -240,7 +243,7 @@ scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; #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. */ @@ -258,6 +261,23 @@ scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; #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 ("#", port); +} + SCM scm_nullstr; /* Create a scheme string with space for LEN 8-bit Latin-1-encoded @@ -1502,6 +1522,23 @@ scm_decoding_error (const char *subr, int err, const char *message, SCM port) /* 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) @@ -1517,14 +1554,11 @@ scm_from_stringn (const char *str, size_t len, const char *encoding, 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, @@ -1535,19 +1569,7 @@ scm_from_stringn (const char *str, size_t len, const char *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) @@ -1621,7 +1643,81 @@ scm_from_utf8_string (const char *str) 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 @@ -1646,6 +1742,28 @@ scm_from_utf32_stringn (const scm_t_wchar *str, size_t len) 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 @@ -2031,6 +2149,27 @@ scm_to_utf32_stringn (SCM str, size_t *lenp) } #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 @@ -2064,7 +2203,8 @@ scm_to_stringn (SCM str, size_t *lenp, const char *encoding, "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. */ @@ -2320,66 +2460,6 @@ scm_i_get_substring_spec (size_t len, *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) { diff --git a/libguile/strings.h b/libguile/strings.h index 42e57ace3..130c436a6 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -3,7 +3,7 @@ #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 @@ -153,6 +153,11 @@ SCM_API scm_t_wchar *scm_to_utf32_stringn (SCM str, size_t *lenp); 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); @@ -174,6 +179,8 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv); #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. */ @@ -235,21 +242,6 @@ SCM_API SCM scm_sys_stringbuf_hist (void); -/* 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 */ diff --git a/libguile/strports.c b/libguile/strports.c index d1b293c21..591089477 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -1,5 +1,5 @@ /* 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 @@ -57,10 +57,8 @@ /* 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: @@ -90,14 +88,14 @@ scm_t_bits scm_tc16_strport; 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 @@ -112,7 +110,7 @@ st_resize_port (scm_t_port *pt, scm_t_off new_size) 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; @@ -124,50 +122,29 @@ st_resize_port (scm_t_port *pt, scm_t_off 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 @@ -204,11 +181,10 @@ st_seek (SCM port, scm_t_off offset, int whence) 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) { @@ -261,10 +237,7 @@ st_truncate (SCM port, scm_t_off length) 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. */ @@ -278,81 +251,63 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) { 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 . */ - 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; } @@ -361,26 +316,12 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) 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, @@ -417,35 +358,27 @@ 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), @@ -563,10 +496,9 @@ scm_eval_string (SCM string) 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); diff --git a/libguile/strports.h b/libguile/strports.h index 3a9c3ec01..b4bafdfc0 100644 --- a/libguile/strports.h +++ b/libguile/strports.h @@ -3,7 +3,7 @@ #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 @@ -28,8 +28,7 @@ -#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) && \ diff --git a/libguile/struct.c b/libguile/struct.c index 3906a42cf..1b61aa4af 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -1,4 +1,5 @@ -/* 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 @@ -31,7 +32,6 @@ #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" @@ -517,6 +517,42 @@ scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits init, .. 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" @@ -532,8 +568,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, "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; @@ -561,61 +596,6 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, } #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" @@ -921,55 +901,6 @@ scm_struct_ihashq (SCM obj, unsigned long n, void *closure) 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}.") @@ -1007,22 +938,22 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) { 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 */ @@ -1030,19 +961,19 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) { 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); } } @@ -1094,9 +1025,6 @@ scm_init_struct () 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 } /* diff --git a/libguile/struct.h b/libguile/struct.h index 0b31cf52e..f1f6c4768 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -174,6 +174,7 @@ SCM_API SCM scm_applicable_struct_with_setter_vtable_vtable; 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, ...); @@ -181,9 +182,6 @@ SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits, scm_t_bits init[]); SCM_API SCM scm_make_vtable (SCM fields, SCM printer); SCM_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); @@ -193,8 +191,6 @@ SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *); SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2); SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *); -SCM_INTERNAL 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); diff --git a/libguile/symbols.c b/libguile/symbols.c index 08512a63f..f93833b9d 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -1,5 +1,5 @@ /* 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 @@ -23,6 +23,8 @@ # include #endif +#include + #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/eval.h" @@ -33,8 +35,7 @@ #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" @@ -52,7 +53,6 @@ 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, @@ -104,21 +104,13 @@ static SCM 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 @@ -144,63 +136,104 @@ lookup_interned_latin1_symbol (const char *str, size_t len, 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) { @@ -215,7 +248,12 @@ 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); } } @@ -491,14 +529,27 @@ scm_from_utf8_symbol (const char *sym) 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); } diff --git a/libguile/symbols.h b/libguile/symbols.h index 6106f9ef1..f345e7033 100644 --- a/libguile/symbols.h +++ b/libguile/symbols.h @@ -3,7 +3,7 @@ #ifndef SCM_SYMBOLS_H #define SCM_SYMBOLS_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 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 @@ -26,8 +26,7 @@ #include "libguile/__scm.h" -#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)) @@ -91,7 +90,7 @@ SCM_API SCM scm_take_utf8_symboln (char *sym, size_t len); /* 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); diff --git a/libguile/tags.h b/libguile/tags.h index c41543ffd..4a1b192dd 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -3,7 +3,7 @@ #ifndef SCM_TAGS_H #define SCM_TAGS_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,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 @@ -114,6 +114,11 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; # 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?'. @@ -124,51 +129,57 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; /* 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 @@ -202,69 +213,56 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; * 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) @@ -275,7 +273,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; * 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. * @@ -284,13 +282,13 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; * (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.) @@ -299,8 +297,8 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; * 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. * @@ -322,19 +320,19 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; * * 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 @@ -353,11 +351,12 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; -/* 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, @@ -365,7 +364,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; /* 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. */ @@ -398,6 +397,13 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #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 @@ -417,18 +423,18 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #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 @@ -448,7 +454,8 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; /* 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)) @@ -622,7 +629,7 @@ enum scm_tc8_tags 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:\ @@ -664,13 +671,6 @@ enum scm_tc8_tags -#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 */ /* diff --git a/libguile/threads.c b/libguile/threads.c index 8cbe1e22f..a67f30b30 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -25,6 +25,7 @@ #endif #include "libguile/bdw-gc.h" +#include #include "libguile/_scm.h" #include @@ -65,200 +66,42 @@ #include "libguile/init.h" #include "libguile/scmsigs.h" #include "libguile/strings.h" -#include "libguile/weaks.h" +#include "libguile/vm.h" #include -/* 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 */ - static void @@ -279,6 +122,7 @@ to_timespec (SCM t, scm_t_timespec *waittime) } } + /*** Queues */ @@ -400,11 +244,11 @@ thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) else id = u.um; - scm_puts ("#", port); + scm_puts_unlocked (")>", port); return 1; } @@ -546,7 +390,9 @@ guilify_self_1 (struct GC_stack_base *base) 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; @@ -561,6 +407,7 @@ guilify_self_1 (struct GC_stack_base *base) 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 @@ -569,8 +416,6 @@ guilify_self_1 (struct GC_stack_base *base) 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; @@ -580,7 +425,7 @@ guilify_self_1 (struct GC_stack_base *base) 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); @@ -613,13 +458,16 @@ guilify_self_2 (SCM parent) 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; @@ -666,10 +514,6 @@ do_thread_exit (void *v) { 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; @@ -690,9 +534,9 @@ do_thread_exit (void *v) 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); @@ -707,7 +551,7 @@ do_thread_exit (void *v) 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); @@ -780,6 +624,12 @@ on_thread_exit (void *v) 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 @@ -834,7 +684,7 @@ scm_i_init_thread_for_guile (struct GC_stack_base *base, SCM parent) */ 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 @@ -933,7 +783,7 @@ with_guile_and_parent (struct GC_stack_base *base, void *data) #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; @@ -967,7 +817,7 @@ scm_without_guile (void *(*func)(void *), void *data) 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 @@ -1308,21 +1158,13 @@ SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0, #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 ("#", port); + scm_puts_unlocked (">", port); return 1; } @@ -1331,9 +1173,12 @@ make_fat_mutex (int recursive, int unchecked_unlock, int external_unlock) { 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; @@ -1425,7 +1270,8 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret) 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); } @@ -1570,6 +1416,25 @@ typedef struct { #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) @@ -1614,7 +1479,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, 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); } @@ -1648,7 +1513,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, } t->block_asyncs--; - scm_async_click (); + scm_async_tick (); scm_remember_upto_here_2 (cond, mutex); @@ -1662,7 +1527,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, 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); } @@ -1758,9 +1623,9 @@ static int fat_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED) { fat_cond *c = SCM_CONDVAR_DATA (cv); - scm_puts ("#", port); + scm_puts_unlocked (">", port); return 1; } @@ -2173,6 +2038,11 @@ scm_threads_prehistory (void *base) 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); } @@ -2188,7 +2058,6 @@ scm_init_threads () 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)); diff --git a/libguile/threads.h b/libguile/threads.h index 901c37bb2..d34e1abf7 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -4,7 +4,7 @@ #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 @@ -28,8 +28,8 @@ #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 @@ -72,15 +72,12 @@ typedef struct scm_i_thread { 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. */ @@ -108,7 +105,7 @@ typedef struct scm_i_thread { 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__ @@ -144,9 +141,6 @@ SCM_INTERNAL void scm_init_thread_procs (void); SCM_INTERNAL void scm_init_threads_default_dynamic_state (void); -#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); @@ -204,12 +198,8 @@ SCM_INTERNAL SCM_THREAD_LOCAL scm_i_thread *scm_i_current_thread; # 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 diff --git a/libguile/throw.c b/libguile/throw.c index 7fc9edff7..244bcf153 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -1,4 +1,4 @@ -/* 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 @@ -322,16 +322,22 @@ scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args) 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; } @@ -364,7 +370,7 @@ handler_message (void *handler_data, SCM tag, SCM args) 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); @@ -450,7 +456,11 @@ SCM_SYMBOL (sym_pre_init_catch_tag, "%pre-init-catch-tag"); 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)) @@ -458,22 +468,34 @@ pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM 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; } @@ -481,14 +503,10 @@ pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) 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; } @@ -497,7 +515,7 @@ static SCM 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; diff --git a/libguile/uniform.c b/libguile/uniform.c index a58242d81..f8cd2d37b 100644 --- a/libguile/uniform.c +++ b/libguile/uniform.c @@ -132,6 +132,25 @@ SCM_DEFINE (scm_uniform_vector_element_type, "uniform-vector-element-type", 1, 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" diff --git a/libguile/uniform.h b/libguile/uniform.h index f0d5915f6..f655a29e2 100644 --- a/libguile/uniform.h +++ b/libguile/uniform.h @@ -3,7 +3,7 @@ #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 @@ -47,6 +47,7 @@ SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h) 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); diff --git a/libguile/validate.h b/libguile/validate.h index 0bdc057f9..68ff3744d 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -4,7 +4,7 @@ #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 @@ -293,8 +293,6 @@ #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); \ @@ -353,7 +351,7 @@ #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) diff --git a/libguile/values.c b/libguile/values.c index ef27cadd1..670e22294 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -60,9 +60,9 @@ print_values (SCM obj, SCM pwps) SCM port = SCM_PORT_WITH_PS_PORT (pwps); scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps)); - scm_puts ("#", port); + scm_puts_unlocked (">", port); return SCM_UNSPECIFIED; } diff --git a/libguile/variable.c b/libguile/variable.c index a9cc60e20..7b3f3356c 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -36,11 +36,11 @@ void scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts ("#', port); + scm_putc_unlocked('>', port); } diff --git a/libguile/variable.h b/libguile/variable.h index 20daf853f..c024c8519 100644 --- a/libguile/variable.h +++ b/libguile/variable.h @@ -3,7 +3,7 @@ #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 @@ -30,7 +30,7 @@ /* 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)) diff --git a/libguile/vectors.c b/libguile/vectors.c index b386debf4..920ead10e 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -68,9 +68,7 @@ scm_vector_elements (SCM vec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { if (SCM_I_WVECTP (vec)) - /* FIXME: We should check each (weak) element of the vector for NULL and - convert it to SCM_BOOL_F. */ - abort (); + scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector"); scm_generalized_vector_get_handle (vec, h); if (lenp) @@ -87,9 +85,7 @@ scm_vector_writable_elements (SCM vec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { if (SCM_I_WVECTP (vec)) - /* FIXME: We should check each (weak) element of the vector for NULL and - convert it to SCM_BOOL_F. */ - abort (); + scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector"); scm_generalized_vector_get_handle (vec, h); if (lenp) @@ -124,7 +120,7 @@ scm_vector_length (SCM v) 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 @@ -206,43 +202,33 @@ scm_vector_ref (SCM v, SCM k) 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); @@ -270,44 +256,37 @@ scm_vector_set_x (SCM v, SCM k, SCM obj) 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"); } @@ -335,28 +314,17 @@ SCM 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 @@ -385,72 +353,6 @@ SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0, #undef FUNC_NAME -/* 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; -} - - - 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" diff --git a/libguile/vectors.h b/libguile/vectors.h index 3746e9026..4fe72b0a4 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -3,7 +3,7 @@ #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 @@ -63,31 +63,14 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec, /* 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); diff --git a/libguile/vm-builtins.h b/libguile/vm-builtins.h new file mode 100644 index 000000000..5e31a04d8 --- /dev/null +++ b/libguile/vm-builtins.h @@ -0,0 +1,47 @@ +/* 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_ */ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c dissimilarity index 69% index 12e62d52d..68a8b12aa 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1,179 +1,3270 @@ -/* 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 -#include -#include -#include -#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. + + + */ + + +/* 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; + + + + + /* + * 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); + } + + + + + /* + * 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); + } + + + + + /* + * 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); + } + + + + + /* + * 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); + } + + + + + /* + * 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); + } + + + + + /* + * 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); + } + + + + /* + * 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); + } + + + + /* + * 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); + } + + + + + /* + * 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); + } + + + + /* + * 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); + } + + + + + /* + * 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); + } + + + + + /* + * 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); + } + + + + + /* + * 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: +*/ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h deleted file mode 100644 index 46d4cfff0..000000000 --- a/libguile/vm-engine.h +++ /dev/null @@ -1,404 +0,0 @@ -/* 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 */ - - -/* - * 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 - - -/* - * 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 (); \ -} - - -/* - * 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 - - -/* - * 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 ()) - - -/* - * 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) - - -#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) - - -/* - * 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 (); \ -} - - -/* 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: -*/ diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c deleted file mode 100644 index c3231568e..000000000 --- a/libguile/vm-i-loader.c +++ /dev/null @@ -1,134 +0,0 @@ -/* 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: -*/ diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c deleted file mode 100644 index fc32ec5a8..000000000 --- a/libguile/vm-i-scheme.c +++ /dev/null @@ -1,1054 +0,0 @@ -/* 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 */ - - -/* - * 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))); -} - - -/* - * 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; -} - - -/* - * 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); -} - - -/* - * 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)); -} - - -/* - * 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; -} - - -/* - * 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)); -} - - -/* - * 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; -} - - -/* - * 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: -*/ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c deleted file mode 100644 index e54a99ba6..000000000 --- a/libguile/vm-i-system.c +++ /dev/null @@ -1,1706 +0,0 @@ -/* 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 */ - - -/* - * 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; -} - - -/* - * 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; -} - - -/* - * 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; -} - - -/* - * 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)); -} - - -/* - * 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: -*/ diff --git a/libguile/vm.c b/libguile/vm.c index 62c1d6d88..5a6958900 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -16,6 +16,9 @@ * 02110-1301 USA */ +/* For mremap(2) on GNU/Linux systems. */ +#define _GNU_SOURCE + #if HAVE_CONFIG_H # include #endif @@ -26,6 +29,10 @@ #include #include +#ifdef HAVE_SYS_MMAN_H +#include +#endif + #include "libguile/bdw-gc.h" #include @@ -33,11 +40,11 @@ #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; @@ -53,29 +60,8 @@ static SCM sym_debug; 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 - /* @@ -85,9 +71,9 @@ static SCM sym_debug; void scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) { - scm_puts ("#", port); + scm_puts_unlocked (">", port); } /* In theory, a number of vm instances can be active in the call trace, and we @@ -102,8 +88,8 @@ scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) 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; @@ -111,97 +97,84 @@ scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint8 *ra, 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)) @@ -219,76 +192,127 @@ vm_dispatch_hook (SCM vm, int hook_num) 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)); @@ -303,112 +327,63 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds, 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 } -/* - * 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 ("#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); -} - - /* * 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) @@ -448,13 +423,6 @@ vm_error_not_a_variable (const char *func_name, SCM x) 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) { @@ -505,20 +473,6 @@ vm_error_wrong_type_apply (SCM proc) 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) { @@ -562,6 +516,13 @@ vm_error_not_enough_values (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) { @@ -574,134 +535,247 @@ vm_error_bad_wide_string_length (size_t len) vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len)); } -#ifdef VM_CHECK_IP -static void -vm_error_invalid_address (void) + + + +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 - +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); +} /* * 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; @@ -709,127 +783,199 @@ make_vm (void) 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 ). */ - 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 { @@ -837,8 +983,8 @@ SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, } #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 { @@ -846,8 +992,8 @@ SCM_DEFINE (scm_vm_push_continuation_hook, "vm-push-continuation-hook", 1, 0, 0, } #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 { @@ -855,8 +1001,8 @@ SCM_DEFINE (scm_vm_pop_continuation_hook, "vm-pop-continuation-hook", 1, 0, 0, } #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 { @@ -864,8 +1010,8 @@ SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0, } #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 { @@ -873,32 +1019,21 @@ SCM_DEFINE (scm_vm_abort_continuation_hook, "vm-abort-continuation-hook", 1, 0, } #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 @@ -935,36 +1070,33 @@ vm_engine_to_symbol (int engine, const char *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 @@ -991,63 +1123,15 @@ SCM_DEFINE (scm_set_default_vm_engine_x, "set-default-vm-engine!", 1, 0, 0, } #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 @@ -1056,39 +1140,33 @@ SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1, * 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 @@ -1097,6 +1175,10 @@ scm_bootstrap_vm (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 (); @@ -1106,15 +1188,15 @@ scm_bootstrap_vm (void) 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 diff --git a/libguile/vm.h b/libguile/vm.h index d354a53c0..6a257328e 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -1,4 +1,4 @@ -/* 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 @@ -28,88 +28,74 @@ enum { 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); diff --git a/libguile/vports.c b/libguile/vports.c index 75e7df303..e7263302b 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -1,4 +1,4 @@ -/* 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 @@ -28,6 +28,8 @@ #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" @@ -86,15 +88,15 @@ sf_fill_input (SCM port) { 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); @@ -104,7 +106,7 @@ sf_fill_input (SCM port) return *pt->read_buf; } else - scm_ungetc (SCM_CHAR (ans), port); + scm_ungetc_unlocked (SCM_CHAR (ans), port); return SCM_CHAR (ans); } @@ -188,7 +190,6 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, #define FUNC_NAME s_scm_make_soft_port { int vlen; - scm_t_port *pt; SCM z; SCM_VALIDATE_VECTOR (1, pv); @@ -196,14 +197,10 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, 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 diff --git a/libguile/weak-set.c b/libguile/weak-set.c new file mode 100644 index 000000000..e8523ba62 --- /dev/null +++ b/libguile/weak-set.c @@ -0,0 +1,892 @@ +/* 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 + */ + + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#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; +} + + + + +/* 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); +} + + + + +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; + } +} + + + +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: +*/ diff --git a/libguile/weak-set.h b/libguile/weak-set.h new file mode 100644 index 000000000..86781c78a --- /dev/null +++ b/libguile/weak-set.h @@ -0,0 +1,69 @@ +/* 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 + */ + + + +#include "libguile/__scm.h" + + + +/* 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: +*/ diff --git a/libguile/weak-table.c b/libguile/weak-table.c new file mode 100644 index 000000000..e91106988 --- /dev/null +++ b/libguile/weak-table.c @@ -0,0 +1,1157 @@ +/* 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 + */ + + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#include "libguile/bdw-gc.h" +#include + +#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; +} + + + + +/* 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; +} + + + +/* 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); +} + + + + +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; + } +} + + + +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 + + + + +/* 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 + + + + + +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: +*/ diff --git a/libguile/weak-table.h b/libguile/weak-table.h new file mode 100644 index 000000000..f516c2601 --- /dev/null +++ b/libguile/weak-table.h @@ -0,0 +1,94 @@ +/* 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 + */ + + + +#include "libguile/__scm.h" + + + +/* 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); + + + +/* 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); + + + +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: +*/ diff --git a/libguile/weak-vector.c b/libguile/weak-vector.c new file mode 100644 index 000000000..30e2ed63f --- /dev/null +++ b/libguile/weak-vector.c @@ -0,0 +1,208 @@ +/* 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 + */ + + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#include "libguile/_scm.h" +#include "libguile/vectors.h" + +#include "libguile/validate.h" + + + +/* {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)); +} + + + +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: +*/ diff --git a/libguile/weak-vector.h b/libguile/weak-vector.h new file mode 100644 index 000000000..1fd7cb5ec --- /dev/null +++ b/libguile/weak-vector.h @@ -0,0 +1,48 @@ +/* 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 + */ + + + +#include "libguile/__scm.h" + + +/* 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: +*/ diff --git a/libguile/weaks.c b/libguile/weaks.c deleted file mode 100644 index 79ae1fee5..000000000 --- a/libguile/weaks.c +++ /dev/null @@ -1,291 +0,0 @@ -/* 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 - */ - - - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include - -#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 - - - -/* 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)); -} - - - - -/* 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 - - -/* 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 - - - - -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: -*/ diff --git a/libguile/weaks.h b/libguile/weaks.h deleted file mode 100644 index fc16f8bf8..000000000 --- a/libguile/weaks.h +++ /dev/null @@ -1,101 +0,0 @@ -/* 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 - */ - - - -#include "libguile/__scm.h" - - - -#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) - - -/* 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)) - - - -/* 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: -*/ diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 379f6b72c..d41ec7b22 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -75,6 +75,7 @@ gl_MODULES([ isfinite isinf isnan + largefile ldexp lib-symbol-versions lib-symbol-visibility diff --git a/meta/Makefile.am b/meta/Makefile.am index 2d3c462a4..b96483bbd 100644 --- a/meta/Makefile.am +++ b/meta/Makefile.am @@ -24,7 +24,7 @@ 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'. @@ -37,7 +37,7 @@ install-exec-hook: $(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. diff --git a/meta/guile-2.0-uninstalled.pc.in b/meta/guile-2.2-uninstalled.pc.in similarity index 100% rename from meta/guile-2.0-uninstalled.pc.in rename to meta/guile-2.2-uninstalled.pc.in diff --git a/meta/guile-2.0.pc.in b/meta/guile-2.2.pc.in similarity index 100% rename from meta/guile-2.0.pc.in rename to meta/guile-2.2.pc.in diff --git a/meta/guile-config.in b/meta/guile-config.in index 0226f685e..b3e4c3d94 100755 --- a/meta/guile-config.in +++ b/meta/guile-config.in @@ -8,7 +8,7 @@ exec "@installed_guile@" -e main -s $0 "$@" ;;;; guile-config --- utility for linking programs with Guile ;;;; Jim Blandy --- 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 @@ -77,7 +77,7 @@ exec "@installed_guile@" -e main -s $0 "$@" (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)) diff --git a/module/Makefile.am b/module/Makefile.am index e8dcd4a13..64ded639c 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -24,45 +24,49 @@ include $(top_srcdir)/am/guilec # 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) \ @@ -81,15 +85,14 @@ ETAGS_ARGS += \ 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)" \ @@ -109,24 +112,29 @@ TREE_IL_LANG_SOURCES = \ 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 @@ -142,6 +150,7 @@ ECMASCRIPT_LANG_SOURCES = \ language/ecmascript/spec.scm ELISP_LANG_SOURCES = \ + language/elisp/falias.scm \ language/elisp/lexer.scm \ language/elisp/parser.scm \ language/elisp/bindings.scm \ @@ -149,8 +158,6 @@ ELISP_LANG_SOURCES = \ 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 = \ @@ -190,7 +197,6 @@ SYSTEM_BASE_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 \ @@ -218,6 +224,12 @@ ICE_9_SOURCES = \ 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 \ @@ -345,12 +357,13 @@ SYSTEM_SOURCES = \ 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 \ @@ -391,6 +404,9 @@ WEB_SOURCES = \ EXTRA_DIST += oop/ChangeLog-2008 +ELISP_SOURCES = \ + language/elisp/boot.el + NOCOMP_SOURCES = \ ice-9/match.upstream.scm \ ice-9/psyntax.scm \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 19c22eabb..83e5480d2 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -51,19 +51,29 @@ (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. @@ -97,13 +107,14 @@ (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 @@ -149,12 +160,11 @@ non-locally, that exit determines the continuation." (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)))))) @@ -166,9 +176,9 @@ for key @var{k}, then invoke @var{thunk}." (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) @@ -186,10 +196,136 @@ If there is no handler at all, Guile prints an error and then exits." -;;; {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)))) + + + +;;; {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)) @@ -218,13 +354,11 @@ If there is no handler at all, Guile prints an error and then exits." (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))) @@ -586,6 +720,25 @@ If there is no handler at all, Guile prints an error and then exits." (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 () @@ -752,116 +905,6 @@ information is unavailable." -;;; -;;; 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)) - - - ;;; ;;; Extensible exception printing. ;;; @@ -1103,15 +1146,11 @@ VALUE." ;; 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))))) @@ -1160,6 +1199,16 @@ VALUE." +;;; {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))))) + + + ;;; {Structs} ;;; @@ -1224,10 +1273,14 @@ VALUE." #,@(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 @@ -1268,64 +1321,369 @@ VALUE." (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) + + + +;;; {Parameters} +;;; + +(define + ;; Three fields: the procedure itself, the fluid, and the converter. + (make-struct 0 'pwprpr)) +(set-struct-vtable-name! ') + +(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 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) ))) + +(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 0 + (case-lambda + (() (fluid-ref fluid)) + ((x) (let ((prev (fluid-ref fluid))) + (fluid-set! fluid (conv x)) + prev))) + fluid conv)) + + + +;;; Once parameters have booted, define the default prompt tag as being +;;; a parameter. +;;; + +(set! default-prompt-tag (make-parameter (default-prompt-tag))) + + + +;;; 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")) + + + +;;; {Warnings} +;;; + +(define current-warning-port + (make-parameter (current-error-port) + (lambda (x) + (if (output-port? x) + x + (error "expected an output port" x))))) + + + + +;;; {Languages} +;;; + +;; The language can be a symbolic name or a object from +;; (system base language). +;; +(define current-language (make-parameter 'scheme)) + + + + +;;; {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)))) @@ -1376,7 +1734,7 @@ VALUE." (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))))) @@ -1387,8 +1745,8 @@ VALUE." (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))))) @@ -1818,7 +2176,7 @@ VALUE." ((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))) @@ -1877,14 +2235,21 @@ VALUE." (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))))) @@ -1953,10 +2318,6 @@ VALUE." ;; 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) @@ -1969,7 +2330,7 @@ VALUE." (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)) @@ -2289,33 +2650,6 @@ VALUE." (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))) - ;;; {Module-based Loading} @@ -3119,145 +3453,6 @@ but it fails to load." -;;; {Parameters} -;;; - -(define - ;; Three fields: the procedure itself, the fluid, and the converter. - (make-struct 0 'pwprpr)) -(set-struct-vtable-name! ') - -(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 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 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) ))) - -(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* ...))))))) - - -;;; -;;; 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")) - - - -;;; -;;; Warnings. -;;; - -(define current-warning-port - (make-parameter (current-error-port) - (lambda (x) - (if (output-port? x) - x - (error "expected an output port" x))))) - - - -;;; -;;; Languages. -;;; - -;; The language can be a symbolic name or a object from -;; (system base language). -;; -(define current-language (make-parameter 'scheme)) - - - - ;;; {Running Repls} ;;; @@ -3334,16 +3529,6 @@ CONV is not applied to the initial value." -;;; {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))))) - - - ;;; {While} ;;; ;;; with `continue' and `break'. @@ -3568,13 +3753,6 @@ CONV is not applied to the initial value." (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) @@ -4026,12 +4204,11 @@ when none is available, reading FILE-NAME with READER." ;; 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 diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm index bd1931692..7da0a6b15 100644 --- a/module/ice-9/command-line.scm +++ b/module/ice-9/command-line.scm @@ -32,7 +32,7 @@ ;;; (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+* @@ -422,7 +422,7 @@ If FILE begins with `-' the -s switch is mandatory. (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 diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index 201ae395e..21d639fa1 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -1,6 +1,6 @@ ;;; -*- 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 @@ -73,13 +73,13 @@ 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. @@ -99,9 +99,9 @@ (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) diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm dissimilarity index 97% index 56b9c0495..9835c1230 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -1,908 +1,19 @@ -;;;; 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))) - - - -;; 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))) - - -(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")) - - - -;;; {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)))))))) - - - -;;; {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* ...))))))) - - - - -(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 ()) diff --git a/module/ice-9/eval-string.scm b/module/ice-9/eval-string.scm index 649551d9f..3cf73b9b5 100644 --- a/module/ice-9/eval-string.scm +++ b/module/ice-9/eval-string.scm @@ -22,6 +22,7 @@ #: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) @@ -84,5 +85,6 @@ (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)))))))) diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index c9711134c..f95bbe90a 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -1,6 +1,6 @@ ;;; -*- 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 @@ -43,19 +43,83 @@ (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 @@ -79,28 +143,77 @@ #`((#,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) @@ -179,8 +292,8 @@ (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 ...))))))) @@ -203,8 +316,6 @@ ;;; module-ref: 14468 ;;; define: 1259 ;;; toplevel-set: 328 -;;; dynwind: 162 -;;; with-fluids: 0 ;;; call/cc: 0 ;;; module-set: 0 ;;; @@ -214,8 +325,9 @@ (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)) @@ -224,7 +336,7 @@ ;; 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)) @@ -262,125 +374,110 @@ 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))) @@ -390,10 +487,7 @@ (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) @@ -404,37 +498,28 @@ 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) @@ -450,40 +535,25 @@ (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))) @@ -503,4 +573,4 @@ (if (macroexpanded? exp) exp ((module-transformer (current-module)) exp))) - '())))) + #f)))) diff --git a/module/ice-9/format.scm b/module/ice-9/format.scm index eed8cbb0e..1ef4cb5ef 100644 --- a/module/ice-9/format.scm +++ b/module/ice-9/format.scm @@ -1,5 +1,5 @@ ;;;; "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 @@ -42,10 +42,7 @@ (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) diff --git a/module/ice-9/local-eval.scm b/module/ice-9/local-eval.scm index 28f30b991..493dbed0d 100644 --- a/module/ice-9/local-eval.scm +++ b/module/ice-9/local-eval.scm @@ -180,7 +180,11 @@ 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) diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm index 4609883d2..3d6655548 100644 --- a/module/ice-9/match.upstream.scm +++ b/module/ice-9/match.upstream.scm @@ -280,14 +280,20 @@ ;; 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)))) diff --git a/module/ice-9/peg.scm b/module/ice-9/peg.scm new file mode 100644 index 000000000..4e03131cd --- /dev/null +++ b/module/ice-9/peg.scm @@ -0,0 +1,42 @@ +;;;; 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?)) + diff --git a/module/ice-9/peg/cache.scm b/module/ice-9/peg/cache.scm new file mode 100644 index 000000000..f45432b35 --- /dev/null +++ b/module/ice-9/peg/cache.scm @@ -0,0 +1,45 @@ +;;;; 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)))))) diff --git a/module/ice-9/peg/codegen.scm b/module/ice-9/peg/codegen.scm new file mode 100644 index 000000000..d80c3e849 --- /dev/null +++ b/module/ice-9/peg/codegen.scm @@ -0,0 +1,359 @@ +;;;; 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)))) diff --git a/module/ice-9/peg/simplify-tree.scm b/module/ice-9/peg/simplify-tree.scm new file mode 100644 index 000000000..4c781a191 --- /dev/null +++ b/module/ice-9/peg/simplify-tree.scm @@ -0,0 +1,97 @@ +;;;; 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)) diff --git a/module/ice-9/peg/string-peg.scm b/module/ice-9/peg/string-peg.scm new file mode 100644 index 000000000..45ed14bb1 --- /dev/null +++ b/module/ice-9/peg/string-peg.scm @@ -0,0 +1,273 @@ +;;;; 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 (? (/ "*" "?" "+"))) +(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) + diff --git a/module/ice-9/peg/using-parsers.scm b/module/ice-9/peg/using-parsers.scm new file mode 100644 index 000000000..076de2999 --- /dev/null +++ b/module/ice-9/peg/using-parsers.scm @@ -0,0 +1,116 @@ +;;;; 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)) diff --git a/module/ice-9/poll.scm b/module/ice-9/poll.scm index 2ba868748..1633dcbc5 100644 --- a/module/ice-9/poll.scm +++ b/module/ice-9/poll.scm @@ -1,6 +1,6 @@ ;; 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 @@ -139,13 +139,7 @@ (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) diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm index 5c23cb009..1573c6fd5 100644 --- a/module/ice-9/pretty-print.scm +++ b/module/ice-9/pretty-print.scm @@ -1,7 +1,7 @@ ;;;; -*- 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 @@ -311,142 +311,138 @@ e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to \"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))))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 7b801ad24..eeffecf38 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -47,19 +47,22 @@ 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 @@ -73,7 +76,7 @@ (make-let (lambda (src names gensyms vals body) (make-struct - (vector-ref %expanded-vtables 15) + (vector-ref %expanded-vtables 16) 0 src names @@ -83,7 +86,7 @@ (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? @@ -91,19 +94,10 @@ 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))) @@ -121,15 +115,16 @@ (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)) @@ -142,15 +137,12 @@ (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 @@ -174,6 +166,8 @@ (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) @@ -206,15 +200,15 @@ (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) @@ -231,10 +225,7 @@ (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) @@ -285,15 +276,9 @@ (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? @@ -374,43 +359,53 @@ (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) @@ -447,20 +442,29 @@ 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))) @@ -477,9 +481,27 @@ (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)) @@ -525,162 +547,151 @@ (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 '(())))) @@ -691,24 +702,23 @@ (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 @@ -717,7 +727,9 @@ (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) @@ -729,7 +741,7 @@ 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)) @@ -819,10 +831,10 @@ ((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 @@ -835,7 +847,7 @@ 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) @@ -845,11 +857,21 @@ 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 @@ -858,15 +880,10 @@ (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 @@ -905,12 +922,12 @@ (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 @@ -954,11 +971,14 @@ (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)) @@ -990,7 +1010,7 @@ (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))) @@ -1002,6 +1022,19 @@ (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 @@ -1516,28 +1549,34 @@ (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) @@ -1560,15 +1599,16 @@ ((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)) @@ -1678,8 +1718,7 @@ (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) @@ -1892,41 +1931,41 @@ (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)) @@ -1936,7 +1975,7 @@ #f "source expression failed to match any pattern" tmp-1)))))) - (build-application + (build-call s (expand (list '#(syntax-object setter ((top)) (hygiene guile)) head) @@ -1949,7 +1988,7 @@ (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)) @@ -1969,7 +2008,7 @@ (global-extend 'module-ref '@@ - (lambda (e r w) + (lambda (e r w mod) (letrec* ((remodulate (lambda (x mod) @@ -1988,33 +2027,46 @@ (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 @@ -2041,24 +2093,6 @@ #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 '()) @@ -2137,9 +2171,9 @@ (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) @@ -2168,7 +2202,7 @@ (syntax-violation 'syntax-case "misplaced ellipsis" pat)) (else (let ((y (gen-var 'tmp))) - (build-application + (build-call #f (build-simple-lambda #f @@ -2190,17 +2224,14 @@ (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)) @@ -2214,7 +2245,7 @@ (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 @@ -2244,7 +2275,7 @@ (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 @@ -2329,9 +2360,12 @@ (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))) @@ -2350,14 +2384,20 @@ (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) @@ -2553,13 +2593,22 @@ (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 @@ -2578,13 +2627,22 @@ (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 @@ -2684,11 +2742,32 @@ 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)))) @@ -3081,7 +3160,16 @@ '(#(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)) '() diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 5f1bd8ae4..5368785c2 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -295,15 +295,16 @@ (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) @@ -322,18 +323,14 @@ (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))) @@ -358,6 +355,8 @@ (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 @@ -411,12 +410,14 @@ (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)) @@ -424,7 +425,7 @@ (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) @@ -445,8 +446,8 @@ (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) @@ -491,13 +492,14 @@ ;; 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. ;; ::= ((