summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore4
-rw-r--r--GUILE-VERSION10
-rw-r--r--configure.ac6
-rw-r--r--doc/example-smob/Makefile4
-rw-r--r--doc/guile.12
-rw-r--r--doc/ref/compiler.texi55
-rw-r--r--doc/ref/libguile-concepts.texi24
-rw-r--r--doc/ref/srfi-modules.texi4
-rw-r--r--doc/ref/vm.texi8
-rw-r--r--libguile.h4
-rw-r--r--libguile/Makefile.am16
-rw-r--r--libguile/__scm.h369
-rw-r--r--libguile/_scm.h58
-rw-r--r--libguile/alist.c6
-rw-r--r--libguile/arbiters.c8
-rw-r--r--libguile/array-handle.c4
-rw-r--r--libguile/array-map.c10
-rw-r--r--libguile/arrays.c36
-rw-r--r--libguile/async.c72
-rw-r--r--libguile/async.h14
-rw-r--r--libguile/backtrace.c38
-rw-r--r--libguile/bitvectors.c4
-rw-r--r--libguile/bytevectors.c45
-rw-r--r--libguile/bytevectors.h10
-rw-r--r--libguile/chars.c4
-rw-r--r--libguile/continuations.c25
-rw-r--r--libguile/control.c4
-rw-r--r--libguile/control.h2
-rw-r--r--libguile/debug.c13
-rw-r--r--libguile/debug.h14
-rw-r--r--libguile/deprecated.c2563
-rw-r--r--libguile/deprecated.h817
-rw-r--r--libguile/deprecation.c2
-rw-r--r--libguile/dynl.c6
-rw-r--r--libguile/dynwind.c2
-rw-r--r--libguile/eq.c2
-rw-r--r--libguile/error.h12
-rw-r--r--libguile/eval.c15
-rw-r--r--libguile/evalext.c2
-rw-r--r--libguile/evalext.h8
-rw-r--r--libguile/expand.c43
-rw-r--r--libguile/expand.h51
-rw-r--r--libguile/feature.c10
-rw-r--r--libguile/filesys.c10
-rw-r--r--libguile/filesys.h4
-rw-r--r--libguile/fluids.c16
-rw-r--r--libguile/fluids.h6
-rw-r--r--libguile/foreign.c27
-rw-r--r--libguile/foreign.h3
-rw-r--r--libguile/fports.c49
-rw-r--r--libguile/fports.h4
-rw-r--r--libguile/frames.c6
-rw-r--r--libguile/frames.h2
-rw-r--r--libguile/gc-malloc.c104
-rw-r--r--libguile/gc.c15
-rw-r--r--libguile/gc.h178
-rw-r--r--libguile/gdbint.c8
-rw-r--r--libguile/gen-scmconfig.c15
-rw-r--r--libguile/goops.c139
-rw-r--r--libguile/goops.h24
-rw-r--r--libguile/gsubr.c10
-rw-r--r--libguile/guardians.c50
-rw-r--r--libguile/guile.c14
-rw-r--r--libguile/hash.c376
-rw-r--r--libguile/hash.h1
-rw-r--r--libguile/hashtab.c708
-rw-r--r--libguile/hashtab.h34
-rw-r--r--libguile/hooks.c18
-rw-r--r--libguile/init.c11
-rw-r--r--libguile/inline.c8
-rw-r--r--libguile/inline.h277
-rw-r--r--libguile/instructions.c2
-rw-r--r--libguile/ioext.c16
-rw-r--r--libguile/keywords.c4
-rw-r--r--libguile/list.c2
-rw-r--r--libguile/load.c34
-rw-r--r--libguile/macros.c10
-rw-r--r--libguile/mallocs.c6
-rw-r--r--libguile/memoize.c71
-rw-r--r--libguile/memoize.h4
-rw-r--r--libguile/modules.c40
-rw-r--r--libguile/numbers.c527
-rw-r--r--libguile/numbers.h17
-rw-r--r--libguile/objcodes.c18
-rw-r--r--libguile/objcodes.h2
-rw-r--r--libguile/objprop.c28
-rw-r--r--libguile/options.c42
-rw-r--r--libguile/ports.c2431
-rw-r--r--libguile/ports.h294
-rw-r--r--libguile/print.c149
-rw-r--r--libguile/private-gc.h14
-rw-r--r--libguile/procprop.c85
-rw-r--r--libguile/procprop.h5
-rw-r--r--libguile/procs.c24
-rw-r--r--libguile/programs.c12
-rw-r--r--libguile/programs.h4
-rw-r--r--libguile/promises.c4
-rw-r--r--libguile/pthread-threads.h20
-rw-r--r--libguile/r6rs-ports.c118
-rw-r--r--libguile/rdelim.c6
-rw-r--r--libguile/read.c131
-rw-r--r--libguile/rw.c4
-rw-r--r--libguile/scmsigs.c27
-rw-r--r--libguile/smob.c122
-rw-r--r--libguile/smob.h160
-rw-r--r--libguile/snarf.h13
-rw-r--r--libguile/socket.c157
-rw-r--r--libguile/srcprop.c72
-rw-r--r--libguile/srfi-14.c18
-rw-r--r--libguile/srfi-14.h4
-rw-r--r--libguile/srfi-4.c5
-rw-r--r--libguile/srfi-4.h12
-rw-r--r--libguile/stackchk.c11
-rw-r--r--libguile/stackchk.h4
-rw-r--r--libguile/strings.c173
-rw-r--r--libguile/strings.h15
-rw-r--r--libguile/strports.c33
-rw-r--r--libguile/strports.h5
-rw-r--r--libguile/struct.c62
-rw-r--r--libguile/struct.h5
-rw-r--r--libguile/symbols.c161
-rw-r--r--libguile/symbols.h7
-rw-r--r--libguile/tags.h252
-rw-r--r--libguile/threads.c53
-rw-r--r--libguile/threads.h3
-rw-r--r--libguile/throw.c14
-rw-r--r--libguile/validate.h4
-rw-r--r--libguile/values.c4
-rw-r--r--libguile/variable.c6
-rw-r--r--libguile/variable.h4
-rw-r--r--libguile/vectors.c190
-rw-r--r--libguile/vectors.h25
-rw-r--r--libguile/vm-i-scheme.c141
-rw-r--r--libguile/vm-i-system.c6
-rw-r--r--libguile/vm.c23
-rw-r--r--libguile/vm.h4
-rw-r--r--libguile/vports.c17
-rw-r--r--libguile/weak-set.c891
-rw-r--r--libguile/weak-set.h69
-rw-r--r--libguile/weak-table.c1160
-rw-r--r--libguile/weak-table.h94
-rw-r--r--libguile/weak-vector.c207
-rw-r--r--libguile/weak-vector.h48
-rw-r--r--libguile/weaks.c294
-rw-r--r--libguile/weaks.h101
-rw-r--r--m4/gnulib-cache.m41
-rw-r--r--meta/Makefile.am4
-rw-r--r--meta/guile-2.2-uninstalled.pc.in (renamed from meta/guile-2.0-uninstalled.pc.in)0
-rw-r--r--meta/guile-2.2.pc.in (renamed from meta/guile-2.0.pc.in)0
-rwxr-xr-xmeta/guile-config.in4
-rw-r--r--module/ice-9/boot-9.scm65
-rw-r--r--module/ice-9/deprecated.scm866
-rw-r--r--module/ice-9/eval.scm15
-rw-r--r--module/ice-9/psyntax-pp.scm42686
-rw-r--r--module/ice-9/psyntax.scm1129
-rw-r--r--module/ice-9/weak-vector.scm15
-rw-r--r--module/language/brainfuck/compile-tree-il.scm54
-rw-r--r--module/language/ecmascript/compile-tree-il.scm172
-rw-r--r--module/language/elisp/compile-tree-il.scm207
-rw-r--r--module/language/tree-il.scm163
-rw-r--r--module/language/tree-il/analyze.scm64
-rw-r--r--module/language/tree-il/canonicalize.scm14
-rw-r--r--module/language/tree-il/compile-glil.scm440
-rw-r--r--module/language/tree-il/debug.scm23
-rw-r--r--module/language/tree-il/fix-letrec.scm19
-rw-r--r--module/language/tree-il/peval.scm427
-rw-r--r--module/language/tree-il/primitives.scm75
-rw-r--r--module/language/tree-il/spec.scm6
-rw-r--r--module/oop/goops.scm200
-rw-r--r--module/srfi/srfi-35.scm16
-rw-r--r--module/system/foreign.scm4
-rw-r--r--test-suite/standalone/test-num2integral.c21
-rw-r--r--test-suite/tests/asm-to-bytecode.test7
-rw-r--r--test-suite/tests/r6rs-records-syntactic.test14
-rw-r--r--test-suite/tests/regexp.test2
-rw-r--r--test-suite/tests/syntax.test68
-rw-r--r--test-suite/tests/tree-il.test487
-rw-r--r--test-suite/tests/vlist.test4
-rw-r--r--test-suite/tests/weaks.test24
179 files changed, 28346 insertions, 34273 deletions
diff --git a/.gitignore b/.gitignore
index f13d7533e..edbb1f0c7 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
diff --git a/GUILE-VERSION b/GUILE-VERSION
index 1aa9fd4b1..71237e421 100644
--- a/GUILE-VERSION
+++ b/GUILE-VERSION
@@ -2,10 +2,10 @@
# Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'.
GUILE_MAJOR_VERSION=2
-GUILE_MINOR_VERSION=0
-GUILE_MICRO_VERSION=3
+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
@@ -18,7 +18,7 @@ GUILE_EFFECTIVE_VERSION=2.0
# See libtool info pages for more information on how and when to
# change these.
-LIBGUILE_INTERFACE_CURRENT=25
+LIBGUILE_INTERFACE_CURRENT=24
LIBGUILE_INTERFACE_REVISION=0
-LIBGUILE_INTERFACE_AGE=3
+LIBGUILE_INTERFACE_AGE=2
LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}"
diff --git a/configure.ac b/configure.ac
index 04553755b..5f9ead1e0 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1260,7 +1260,7 @@ 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])
+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_suspend_signal GC_move_disappearing_link GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes])
# 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
@@ -1658,8 +1658,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])
AC_CONFIG_FILES([doc/ref/effective-version.texi])
GUILE_CONFIG_SCRIPT([check-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/compiler.texi b/doc/ref/compiler.texi
index 86379c71b..3d6dbf327 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
+@c Copyright (C) 2008, 2009, 2010, 2011
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -158,12 +158,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
@@ -181,10 +180,10 @@ The Scheme-to-Tree-IL expander may be invoked using the generic
@lisp
(compile '(+ 1 2) #:from 'scheme #:to 'tree-il)
@result{}
- #<<application> src: #f
- proc: #<<toplevel-ref> src: #f name: +>
- args: (#<<const> src: #f exp: 1>
- #<<const> src: #f exp: 2>)>
+ #<<call> src: #f
+ proc: #<<toplevel-ref> src: #f name: +>
+ args: (#<<const> src: #f exp: 1>
+ #<<const> src: #f exp: 2>)>
@end lisp
Or, since Tree-IL is so close to Scheme, it is often useful to expand
@@ -339,9 +338,9 @@ instruction.
Compilation of Tree-IL usually begins with a pass that resolves some
@code{<module-ref>} and @code{<toplevel-ref>} expressions to
-@code{<primitive-ref>} expressions. The actual compilation pass
-has special cases for applications of certain primitives, like
-@code{apply} or @code{cons}.
+@code{<primitive-ref>} expressions. The actual compilation pass has
+special cases for calls to certain primitives, like @code{apply} or
+@code{cons}.
@end deftp
@deftp {Scheme Variable} <lexical-ref> src name gensym
@deftpx {External Representation} (lexical @var{name} @var{gensym})
@@ -385,10 +384,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} <application> src proc args
-@deftpx {External Representation} (apply @var{proc} . @var{args})
+@deftp {Scheme Variable} <call> src proc args
+@deftpx {External Representation} (call @var{proc} . @var{args})
A procedure call.
@end deftp
+@deftp {Scheme Variable} <primcall> src name args
+@deftpx {External Representation} (primcall @var{name} . @var{args})
+A call to a primitive. Equivalent to @code{(call (primitive @var{name})
+. @var{args})}. This construct is often more convenient to generate and
+analyze than @code{<call>}.
+
+As part of the compilation process, instances of @code{(call (primitive
+@var{name}) . @var{args})} are transformed into primcalls.
+@end deftp
@deftp {Scheme Variable} <sequence> src exps
@deftpx {External Representation} (begin . @var{exps})
Like Scheme's @code{begin}.
@@ -465,12 +473,15 @@ expression evaluating to a fluid.
A dynamic variable set. @var{fluid}, a Tree-IL expression evaluating
to a fluid, will be set to the result of evaluating @var{exp}.
@end deftp
-@deftp {Scheme Variable} <dynwind> winder body unwinder
-@deftpx {External Representation} (dynwind @var{winder} @var{body} @var{unwinder})
+@deftp {Scheme Variable} <dynwind> winder pre body post unwinder
+@deftpx {External Representation} (dynwind @var{winder} @var{pre} @var{body} @var{post} @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.
+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. Guile actually inlines the
+bodies of @var{winder} and @var{unwinder} for the case of normal control
+flow, compiling the expressions in @var{pre} and @var{post},
+respectively.
@end deftp
@deftp {Scheme Variable} <prompt> tag body handler
@deftpx {External Representation} (prompt @var{tag} @var{body} @var{handler})
@@ -506,7 +517,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{<let-values>} is an optimization of @code{<application>} of the
+@code{<let-values>} is an optimization of a @code{<call>} to the
primitive, @code{call-with-values}.
@end deftp
@deftp {Scheme Variable} <fix> src names gensyms vals body
diff --git a/doc/ref/libguile-concepts.texi b/doc/ref/libguile-concepts.texi
index 6ebeb6363..915054c53 100644
--- a/doc/ref/libguile-concepts.texi
+++ b/doc/ref/libguile-concepts.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
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -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/srfi-modules.texi b/doc/ref/srfi-modules.texi
index c2b19fd9c..444fc81ec 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -171,8 +171,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
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 82e7bac6f..398129e2b 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
+@c Copyright (C) 2008,2009,2010,2011
@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
diff --git a/libguile.h b/libguile.h
index 2c10d05e9..7ac98a507 100644
--- a/libguile.h
+++ b/libguile.h
@@ -115,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 c181b998f..52ffc34be 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -218,7 +218,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 \
@@ -314,7 +316,9 @@ DOT_X_FILES = \
vectors.x \
version.x \
vports.x \
- weaks.x
+ weak-set.x \
+ weak-table.x \
+ weak-vector.x
# vm-related snarfs
DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
@@ -415,7 +419,9 @@ 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@
@@ -617,7 +623,9 @@ modinclude_HEADERS = \
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
diff --git a/libguile/__scm.h b/libguile/__scm.h
index c4f2a1ad1..d0a421371 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -145,37 +145,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. */
@@ -192,6 +161,64 @@
+/* We would like gnu89 extern inline semantics, not C99 extern inline
+ semantics, so that we can be sure to avoid reifying definitions of
+ inline functions in all compilation units, which is a possibility at
+ low optimization levels, or if a user takes the address of an inline
+ function.
+
+ Hence the `__gnu_inline__' attribute, in accordance with:
+ http://gcc.gnu.org/gcc-4.3/porting_to.html .
+
+ With GCC 4.2, `__GNUC_STDC_INLINE__' is never defined (because C99 inline
+ semantics are not supported), but a warning is issued in C99 mode if
+ `__gnu_inline__' is not used.
+
+ Apple's GCC build >5400 (since Xcode 3.0) doesn't support GNU inline in
+ C99 mode and doesn't define `__GNUC_STDC_INLINE__'. Fall back to "static
+ inline" in that case. */
+
+# if (defined __GNUC__) && (!(((defined __APPLE_CC__) && (__APPLE_CC__ > 5400)) && __STDC_VERSION__ >= 199901L))
+# if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2)
+# define SCM_C_EXTERN_INLINE \
+ extern __inline__ __attribute__ ((__gnu_inline__))
+# else
+# define SCM_C_EXTERN_INLINE extern __inline__
+# endif
+# endif
+
+/* SCM_INLINE is a macro prepended to all public inline function
+ declarations. Implementations of those functions should also be in
+ the header file, prefixed by SCM_INLINE_IMPLEMENTATION, and protected
+ by SCM_CAN_INLINE and a CPP define for the C file in question, like
+ SCM_INLINE_C_INCLUDING_INLINE_H. See inline.h for an example
+ usage. */
+
+#if defined SCM_IMPLEMENT_INLINES
+/* Reifying functions to a file, whether or not inlining is available. */
+# define SCM_CAN_INLINE 0
+# define SCM_INLINE SCM_API
+# define SCM_INLINE_IMPLEMENTATION
+#elif defined SCM_C_INLINE
+/* Declarations when inlining is available. */
+# define SCM_CAN_INLINE 1
+# ifdef SCM_C_EXTERN_INLINE
+# define SCM_INLINE SCM_C_EXTERN_INLINE
+# else
+/* Fall back to static inline if GNU "extern inline" is unavailable. */
+# define SCM_INLINE static SCM_C_INLINE
+# endif
+# define SCM_INLINE_IMPLEMENTATION SCM_INLINE
+#else
+/* Declarations when inlining is not available. */
+# define SCM_CAN_INLINE 0
+# define SCM_INLINE SCM_API
+/* Don't define SCM_INLINE_IMPLEMENTATION; it should never be seen in
+ this case. */
+#endif
+
+
+
/* {Debugging Options}
*
* These compile time options determine whether to include code that is only
@@ -220,14 +247,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,
@@ -237,13 +256,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.
@@ -286,22 +298,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}
@@ -377,12 +373,6 @@
# define SCM_LONG_BIT (SCM_CHAR_BIT * sizeof (long) / sizeof (char))
#endif
-#ifdef UCHAR_MAX
-# define SCM_CHAR_CODE_LIMIT (UCHAR_MAX + 1L)
-#else
-# define SCM_CHAR_CODE_LIMIT 256L
-#endif
-
#define SCM_I_UTYPE_MAX(type) ((type)-1)
#define SCM_I_TYPE_MAX(type,umax) ((type)((umax)/2))
#define SCM_I_TYPE_MIN(type,umax) (-((type)((umax)/2))-1)
@@ -403,12 +393,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)
@@ -417,10 +401,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"
@@ -439,64 +419,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 <setjmp.h>
-# endif
-#else /* ndef vms */
-# ifdef _CRAY1
- typedef int jmp_buf[112];
- extern int setjump(jmp_buf env);
- extern int longjump(jmp_buf env, int ret);
-# define setjmp setjump
-# define longjmp longjump
-# else /* ndef _CRAY1 */
-# if defined (__ia64__)
-/* For IA64, emulate the setjmp API using getcontext. */
-# include <signal.h>
-# include <ucontext.h>
- typedef struct {
- ucontext_t ctx;
- int fresh;
- } scm_i_jmp_buf;
-# define SCM_I_SETJMP(JB) \
- ( (JB).fresh = 1, \
- getcontext (&((JB).ctx)), \
- ((JB).fresh ? ((JB).fresh = 0, 0) : 1) )
-# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
- void scm_ia64_longjmp (scm_i_jmp_buf *, int);
-# else /* ndef __ia64__ */
-# include <setjmp.h>
-# endif /* ndef __ia64__ */
-# endif /* ndef _CRAY1 */
-#endif /* ndef vms */
-
-/* For any platform where SCM_I_SETJMP hasn't been defined in some
- special way above, map SCM_I_SETJMP, SCM_I_LONGJMP and
- scm_i_jmp_buf to setjmp, longjmp and jmp_buf. */
-#ifndef SCM_I_SETJMP
-#define scm_i_jmp_buf jmp_buf
-#define SCM_I_SETJMP setjmp
-#define SCM_I_LONGJMP longjmp
-#endif
-/* James Clark came up with this neat one instruction fix for
- * continuations on the SPARC. It flushes the register windows so
- * that all the state of the process is contained in the stack.
+/* scm_i_jmp_buf
+ *
+ * The corresponding SCM_I_SETJMP and SCM_I_LONGJMP are defined in the
+ * _scm.h private header.
*/
-#if defined (sparc) || defined (__sparc__) || defined (__sparc)
-# define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3")
+#if defined (vms)
+typedef int scm_i_jmp_buf[17];
+
+#elif defined (_CRAY1)
+typedef int scm_i_jmp_buf[112];
+
+#elif defined (__ia64__)
+# include <signal.h>
+# include <ucontext.h>
+typedef struct {
+ ucontext_t ctx;
+ int fresh;
+} scm_i_jmp_buf;
+
#else
-# define SCM_FLUSH_REGISTER_WINDOWS /* empty */
+# include <setjmp.h>
+typedef jmp_buf scm_i_jmp_buf;
#endif
+
+
+
/* If stack is not longword aligned then
*/
@@ -522,147 +473,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
@@ -685,27 +503,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 <n>).
- */
-
-#ifndef SCM_EXIT_SUCCESS
-#ifdef vms
-#define SCM_EXIT_SUCCESS 1
-#else
-#define SCM_EXIT_SUCCESS 0
-#endif /* def vms */
-#endif /* ndef SCM_EXIT_SUCCESS */
-#ifndef SCM_EXIT_FAILURE
-#ifdef vms
-#define SCM_EXIT_FAILURE 2
-#else
-#define SCM_EXIT_FAILURE 1
-#endif /* def vms */
-#endif /* ndef SCM_EXIT_FAILURE */
-
/* Define SCM_C_INLINE_KEYWORD so that it can be used as a replacement
for the "inline" keyword, expanding to nothing when "inline" is not
available.
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 48fb2ccb6..a7a3ad254 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -191,6 +191,62 @@
#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 \
+ do \
+ { \
+ if (SCM_UNLIKELY (SCM_I_CURRENT_THREAD->pending_asyncs)) \
+ scm_async_tick (); \
+ } \
+ while (0)
+
+#define SCM_ASYNC_TICK_WITH_CODE(thr, stmt) \
+ do \
+ { \
+ if (SCM_UNLIKELY (thr->pending_asyncs)) \
+ { \
+ stmt; \
+ scm_async_tick (); \
+ } \
+ } \
+ while (0)
+
+
+
+
/* The endianness marker in objcode. */
#ifdef WORDS_BIGENDIAN
# define SCM_OBJCODE_ENDIANNESS "BE"
@@ -205,7 +261,7 @@
#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_MAJOR_VERSION 3
#define SCM_OBJCODE_MINOR_VERSION 0
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
diff --git a/libguile/alist.c b/libguile/alist.c
index fd2ccde21..799e9f10e 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 ("#<arbiter ", port);
+ scm_puts_unlocked ("#<arbiter ", port);
if (SCM_ARB_LOCKED (exp))
- scm_puts ("locked ", port);
+ scm_puts_unlocked ("locked ", port);
scm_iprin1 (SCM_PACK (SCM_SMOB_DATA (exp)), port, pstate);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return !0;
}
diff --git a/libguile/array-handle.c b/libguile/array-handle.c
index ec3127a4a..7114f78e0 100644
--- a/libguile/array-handle.c
+++ b/libguile/array-handle.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 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
@@ -132,7 +132,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 ef6f80dd3..acd167da6 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001,2004,2005, 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
@@ -99,7 +99,7 @@ scm_ra_matchp (SCM ra0, SCM ras)
else
return 0;
- while (SCM_NIMP (ras))
+ while (scm_is_pair (ras))
{
ra1 = SCM_CAR (ras);
@@ -204,7 +204,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);
@@ -262,7 +262,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);
@@ -295,7 +295,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 97b5aad9b..935d6f363 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -470,7 +470,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))
{
@@ -725,15 +725,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;
}
@@ -750,7 +750,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)
@@ -771,12 +771,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);
}
@@ -804,9 +804,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
@@ -830,14 +830,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)
@@ -860,7 +860,7 @@ scm_i_read_array (SCM port, int c)
*/
if (c == '(')
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return scm_vector (scm_read (port));
}
@@ -868,11 +868,11 @@ scm_i_read_array (SCM port, int c)
*/
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;
@@ -897,7 +897,7 @@ scm_i_read_array (SCM port, int c)
&& 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;
@@ -922,7 +922,7 @@ scm_i_read_array (SCM port, int c)
if (c == '@')
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
c = read_decimal_integer (port, c, &lbnd);
}
@@ -930,7 +930,7 @@ scm_i_read_array (SCM port, int c)
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,
@@ -952,7 +952,7 @@ scm_i_read_array (SCM port, int c)
scm_i_input_error (NULL, port,
"missing '(' in vector or array literal",
SCM_EOL);
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
elements = scm_read (port);
if (scm_is_false (shape))
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 <config.h>
#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 ("<stdin>", port);
+ scm_puts_unlocked ("<stdin>", 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 b0c21f50d..bc273a3b1 100644
--- a/libguile/bitvectors.c
+++ b/libguile/bitvectors.c
@@ -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;
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index fff53550c..811e8d886 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -193,6 +193,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) \
@@ -210,7 +213,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 ();
@@ -226,13 +229,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;
@@ -253,7 +257,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);
@@ -262,6 +266,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;
@@ -282,19 +287,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
@@ -316,7 +333,7 @@ scm_c_shrink_bytevector (SCM bv, size_t c_new_len)
SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
if (SCM_BYTEVECTOR_CONTIGUOUS_P (bv))
- new_bv = PTR2SCM (scm_gc_realloc (SCM2PTR (bv),
+ new_bv = SCM_PACK_POINTER (scm_gc_realloc (SCM_HEAP_OBJECT_BASE (bv),
c_len + SCM_BYTEVECTOR_HEADER_BYTES,
c_new_len + SCM_BYTEVECTOR_HEADER_BYTES,
SCM_GC_BYTEVECTOR));
@@ -398,17 +415,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;
}
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 cf8b6ac03..86627703c 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -174,14 +174,25 @@ continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
{
scm_t_contregs *continuation = SCM_CONTREGS (obj);
- scm_puts ("#<continuation ", port);
+ scm_puts_unlocked ("#<continuation ", port);
scm_intprint (continuation->num_stack_items, 10, port);
- scm_puts (" @ ", port);
+ scm_puts_unlocked (" @ ", port);
scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
+/* James Clark came up with this neat one instruction fix for
+ * continuations on the SPARC. It flushes the register windows so
+ * that all the state of the process is contained in the stack.
+ */
+
+#if defined (sparc) || defined (__sparc__) || defined (__sparc)
+# define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3")
+#else
+# define SCM_FLUSH_REGISTER_WINDOWS /* empty */
+#endif
+
/* this may return more than once: the first time with the escape
procedure, then subsequently with SCM_UNDEFINED (the vals already having been
placed on the VM stack). */
@@ -487,7 +498,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);
@@ -532,7 +543,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;
}
@@ -546,7 +557,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;
}
@@ -590,7 +601,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/control.c b/libguile/control.c
index 661de8f4f..6302c0750 100644
--- a/libguile/control.c
+++ b/libguile/control.c
@@ -269,9 +269,9 @@ SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
void
scm_i_prompt_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<prompt ", port);
+ scm_puts_unlocked ("#<prompt ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
void
diff --git a/libguile/control.h b/libguile/control.h
index 2167ffa08..ebf255f72 100644
--- a/libguile/control.h
+++ b/libguile/control.h
@@ -22,7 +22,7 @@
#define SCM_F_PROMPT_ESCAPE 0x1
-#define SCM_PROMPT_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_prompt)
+#define SCM_PROMPT_P(x) (SCM_HAS_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))
diff --git a/libguile/debug.c b/libguile/debug.c
index 88a01d6aa..c6ce99e7c 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -108,9 +108,7 @@ 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;
@@ -146,16 +144,9 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
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);
+ if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
+ && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
continue;
- default:
- break;
- }
}
while (0);
diff --git a/libguile/debug.h b/libguile/debug.h
index d862abab4..0749d283c 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
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -52,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
index 530d2d425..e6ef91757 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -27,2559 +27,10 @@
#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"
-
-#include <math.h>
-#include <stdio.h>
-#include <string.h>
-
-#include <arpa/inet.h>
#if (SCM_ENABLE_DEPRECATED == 1)
-/* From print.c: Internal symbol names of isyms. Deprecated in guile 1.7.0 on
- * 2004-04-22. */
-char *scm_isymnames[] =
-{
- "#@<deprecated>"
-};
-
-
-SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x);
-
-SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x);
-
-SCM
-scm_wta (SCM arg, const char *pos, const char *s_subr)
-{
- if (!s_subr || !*s_subr)
- s_subr = NULL;
- if ((~0x1fL) & (long) pos)
- {
- /* error string supplied. */
- scm_misc_error (s_subr, pos, scm_list_1 (arg));
- }
- else
- {
- /* numerical error code. */
- scm_t_bits error = (scm_t_bits) pos;
-
- switch (error)
- {
- case SCM_ARGn:
- scm_wrong_type_arg (s_subr, 0, arg);
- case SCM_ARG1:
- scm_wrong_type_arg (s_subr, 1, arg);
- case SCM_ARG2:
- scm_wrong_type_arg (s_subr, 2, arg);
- case SCM_ARG3:
- scm_wrong_type_arg (s_subr, 3, arg);
- case SCM_ARG4:
- scm_wrong_type_arg (s_subr, 4, arg);
- case SCM_ARG5:
- scm_wrong_type_arg (s_subr, 5, arg);
- case SCM_ARG6:
- scm_wrong_type_arg (s_subr, 6, arg);
- case SCM_ARG7:
- scm_wrong_type_arg (s_subr, 7, arg);
- case SCM_WNA:
- scm_wrong_num_args (arg);
- case SCM_OUTOFRANGE:
- scm_out_of_range (s_subr, arg);
- case SCM_NALLOC:
- scm_memory_error (s_subr);
- default:
- /* this shouldn't happen. */
- scm_misc_error (s_subr, "Unknown error", SCM_EOL);
- }
- }
- return SCM_UNSPECIFIED;
-}
-
-/* Module registry
- */
-
-/* We can't use SCM objects here. One should be able to call
- SCM_REGISTER_MODULE from a C++ constructor for a static
- object. This happens before main and thus before libguile is
- initialized. */
-
-struct moddata {
- struct moddata *link;
- char *module_name;
- void *init_func;
-};
-
-static struct moddata *registered_mods = NULL;
-
-void
-scm_register_module_xxx (char *module_name, void *init_func)
-{
- struct moddata *md;
-
- scm_c_issue_deprecation_warning
- ("`scm_register_module_xxx' is deprecated. Use extensions instead.");
-
- /* XXX - should we (and can we) DEFER_INTS here? */
-
- for (md = registered_mods; md; md = md->link)
- if (!strcmp (md->module_name, module_name))
- {
- md->init_func = init_func;
- return;
- }
-
- md = (struct moddata *) malloc (sizeof (struct moddata));
- if (md == NULL)
- {
- fprintf (stderr,
- "guile: can't register module (%s): not enough memory",
- module_name);
- return;
- }
-
- md->module_name = module_name;
- md->init_func = init_func;
- md->link = registered_mods;
- registered_mods = md;
-}
-
-SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0,
- (),
- "Return a list of the object code modules that have been imported into\n"
- "the current Guile process. Each element of the list is a pair whose\n"
- "car is the name of the module, and whose cdr is the function handle\n"
- "for that module's initializer function. The name is the string that\n"
- "has been passed to scm_register_module_xxx.")
-#define FUNC_NAME s_scm_registered_modules
-{
- SCM res;
- struct moddata *md;
-
- res = SCM_EOL;
- for (md = registered_mods; md; md = md->link)
- res = scm_cons (scm_cons (scm_from_locale_string (md->module_name),
- scm_from_ulong ((unsigned long) md->init_func)),
- res);
- return res;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0,
- (),
- "Destroy the list of modules registered with the current Guile process.\n"
- "The return value is unspecified. @strong{Warning:} this function does\n"
- "not actually unlink or deallocate these modules, but only destroys the\n"
- "records of which modules have been loaded. It should therefore be used\n"
- "only by module bookkeeping operations.")
-#define FUNC_NAME s_scm_clear_registered_modules
-{
- struct moddata *md1, *md2;
-
- SCM_CRITICAL_SECTION_START;
-
- for (md1 = registered_mods; md1; md1 = md2)
- {
- md2 = md1->link;
- free (md1);
- }
- registered_mods = NULL;
-
- SCM_CRITICAL_SECTION_END;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-void
-scm_remember (SCM *ptr)
-{
- scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
- "Use the `scm_remember_upto_here*' family of functions instead.");
-}
-
-SCM
-scm_protect_object (SCM obj)
-{
- scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
- "Use `scm_gc_protect_object' instead.");
- return scm_gc_protect_object (obj);
-}
-
-SCM
-scm_unprotect_object (SCM obj)
-{
- scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
- "Use `scm_gc_unprotect_object' instead.");
- return scm_gc_unprotect_object (obj);
-}
-
-SCM_SYMBOL (scm_sym_app, "app");
-SCM_SYMBOL (scm_sym_modules, "modules");
-static SCM module_prefix = SCM_BOOL_F;
-static SCM make_modules_in_var;
-static SCM beautify_user_module_x_var;
-static SCM try_module_autoload_var;
-
-static void
-init_module_stuff ()
-{
- if (scm_is_false (module_prefix))
- {
- module_prefix = scm_list_2 (scm_sym_app, scm_sym_modules);
- make_modules_in_var = scm_c_lookup ("make-modules-in");
- beautify_user_module_x_var =
- scm_c_lookup ("beautify-user-module!");
- try_module_autoload_var = scm_c_lookup ("try-module-autoload");
- }
-}
-
-static SCM
-scm_module_full_name (SCM name)
-{
- init_module_stuff ();
- if (scm_is_eq (SCM_CAR (name), scm_sym_app))
- return name;
- else
- return scm_append (scm_list_2 (module_prefix, name));
-}
-
-SCM
-scm_make_module (SCM name)
-{
- init_module_stuff ();
- scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. "
- "Use `scm_c_define_module instead.");
-
- return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var),
- scm_the_root_module (),
- scm_module_full_name (name));
-}
-
-SCM
-scm_ensure_user_module (SCM module)
-{
- init_module_stuff ();
- scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. "
- "Use `scm_c_define_module instead.");
-
- scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var), module);
- return SCM_UNSPECIFIED;
-}
-
-SCM
-scm_load_scheme_module (SCM name)
-{
- init_module_stuff ();
- scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. "
- "Use `scm_c_resolve_module instead.");
-
- return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var), name);
-}
-
-/* This is implemented in C solely for SCM_COERCE_OUTPORT ... */
-
-static void
-maybe_close_port (void *data, SCM port)
-{
- SCM except_set = PTR2SCM (data);
-
- while (!scm_is_null (except_set))
- {
- SCM p = SCM_COERCE_OUTPORT (SCM_CAR (except_set));
- if (scm_is_eq (p, port))
- return;
- except_set = SCM_CDR (except_set);
- }
-
- scm_close_port (port);
-}
-
-SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1,
- (SCM ports),
- "[DEPRECATED] Close all open file ports used by the interpreter\n"
- "except for those supplied as arguments. This procedure\n"
- "was intended to be used before an exec call to close file descriptors\n"
- "which are not needed in the new process. However it has the\n"
- "undesirable side effect of flushing buffers, so it's deprecated.\n"
- "Use port-for-each instead.")
-#define FUNC_NAME s_scm_close_all_ports_except
-{
- SCM p;
- SCM_VALIDATE_REST_ARGUMENT (ports);
-
- for (p = ports; !scm_is_null (p); p = SCM_CDR (p))
- SCM_VALIDATE_OPPORT (SCM_ARG1, SCM_COERCE_OUTPORT (SCM_CAR (p)));
-
- scm_c_port_for_each (maybe_close_port, SCM2PTR (ports));
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_variable_set_name_hint, "variable-set-name-hint!", 2, 0, 0,
- (SCM var, SCM hint),
- "Do not use this function.")
-#define FUNC_NAME s_scm_variable_set_name_hint
-{
- SCM_VALIDATE_VARIABLE (1, var);
- SCM_VALIDATE_SYMBOL (2, hint);
- scm_c_issue_deprecation_warning
- ("'variable-set-name-hint!' is deprecated. Do not use it.");
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0,
- (SCM name),
- "Do not use this function.")
-#define FUNC_NAME s_scm_builtin_variable
-{
- SCM_VALIDATE_SYMBOL (1,name);
- scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. "
- "Use module system operations instead.");
- return scm_sym2var (name, SCM_BOOL_F, SCM_BOOL_T);
-}
-#undef FUNC_NAME
-
-SCM
-scm_makstr (size_t len, int dummy)
-{
- scm_c_issue_deprecation_warning
- ("'scm_makstr' is deprecated. Use 'scm_c_make_string' instead.");
- return scm_c_make_string (len, SCM_UNDEFINED);
-}
-
-SCM
-scm_makfromstr (const char *src, size_t len, int dummy SCM_UNUSED)
-{
- scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. "
- "Use `scm_from_locale_stringn' instead.");
-
- return scm_from_locale_stringn (src, len);
-}
-
-SCM
-scm_internal_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
-{
- scm_c_issue_deprecation_warning ("`scm_internal_with_fluids' is deprecated. "
- "Use `scm_c_with_fluids' instead.");
-
- return scm_c_with_fluids (fluids, values, cproc, cdata);
-}
-
-SCM
-scm_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_gsubr' is deprecated. Use `scm_c_define_gsubr' instead.");
-
- return scm_c_define_gsubr (name, req, opt, rst, fcn);
-}
-
-SCM
-scm_make_gsubr_with_generic (const char *name,
- int req, int opt, int rst,
- SCM (*fcn)(), SCM *gf)
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_gsubr_with_generic' is deprecated. "
- "Use `scm_c_define_gsubr_with_generic' instead.");
-
- return scm_c_define_gsubr_with_generic (name, req, opt, rst, fcn, gf);
-}
-
-SCM
-scm_create_hook (const char *name, int n_args)
-{
- scm_c_issue_deprecation_warning
- ("'scm_create_hook' is deprecated. "
- "Use 'scm_make_hook' and 'scm_c_define' instead.");
- {
- SCM hook = scm_make_hook (scm_from_int (n_args));
- scm_c_define (name, hook);
- return hook;
- }
-}
-
-SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{memq}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_memq
-{
- scm_c_issue_deprecation_warning
- ("'sloppy-memq' is deprecated. Use 'memq' instead.");
-
- for(; scm_is_pair (lst); lst = SCM_CDR(lst))
- {
- if (scm_is_eq (SCM_CAR (lst), x))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_sloppy_memv, "sloppy-memv", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{memv}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_memv
-{
- scm_c_issue_deprecation_warning
- ("'sloppy-memv' is deprecated. Use 'memv' instead.");
-
- for(; scm_is_pair (lst); lst = SCM_CDR(lst))
- {
- if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x)))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{member}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_member
-{
- scm_c_issue_deprecation_warning
- ("'sloppy-member' is deprecated. Use 'member' instead.");
-
- for(; scm_is_pair (lst); lst = SCM_CDR(lst))
- {
- if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-
-SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
-
-SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0,
- (SCM port),
- "Read a form from @var{port} (standard input by default), and evaluate it\n"
- "(memoizing it in the process) in the top-level environment. If no data\n"
- "is left to be read from @var{port}, an @code{end-of-file} error is\n"
- "signalled.")
-#define FUNC_NAME s_scm_read_and_eval_x
-{
- SCM form;
-
- scm_c_issue_deprecation_warning
- ("'read-and-eval!' is deprecated. Use 'read' and 'eval' instead.");
-
- form = scm_read (port);
- if (SCM_EOF_OBJECT_P (form))
- scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
- return scm_eval_x (form, scm_current_module ());
-}
-#undef FUNC_NAME
-
-/* Call thunk(closure) underneath a top-level error handler.
- * If an error occurs, pass the exitval through err_filter and return it.
- * If no error occurs, return the value of thunk.
- */
-
-#ifdef _UNICOS
-typedef int setjmp_type;
-#else
-typedef long setjmp_type;
-#endif
-
-struct cce_handler_data {
- SCM (*err_filter) ();
- void *closure;
-};
-
-static SCM
-invoke_err_filter (void *d, SCM tag, SCM args)
-{
- struct cce_handler_data *data = (struct cce_handler_data *)d;
- return data->err_filter (SCM_BOOL_F, data->closure);
-}
-
-SCM
-scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure)
-{
- scm_c_issue_deprecation_warning
- ("'scm_call_catching_errors' is deprecated. "
- "Use 'scm_internal_catch' instead.");
-
- {
- struct cce_handler_data data;
- data.err_filter = err_filter;
- data.closure = closure;
- return scm_internal_catch (SCM_BOOL_T,
- (scm_t_catch_body)thunk, closure,
- (scm_t_catch_handler)invoke_err_filter, &data);
- }
-}
-
-long
-scm_make_smob_type_mfpe (char *name, size_t size,
- SCM (*mark) (SCM),
- size_t (*free) (SCM),
- int (*print) (SCM, SCM, scm_print_state *),
- SCM (*equalp) (SCM, SCM))
-{
- scm_c_issue_deprecation_warning
- ("'scm_make_smob_type_mfpe' is deprecated. "
- "Use 'scm_make_smob_type' plus 'scm_set_smob_*' instead.");
-
- {
- long answer = scm_make_smob_type (name, size);
- scm_set_smob_mfpe (answer, mark, free, print, equalp);
- return answer;
- }
-}
-
-void
-scm_set_smob_mfpe (long tc,
- SCM (*mark) (SCM),
- size_t (*free) (SCM),
- int (*print) (SCM, SCM, scm_print_state *),
- SCM (*equalp) (SCM, SCM))
-{
- scm_c_issue_deprecation_warning
- ("'scm_set_smob_mfpe' is deprecated. "
- "Use 'scm_set_smob_mark' instead, for example.");
-
- if (mark) scm_set_smob_mark (tc, mark);
- if (free) scm_set_smob_free (tc, free);
- if (print) scm_set_smob_print (tc, print);
- if (equalp) scm_set_smob_equalp (tc, equalp);
-}
-
-size_t
-scm_smob_free (SCM obj)
-{
- long n = SCM_SMOBNUM (obj);
-
- scm_c_issue_deprecation_warning
- ("`scm_smob_free' is deprecated. "
- "It is no longer needed.");
-
- if (scm_smobs[n].size > 0)
- scm_gc_free ((void *) SCM_SMOB_DATA_1 (obj),
- scm_smobs[n].size, SCM_SMOBNAME (n));
- return 0;
-}
-
-SCM
-scm_read_0str (char *expr)
-{
- scm_c_issue_deprecation_warning
- ("scm_read_0str is deprecated. Use scm_c_read_string instead.");
-
- return scm_c_read_string (expr);
-}
-
-SCM
-scm_eval_0str (const char *expr)
-{
- scm_c_issue_deprecation_warning
- ("scm_eval_0str is deprecated. Use scm_c_eval_string instead.");
-
- return scm_c_eval_string (expr);
-}
-
-SCM
-scm_strprint_obj (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("scm_strprint_obj is deprecated. Use scm_object_to_string instead.");
- return scm_object_to_string (obj, SCM_UNDEFINED);
-}
-
-char *
-scm_i_object_chars (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_CHARS is deprecated. See the manual for alternatives.");
- if (SCM_STRINGP (obj))
- return SCM_STRING_CHARS (obj);
- if (SCM_SYMBOLP (obj))
- return SCM_SYMBOL_CHARS (obj);
- abort ();
-}
-
-long
-scm_i_object_length (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_LENGTH is deprecated. "
- "Use scm_c_string_length instead, for example, or see the manual.");
- if (SCM_STRINGP (obj))
- return SCM_STRING_LENGTH (obj);
- if (SCM_SYMBOLP (obj))
- return SCM_SYMBOL_LENGTH (obj);
- if (SCM_VECTORP (obj))
- return SCM_VECTOR_LENGTH (obj);
- abort ();
-}
-
-SCM
-scm_sym2ovcell_soft (SCM sym, SCM obarray)
-{
- SCM lsym, z;
- size_t hash = scm_i_symbol_hash (sym) % SCM_VECTOR_LENGTH (obarray);
-
- scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. "
- "Use hashtables instead.");
-
- SCM_CRITICAL_SECTION_START;
- for (lsym = SCM_VECTOR_REF (obarray, hash);
- SCM_NIMP (lsym);
- lsym = SCM_CDR (lsym))
- {
- z = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (z), sym))
- {
- SCM_CRITICAL_SECTION_END;
- return z;
- }
- }
- SCM_CRITICAL_SECTION_END;
- return SCM_BOOL_F;
-}
-
-
-SCM
-scm_sym2ovcell (SCM sym, SCM obarray)
-#define FUNC_NAME "scm_sym2ovcell"
-{
- SCM answer;
-
- scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. "
- "Use hashtables instead.");
-
- answer = scm_sym2ovcell_soft (sym, obarray);
- if (scm_is_true (answer))
- return answer;
- SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym));
- return SCM_UNSPECIFIED; /* not reached */
-}
-#undef FUNC_NAME
-
-
-/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
-
- OBARRAY should be a vector of lists, indexed by the name's hash
- value, modulo OBARRAY's length. Each list has the form
- ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
- value associated with that symbol (in the current module? in the
- system module?)
-
- To "intern" a symbol means: if OBARRAY already contains a symbol by
- that name, return its (SYMBOL . VALUE) pair; otherwise, create a
- new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
- appropriate list of the OBARRAY, and return the pair.
-
- If softness is non-zero, don't create a symbol if it isn't already
- in OBARRAY; instead, just return #f.
-
- If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
- return (SYMBOL . SCM_UNDEFINED). */
-
-
-static SCM
-intern_obarray_soft (SCM symbol, SCM obarray, unsigned int softness)
-{
- size_t raw_hash = scm_i_symbol_hash (symbol);
- size_t hash;
- SCM lsym;
-
- if (scm_is_false (obarray))
- {
- if (softness)
- return SCM_BOOL_F;
- else
- return scm_cons (symbol, SCM_UNDEFINED);
- }
-
- hash = raw_hash % SCM_VECTOR_LENGTH (obarray);
-
- for (lsym = SCM_VECTOR_REF(obarray, hash);
- SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
- {
- SCM a = SCM_CAR (lsym);
- SCM z = SCM_CAR (a);
- if (scm_is_eq (z, symbol))
- return a;
- }
-
- if (softness)
- {
- return SCM_BOOL_F;
- }
- else
- {
- SCM cell = scm_cons (symbol, SCM_UNDEFINED);
- SCM slot = SCM_VECTOR_REF (obarray, hash);
-
- SCM_VECTOR_SET (obarray, hash, scm_cons (cell, slot));
-
- return cell;
- }
-}
-
-
-SCM
-scm_intern_obarray_soft (const char *name, size_t len, SCM obarray,
- unsigned int softness)
-{
- SCM symbol = scm_from_locale_symboln (name, len);
-
- scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
- "Use hashtables instead.");
-
- return intern_obarray_soft (symbol, obarray, softness);
-}
-
-SCM
-scm_intern_obarray (const char *name,size_t len,SCM obarray)
-{
- scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. "
- "Use hashtables instead.");
-
- return scm_intern_obarray_soft (name, len, obarray, 0);
-}
-
-/* Lookup the value of the symbol named by the nul-terminated string
- NAME in the current module. */
-SCM
-scm_symbol_value0 (const char *name)
-{
- scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. "
- "Use `scm_lookup' instead.");
-
- return scm_variable_ref (scm_c_lookup (name));
-}
-
-SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0,
- (SCM o, SCM s, SCM softp),
- "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
- "@var{string}.\n\n"
- "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
- "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
- "symbol table; merely return the pair (@var{symbol}\n"
- ". @var{#<undefined>}).\n\n"
- "The @var{soft?} argument determines whether new symbol table entries\n"
- "should be created when the specified symbol is not already present in\n"
- "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
- "new entries should not be added for symbols not already present in the\n"
- "table; instead, simply return @code{#f}.")
-#define FUNC_NAME s_scm_string_to_obarray_symbol
-{
- SCM vcell;
- SCM answer;
- int softness;
-
- SCM_VALIDATE_STRING (2, s);
- SCM_ASSERT (scm_is_bool (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME);
-
- scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. "
- "Use hashtables instead.");
-
- softness = (!SCM_UNBNDP (softp) && scm_is_true(softp));
- /* iron out some screwy calling conventions */
- if (scm_is_false (o))
- {
- /* nothing interesting to do here. */
- return scm_string_to_symbol (s);
- }
- else if (scm_is_eq (o, SCM_BOOL_T))
- o = SCM_BOOL_F;
-
- vcell = intern_obarray_soft (scm_string_to_symbol (s), o, softness);
- if (scm_is_false (vcell))
- return vcell;
- answer = SCM_CAR (vcell);
- return answer;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0,
- (SCM o, SCM s),
- "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
- "unspecified initial value. The symbol table is not modified if a symbol\n"
- "with this name is already present.")
-#define FUNC_NAME s_scm_intern_symbol
-{
- size_t hval;
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- return SCM_UNSPECIFIED;
-
- scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_VECTOR (1,o);
- hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
- /* If the symbol is already interned, simply return. */
- SCM_CRITICAL_SECTION_START;
- {
- SCM lsym;
- SCM sym;
- for (lsym = SCM_VECTOR_REF (o, hval);
- SCM_NIMP (lsym);
- lsym = SCM_CDR (lsym))
- {
- sym = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (sym), s))
- {
- SCM_CRITICAL_SECTION_END;
- return SCM_UNSPECIFIED;
- }
- }
- SCM_VECTOR_SET (o, hval,
- scm_acons (s, SCM_UNDEFINED,
- SCM_VECTOR_REF (o, hval)));
- }
- SCM_CRITICAL_SECTION_END;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
- (SCM o, SCM s),
- "Remove the symbol with name @var{string} from @var{obarray}. This\n"
- "function returns @code{#t} if the symbol was present and @code{#f}\n"
- "otherwise.")
-#define FUNC_NAME s_scm_unintern_symbol
-{
- size_t hval;
-
- scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- return SCM_BOOL_F;
- SCM_VALIDATE_VECTOR (1,o);
- hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
- SCM_CRITICAL_SECTION_START;
- {
- SCM lsym_follow;
- SCM lsym;
- SCM sym;
- for (lsym = SCM_VECTOR_REF (o, hval), lsym_follow = SCM_BOOL_F;
- SCM_NIMP (lsym);
- lsym_follow = lsym, lsym = SCM_CDR (lsym))
- {
- sym = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (sym), s))
- {
- /* Found the symbol to unintern. */
- if (scm_is_false (lsym_follow))
- SCM_VECTOR_SET (o, hval, lsym);
- else
- SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
- SCM_CRITICAL_SECTION_END;
- return SCM_BOOL_T;
- }
- }
- }
- SCM_CRITICAL_SECTION_END;
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0,
- (SCM o, SCM s),
- "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
- "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
- "use the global symbol table. If @var{string} is not interned in\n"
- "@var{obarray}, an error is signalled.")
-#define FUNC_NAME s_scm_symbol_binding
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- return scm_variable_ref (scm_lookup (s));
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell (s, o);
- return SCM_CDR(vcell);
-}
-#undef FUNC_NAME
-
-#if 0
-SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0,
- (SCM o, SCM s),
- "Return @code{#t} if @var{obarray} contains a symbol with name\n"
- "@var{string}, and @code{#f} otherwise.")
-#define FUNC_NAME s_scm_symbol_interned_p
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- {
- SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F);
- if (var != SCM_BOOL_F)
- return SCM_BOOL_T;
- return SCM_BOOL_F;
- }
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell_soft (s, o);
- return (SCM_NIMP(vcell)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-#undef FUNC_NAME
-#endif
-
-SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0,
- (SCM o, SCM s),
- "Return @code{#t} if @var{obarray} contains a symbol with name\n"
- "@var{string} bound to a defined value. This differs from\n"
- "@var{symbol-interned?} in that the mere mention of a symbol\n"
- "usually causes it to be interned; @code{symbol-bound?}\n"
- "determines whether a symbol has been given any meaningful\n"
- "value.")
-#define FUNC_NAME s_scm_symbol_bound_p
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- {
- SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F);
- if (SCM_VARIABLEP(var) && !SCM_UNBNDP(SCM_VARIABLE_REF(var)))
- return SCM_BOOL_T;
- return SCM_BOOL_F;
- }
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell_soft (s, o);
- return scm_from_bool (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell)));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0,
- (SCM o, SCM s, SCM v),
- "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
- "it to @var{value}. An error is signalled if @var{string} is not present\n"
- "in @var{obarray}.")
-#define FUNC_NAME s_scm_symbol_set_x
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. "
- "Use the module system instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- {
- scm_define (s, v);
- return SCM_UNSPECIFIED;
- }
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell (s, o);
- SCM_SETCDR (vcell, v);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-#define MAX_PREFIX_LENGTH 30
-
-static int gentemp_counter;
-
-SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0,
- (SCM prefix, SCM obarray),
- "Create a new symbol with a name unique in an obarray.\n"
- "The name is constructed from an optional string @var{prefix}\n"
- "and a counter value. The default prefix is @code{t}. The\n"
- "@var{obarray} is specified as a second optional argument.\n"
- "Default is the system obarray where all normal symbols are\n"
- "interned. The counter is increased by 1 at each\n"
- "call. There is no provision for resetting the counter.")
-#define FUNC_NAME s_scm_gentemp
-{
- char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN];
- char *name = buf;
- int n_digits;
- size_t len;
-
- scm_c_issue_deprecation_warning ("`gentemp' is deprecated. "
- "Use `gensym' instead.");
-
- if (SCM_UNBNDP (prefix))
- {
- name[0] = 't';
- len = 1;
- }
- else
- {
- SCM_VALIDATE_STRING (1, prefix);
- len = scm_i_string_length (prefix);
- name = scm_to_locale_stringn (prefix, &len);
- name = scm_realloc (name, len + SCM_INTBUFLEN);
- }
-
- if (SCM_UNBNDP (obarray))
- return scm_gensym (prefix);
- else
- SCM_ASSERT ((scm_is_vector (obarray) || SCM_I_WVECTP (obarray)),
- obarray,
- SCM_ARG2,
- FUNC_NAME);
- do
- n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]);
- while (scm_is_true (scm_intern_obarray_soft (name,
- len + n_digits,
- obarray,
- 1)));
- {
- SCM vcell = scm_intern_obarray_soft (name,
- len + n_digits,
- obarray,
- 0);
- if (name != buf)
- free (name);
- return SCM_CAR (vcell);
- }
-}
-#undef FUNC_NAME
-
-SCM
-scm_i_makinum (scm_t_signed_bits val)
-{
- scm_c_issue_deprecation_warning
- ("SCM_MAKINUM is deprecated. Use scm_from_int or similar instead.");
- return SCM_I_MAKINUM (val);
-}
-
-int
-scm_i_inump (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_INUMP is deprecated. Use scm_is_integer or similar instead.");
- return SCM_I_INUMP (obj);
-}
-
-scm_t_signed_bits
-scm_i_inum (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_INUM is deprecated. Use scm_to_int or similar instead.");
- return scm_to_intmax (obj);
-}
-
-char *
-scm_c_string2str (SCM obj, char *str, size_t *lenp)
-{
- scm_c_issue_deprecation_warning
- ("scm_c_string2str is deprecated. Use scm_to_locale_stringbuf or similar instead.");
-
- if (str == NULL)
- {
- char *result = scm_to_locale_string (obj);
- if (lenp)
- *lenp = scm_i_string_length (obj);
- return result;
- }
- else
- {
- /* Pray that STR is large enough.
- */
- size_t len = scm_to_locale_stringbuf (obj, str, SCM_I_SIZE_MAX);
- str[len] = '\0';
- if (lenp)
- *lenp = len;
- return str;
- }
-}
-
-char *
-scm_c_substring2str (SCM obj, char *str, size_t start, size_t len)
-{
- scm_c_issue_deprecation_warning
- ("scm_c_substring2str is deprecated. Use scm_substring plus scm_to_locale_stringbuf instead.");
-
- if (start)
- obj = scm_substring (obj, scm_from_size_t (start), SCM_UNDEFINED);
-
- scm_to_locale_stringbuf (obj, str, len);
- return str;
-}
-
-/* Converts the given Scheme symbol OBJ into a C string, containing a copy
- of OBJ's content with a trailing null byte. If LENP is non-NULL, set
- *LENP to the string's length.
-
- When STR is non-NULL it receives the copy and is returned by the function,
- otherwise new memory is allocated and the caller is responsible for
- freeing it via free(). If out of memory, NULL is returned.
-
- Note that Scheme symbols may contain arbitrary data, including null
- characters. This means that null termination is not a reliable way to
- determine the length of the returned value. However, the function always
- copies the complete contents of OBJ, and sets *LENP to the length of the
- scheme symbol (if LENP is non-null). */
-char *
-scm_c_symbol2str (SCM obj, char *str, size_t *lenp)
-{
- return scm_c_string2str (scm_symbol_to_string (obj), str, lenp);
-}
-
-double
-scm_truncate (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_truncate is deprecated. Use scm_c_truncate instead.");
- return scm_c_truncate (x);
-}
-
-double
-scm_round (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_round is deprecated. Use scm_c_round instead.");
- return scm_c_round (x);
-}
-
-SCM
-scm_sys_expt (SCM x, SCM y)
-{
- scm_c_issue_deprecation_warning
- ("scm_sys_expt is deprecated. Use scm_expt instead.");
- return scm_expt (x, y);
-}
-
-double
-scm_asinh (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_asinh is deprecated. Use asinh instead.");
-#if HAVE_ASINH
- return asinh (x);
-#else
- return log (x + sqrt (x * x + 1));
-#endif
-}
-
-double
-scm_acosh (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_acosh is deprecated. Use acosh instead.");
-#if HAVE_ACOSH
- return acosh (x);
-#else
- return log (x + sqrt (x * x - 1));
-#endif
-}
-
-double
-scm_atanh (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_atanh is deprecated. Use atanh instead.");
-#if HAVE_ATANH
- return atanh (x);
-#else
- return 0.5 * log ((1 + x) / (1 - x));
-#endif
-}
-
-SCM
-scm_sys_atan2 (SCM z1, SCM z2)
-{
- scm_c_issue_deprecation_warning
- ("scm_sys_atan2 is deprecated. Use scm_atan instead.");
- return scm_atan (z1, z2);
-}
-
-char *
-scm_i_deprecated_symbol_chars (SCM sym)
-{
- scm_c_issue_deprecation_warning
- ("SCM_SYMBOL_CHARS is deprecated. Use scm_symbol_to_string.");
-
- return (char *)scm_i_symbol_chars (sym);
-}
-
-size_t
-scm_i_deprecated_symbol_length (SCM sym)
-{
- scm_c_issue_deprecation_warning
- ("SCM_SYMBOL_LENGTH is deprecated. Use scm_symbol_to_string.");
- return scm_i_symbol_length (sym);
-}
-
-int
-scm_i_keywordp (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_KEYWORDP is deprecated. Use scm_is_keyword instead.");
- return scm_is_keyword (obj);
-}
-
-SCM
-scm_i_keywordsym (SCM keyword)
-{
- scm_c_issue_deprecation_warning
- ("SCM_KEYWORDSYM is deprecated. See scm_keyword_to_symbol instead.");
- return scm_keyword_dash_symbol (keyword);
-}
-
-int
-scm_i_vectorp (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTORP is deprecated. Use scm_is_vector instead.");
- return SCM_I_IS_VECTOR (x);
-}
-
-unsigned long
-scm_i_vector_length (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead.");
- return SCM_I_VECTOR_LENGTH (x);
-}
-
-const SCM *
-scm_i_velts (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VELTS is deprecated. Use scm_vector_elements instead.");
- return SCM_I_VECTOR_ELTS (x);
-}
-
-SCM *
-scm_i_writable_velts (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_WRITABLE_VELTS is deprecated. "
- "Use scm_vector_writable_elements instead.");
- return SCM_I_VECTOR_WELTS (x);
-}
-
-SCM
-scm_i_vector_ref (SCM x, size_t idx)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTOR_REF is deprecated. "
- "Use scm_c_vector_ref or scm_vector_elements instead.");
- return scm_c_vector_ref (x, idx);
-}
-
-void
-scm_i_vector_set (SCM x, size_t idx, SCM val)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTOR_SET is deprecated. "
- "Use scm_c_vector_set_x or scm_vector_writable_elements instead.");
- scm_c_vector_set_x (x, idx, val);
-}
-
-SCM
-scm_vector_equal_p (SCM x, SCM y)
-{
- scm_c_issue_deprecation_warning
- ("scm_vector_euqal_p is deprecated. "
- "Use scm_equal_p instead.");
- return scm_equal_p (x, y);
-}
-
-SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
- (SCM uvec, SCM port_or_fd, SCM start, SCM end),
- "Fill the elements of @var{uvec} by reading\n"
- "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
- "The optional arguments @var{start} (inclusive) and @var{end}\n"
- "(exclusive) allow a specified region to be read,\n"
- "leaving the remainder of the vector unchanged.\n\n"
- "When @var{port-or-fdes} is a port, all specified elements\n"
- "of @var{uvec} are attempted to be read, potentially blocking\n"
- "while waiting for more input or end-of-file.\n"
- "When @var{port-or-fd} is an integer, a single call to\n"
- "read(2) is made.\n\n"
- "An error is signalled when the last element has only\n"
- "been partially filled before reaching end-of-file or in\n"
- "the single call to read(2).\n\n"
- "@code{uniform-vector-read!} returns the number of elements\n"
- "read.\n\n"
- "@var{port-or-fdes} may be omitted, in which case it defaults\n"
- "to the value returned by @code{(current-input-port)}.")
-#define FUNC_NAME s_scm_uniform_vector_read_x
-{
- SCM result;
- size_t c_width, c_start, c_end;
-
- SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
-
- scm_c_issue_deprecation_warning
- ("`uniform-vector-read!' is deprecated. Use `get-bytevector-n!' from\n"
- "`(rnrs io ports)' instead.");
-
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_input_port ();
-
- c_width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
-
- c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start);
- c_start *= c_width;
-
- c_end = SCM_UNBNDP (end) ? SCM_BYTEVECTOR_LENGTH (uvec) : scm_to_size_t (end);
- c_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);
-}
-
-int scm_internal_select (int fds,
- SELECT_TYPE *rfds,
- SELECT_TYPE *wfds,
- SELECT_TYPE *efds,
- struct timeval *timeout)
-{
- scm_c_issue_deprecation_warning
- ("`scm_internal_select' is deprecated. Use scm_std_select instead.");
- return scm_std_select (fds, rfds, wfds, efds, timeout);
-}
-
-
-
-#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
@@ -2624,26 +75,12 @@ scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
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;
-}
-
void
scm_i_init_deprecated ()
{
- properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
- scm_struct_table = scm_make_hash_table (SCM_UNDEFINED);
#include "libguile/deprecated.x"
}
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 2b85bef6a..d11667191 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -5,7 +5,7 @@
#ifndef SCM_DEPRECATED_H
#define SCM_DEPRECATED_H
-/* Copyright (C) 2003,2004, 2005, 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2003,2004, 2005, 2006, 2007, 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
@@ -31,119 +31,6 @@
#if (SCM_ENABLE_DEPRECATED == 1)
-/* From eval.h: Macros for handling ilocs. These were deprecated in guile
- * 1.7.0 on 2004-04-22. */
-#define SCM_IFRINC (0x00000100L)
-#define SCM_ICDR (0x00080000L)
-#define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
- & (SCM_UNPACK (n) >> 8))
-#define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
-#define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
-
-
-/* From tags.h: Macros to access internal symbol names of isyms. Deprecated
- * in guile 1.7.0 on 2004-04-22. */
-SCM_API char *scm_isymnames[];
-#define SCM_ISYMNUM(n) 0
-#define SCM_ISYMCHARS(n) "#@<deprecated>"
-
-
-/* From tags.h: Macro checking for two tc16 types that are allocated to differ
- * only in the 's'-bit. Deprecated in guile 1.7.0 on 2003-09-21. */
-#define SCM_TYP16S(x) (0xfeff & SCM_CELL_TYPE (x))
-
-
-/* From numbers.h: Macros checking for types, but avoiding a redundant check
- * for !SCM_IMP. These were deprecated in guile 1.7.0 on 2003-09-06. */
-#define SCM_SLOPPY_INEXACTP(x) (SCM_TYP16S (x) == scm_tc16_real)
-#define SCM_SLOPPY_REALP(x) (SCM_TYP16 (x) == scm_tc16_real)
-#define SCM_SLOPPY_COMPLEXP(x) (SCM_TYP16 (x) == scm_tc16_complex)
-
-
-/* From structs.h:
- Deprecated in Guile 1.9.5 on 2009-11-03. */
-#define scm_vtable_index_vtable scm_vtable_index_self
-#define scm_vtable_index_printer scm_vtable_index_instance_printer
-#define scm_struct_i_free scm_vtable_index_instance_finalize
-#define scm_struct_i_flags scm_vtable_index_flags
-#define SCM_STRUCTF_MASK ((scm_t_bits)-1)
-#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA(x)[scm_struct_i_free]=(scm_t_bits)(D))
-
-#define scm_substring_move_left_x scm_substring_move_x
-#define scm_substring_move_right_x scm_substring_move_x
-
-#define scm_sizet size_t
-
-SCM_DEPRECATED SCM scm_wta (SCM arg, const char *pos, const char *s_subr);
-
-#define SCM_WNA 8
-#define SCM_OUTOFRANGE 10
-#define SCM_NALLOC 11
-
-SCM_DEPRECATED void scm_register_module_xxx (char *module_name, void *init_func);
-SCM_DEPRECATED SCM scm_registered_modules (void);
-SCM_DEPRECATED SCM scm_clear_registered_modules (void);
-
-SCM_DEPRECATED SCM scm_protect_object (SCM obj);
-SCM_DEPRECATED SCM scm_unprotect_object (SCM obj);
-
-#define SCM_SETAND_CAR(x, y) \
- (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) & (y))))
-#define SCM_SETOR_CAR(x, y)\
- (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) | (y))))
-#define SCM_SETAND_CDR(x, y)\
- (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) & (y))))
-#define SCM_SETOR_CDR(x, y)\
- (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) | (y))))
-#define SCM_FREEP(x) (0)
-#define SCM_NFREEP(x) (1)
-#define SCM_GCTYP16(x) SCM_TYP16 (x)
-#define SCM_GCCDR(x) SCM_CDR (x)
-SCM_DEPRECATED void scm_remember (SCM * ptr);
-
-SCM_DEPRECATED SCM scm_make_module (SCM name);
-SCM_DEPRECATED SCM scm_ensure_user_module (SCM name);
-SCM_DEPRECATED SCM scm_load_scheme_module (SCM name);
-
-#define scm_port scm_t_port
-#define scm_ptob_descriptor scm_t_ptob_descriptor
-#define scm_port_rw_active scm_t_port_rw_active
-
-SCM_DEPRECATED SCM scm_close_all_ports_except (SCM ports);
-
-#define scm_rstate scm_t_rstate
-#define scm_rng scm_t_rng
-
-#define SCM_SLOPPY_CONSP(x) ((1 & SCM_CELL_TYPE (x)) == 0)
-#define SCM_SLOPPY_NCONSP(x) (!SCM_SLOPPY_CONSP(x))
-
-#define scm_tc7_ssymbol scm_tc7_symbol
-#define scm_tc7_msymbol scm_tc7_symbol
-#define scm_tcs_symbols scm_tc7_symbol
-
-SCM_DEPRECATED SCM scm_makstr (size_t len, int);
-SCM_DEPRECATED SCM scm_makfromstr (const char *src, size_t len, int);
-
-SCM_DEPRECATED SCM scm_variable_set_name_hint (SCM var, SCM hint);
-SCM_DEPRECATED SCM scm_builtin_variable (SCM name);
-
-SCM_DEPRECATED SCM scm_internal_with_fluids (SCM fluids, SCM vals,
- SCM (*cproc)(void *),
- void *cdata);
-
-SCM_DEPRECATED SCM scm_make_gsubr (const char *name,
- int req, int opt, int rst,
- scm_t_subr fcn);
-SCM_DEPRECATED SCM scm_make_gsubr_with_generic (const char *name,
- int req,
- int opt,
- int rst,
- scm_t_subr fcn,
- SCM *gf);
-
-SCM_DEPRECATED SCM scm_create_hook (const char* name, int n_args);
-
-
/* Deprecated 13-05-2011 because it's better just to scm_dynwind_begin.
That also avoids the temptation to stuff pointers in an SCM. */
@@ -154,6 +41,39 @@ SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before,
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)
@@ -172,644 +92,59 @@ SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before,
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);
+#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
-SCM_DEPRECATED SCM scm_make_real (double x);
-SCM_DEPRECATED double scm_num2dbl (SCM a, const char * why);
-SCM_DEPRECATED SCM scm_float2num (float n);
-SCM_DEPRECATED SCM scm_double2num (double n);
-
-/* The next two are implemented in numbers.c since they use features
- only available there.
-*/
-SCM_DEPRECATED float scm_num2float (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED double scm_num2double (SCM num, unsigned long int pos,
- const char *s_caller);
-
-SCM_DEPRECATED SCM scm_make_complex (double x, double y);
-
-/* Discouraged because they don't make the encoding explicit.
- */
-
-SCM_DEPRECATED SCM scm_mem2symbol (const char *mem, size_t len);
-SCM_DEPRECATED SCM scm_mem2uninterned_symbol (const char *mem, size_t len);
-SCM_DEPRECATED SCM scm_str2symbol (const char *str);
-
-SCM_DEPRECATED SCM scm_take_str (char *s, size_t len);
-SCM_DEPRECATED SCM scm_take0str (char *s);
-SCM_DEPRECATED SCM scm_mem2string (const char *src, size_t len);
-SCM_DEPRECATED SCM scm_str2string (const char *src);
-SCM_DEPRECATED SCM scm_makfrom0str (const char *src);
-SCM_DEPRECATED SCM scm_makfrom0str_opt (const char *src);
-
-/* Discouraged because scm_c_make_string has a better name and is more
- consistent with make-string.
- */
-SCM_DEPRECATED SCM scm_allocate_string (size_t len);
-
-/* Discouraged because they are just strange.
- */
-
-SCM_DEPRECATED SCM scm_make_keyword_from_dash_symbol (SCM symbol);
-SCM_DEPRECATED SCM scm_keyword_dash_symbol (SCM keyword);
-
-/* Discouraged because it does not state what encoding S is in.
- */
-
-SCM_DEPRECATED SCM scm_c_make_keyword (const char *s);
-
-SCM_DEPRECATED unsigned int scm_thread_sleep (unsigned int);
-SCM_DEPRECATED unsigned long scm_thread_usleep (unsigned long);
-SCM_DEPRECATED int scm_internal_select (int fds,
- SELECT_TYPE *rfds,
- SELECT_TYPE *wfds,
- SELECT_TYPE *efds,
- struct timeval *timeout);
-
-/* 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_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);
-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)
-
-
-
void scm_i_init_deprecated (void);
#endif
diff --git a/libguile/deprecation.c b/libguile/deprecation.c
index 08227071f..5c1a246c2 100644
--- a/libguile/deprecation.c
+++ b/libguile/deprecation.c
@@ -89,7 +89,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 a2ae6e267..72305a41b 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -185,11 +185,11 @@ scm_t_bits scm_tc16_dynamic_obj;
static int
dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<dynamic-object ", port);
+ scm_puts_unlocked ("#<dynamic-object ", port);
scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
if (DYNL_HANDLE (exp) == NULL)
- scm_puts (" (unlinked)", port);
- scm_putc ('>', port);
+ scm_puts_unlocked (" (unlinked)", port);
+ scm_putc_unlocked ('>', port);
return 1;
}
diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index 14dd861dc..bec2dc806 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -195,7 +195,7 @@ void
scm_swap_bindings (SCM vars, SCM vals)
{
SCM tmp;
- while (SCM_NIMP (vals))
+ while (scm_is_pair (vals))
{
tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
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 e008b3a08..ad0a84a58 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -229,10 +229,9 @@ eval (SCM x, SCM env)
mx = SCM_MEMOIZED_ARGS (x);
switch (SCM_MEMOIZED_TAG (x))
{
- case SCM_M_BEGIN:
- for (; !scm_is_null (CDR (mx)); mx = CDR (mx))
- eval (CAR (mx), env);
- x = CAR (mx);
+ case SCM_M_SEQ:
+ eval (CAR (mx), env);
+ x = CDR (mx);
goto loop;
case SCM_M_IF:
@@ -914,16 +913,16 @@ static int
boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
{
SCM args;
- scm_puts ("#<boot-closure ", port);
- scm_uintprint ((scm_t_bits)SCM2PTR (closure), 16, port);
- scm_putc (' ', port);
+ scm_puts_unlocked ("#<boot-closure ", port);
+ scm_uintprint (SCM_UNPACK (closure), 16, port);
+ scm_putc_unlocked (' ', port);
args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
scm_from_latin1_symbol ("_"));
if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
args = scm_cons_star (scm_from_latin1_symbol ("_"), args);
/* FIXME: optionals and rests */
scm_display (args, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
diff --git a/libguile/evalext.c b/libguile/evalext.c
index c1d46b56d..3e04a7a59 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -76,6 +76,8 @@ 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:
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 bdecd80d8..3f23d4f8f 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
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -71,10 +71,10 @@ 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 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) \
@@ -359,9 +359,9 @@ expand (SCM exp, SCM env)
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));
+ return CALL (scm_source_properties (exp),
+ expand (proc, env),
+ scm_reverse_x (args, SCM_UNDEFINED));
else
syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
}
@@ -396,7 +396,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));
}
@@ -487,10 +489,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 */
@@ -993,9 +995,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
@@ -1212,13 +1214,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,
@@ -1243,8 +1245,9 @@ 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);
diff --git a/libguile/expand.h b/libguile/expand.h
index 02e6e179e..f5e7af5d4 100644
--- a/libguile/expand.h
+++ b/libguile/expand.h
@@ -47,8 +47,9 @@ 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,
@@ -228,30 +229,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 \
diff --git a/libguile/feature.c b/libguile/feature.c
index f3bddc788..c11cb5e9e 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,21 +110,13 @@ 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
- scm_c_define ("char-code-limit", scm_from_int (SCM_CHAR_CODE_LIMIT));
-
#include "libguile/feature.x"
}
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 18ad9746c..63e5a206b 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1005,7 +1005,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
@@ -1775,12 +1775,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 967ce7450..c420992bd 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -3,7 +3,7 @@
#ifndef SCM_FILESYS_H
#define SCM_FILESYS_H
-/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,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
@@ -31,7 +31,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/fluids.c b/libguile/fluids.c
index f1c09cb30..55910b0a5 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -79,25 +79,25 @@ grow_dynamic_state (SCM state)
void
scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<fluid ", port);
+ scm_puts_unlocked ("#<fluid ", port);
scm_intprint ((int) FLUID_NUM (exp), 10, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
void
scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<dynamic-state ", port);
+ scm_puts_unlocked ("#<dynamic-state ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
void
scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<with-fluids ", port);
+ scm_puts_unlocked ("#<with-fluids ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
@@ -156,11 +156,11 @@ 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],
- SCM2PTR (fluid));
+ SCM_HEAP_OBJECT_BASE (fluid));
scm_dynwind_end ();
diff --git a/libguile/fluids.h b/libguile/fluids.h
index 2b91ff3d1..7d134b922 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -32,7 +32,7 @@
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_P(x) (SCM_HAS_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))
@@ -54,7 +54,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))
@@ -83,7 +83,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
diff --git a/libguile/foreign.c b/libguile/foreign.c
index f8c268d51..445ce0289 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -87,22 +87,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 (GC_PTR ptr, GC_PTR 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,
@@ -155,7 +152,7 @@ scm_from_pointer (void *ptr, scm_t_pointer_finalizer finalizer)
/* Register a finalizer for the newly created instance. */
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret),
pointer_finalizer_trampoline,
finalizer,
&prev_finalizer,
@@ -198,7 +195,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;
@@ -270,8 +267,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
@@ -321,7 +318,7 @@ SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0,
SCM_SET_CELL_WORD_0 (pointer, SCM_CELL_WORD_0 (pointer) | (1 << 16UL));
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (pointer),
pointer_finalizer_trampoline,
c_finalizer,
&prev_finalizer,
@@ -334,9 +331,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 ("#<pointer 0x", port);
+ scm_puts_unlocked ("#<pointer 0x", port);
scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
@@ -1128,7 +1125,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));
@@ -1159,7 +1156,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)
{
@@ -1305,7 +1302,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 6c6f37306..eac4ca048 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -49,8 +49,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) \
diff --git a/libguile/fports.c b/libguile/fports.c
index 3ac3ced8b..97dadded5 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -216,7 +216,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
drained = scm_nullstr;
if (SCM_OUTPUT_PORT_P (port))
- scm_flush (port);
+ scm_flush_unlocked (port);
if (pt->read_buf == pt->putback_buf)
{
@@ -535,7 +535,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;
int flags;
/* test that fdes is valid. */
@@ -554,26 +554,21 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
}
- 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
@@ -642,7 +637,7 @@ fport_input_waiting (SCM port)
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))
{
@@ -651,8 +646,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)
@@ -664,11 +659,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;
}
@@ -723,7 +718,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
diff --git a/libguile/fports.h b/libguile/fports.h
index cbef0f8ec..32b6a5947 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 Free Software Foundation, 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,7 +39,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))
diff --git a/libguile/frames.c b/libguile/frames.c
index 2e83cde9a..b805137a4 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -45,12 +45,12 @@ scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
void
scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<frame ", port);
+ scm_puts_unlocked ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
diff --git a/libguile/frames.h b/libguile/frames.h
index ffb577a8a..cae2bd0c0 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -111,7 +111,7 @@ struct scm_frame
scm_t_ptrdiff offset;
};
-#define SCM_VM_FRAME_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_frame)
+#define SCM_VM_FRAME_P(x) (SCM_HAS_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
diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
index de8e9e2b3..5c230dd1f 100644
--- a/libguile/gc-malloc.c
+++ b/libguile/gc-malloc.c
@@ -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"
@@ -242,106 +241,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.");
-
-#ifdef GUILE_DEBUG_MALLOC
- scm_malloc_unregister (obj);
-#endif
-
- 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 7816801e1..5f61a1de8 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -22,8 +22,6 @@
# include <config.h>
#endif
-#define SCM_BUILDING_DEPRECATED_CODE
-
#include "libguile/gen-scmconfig.h"
#include <stdio.h>
@@ -49,7 +47,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"
@@ -82,14 +79,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)
@@ -951,6 +944,10 @@ 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:
diff --git a/libguile/gc.h b/libguile/gc.h
index 310569d29..30d06995e 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -35,22 +35,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
@@ -58,12 +45,13 @@ typedef struct scm_t_cell
* in debug mode. In particular these macros will even work for free cells,
* which should never be encountered by user code. */
-#define SCM_GC_CELL_OBJECT(x, n) (((SCM *)SCM2PTR (x)) [n])
-#define SCM_GC_CELL_WORD(x, n) (SCM_UNPACK (SCM_GC_CELL_OBJECT ((x), (n))))
+#define SCM_GC_CELL_OBJECT(x, n) (SCM_PACK (SCM_HEAP_OBJECT_BASE (x)[n]))
+#define SCM_GC_CELL_WORD(x, n) (SCM_HEAP_OBJECT_BASE (x)[n])
-#define SCM_GC_SET_CELL_OBJECT(x, n, v) ((((SCM *)SCM2PTR (x)) [n]) = (v))
+#define SCM_GC_SET_CELL_OBJECT(x, n, v) \
+ (SCM_HEAP_OBJECT_BASE (x)[n] = SCM_UNPACK (v))
#define SCM_GC_SET_CELL_WORD(x, n, v) \
- (SCM_GC_SET_CELL_OBJECT ((x), (n), SCM_PACK (v)))
+ (SCM_HEAP_OBJECT_BASE (x)[n] = (v))
#define SCM_GC_CELL_TYPE(x) (SCM_GC_CELL_OBJECT ((x), 0))
@@ -109,7 +97,8 @@ typedef struct scm_t_cell
#define SCM_SET_CELL_OBJECT_2(x, v) SCM_SET_CELL_OBJECT ((x), 2, (v))
#define SCM_SET_CELL_OBJECT_3(x, v) SCM_SET_CELL_OBJECT ((x), 3, (v))
-#define SCM_CELL_OBJECT_LOC(x, n) (SCM_VALIDATE_CELL((x), &SCM_GC_CELL_OBJECT ((x), (n))))
+#define SCM_CELL_WORD_LOC(x, n) (SCM_VALIDATE_CELL((x), &SCM_GC_CELL_WORD ((x), (n))))
+#define SCM_CELL_OBJECT_LOC(x, n) ((SCM *) SCM_CELL_WORD_LOC (x, n))
#define SCM_CARLOC(x) (SCM_CELL_OBJECT_LOC ((x), 0))
#define SCM_CDRLOC(x) (SCM_CELL_OBJECT_LOC ((x), 1))
@@ -138,20 +127,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;
@@ -207,6 +182,114 @@ SCM_API char *scm_gc_strdup (const char *str, const char *what)
SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what)
SCM_MALLOC;
+
+#ifdef BUILDING_LIBGUILE
+#include "libguile/bdw-gc.h"
+#define SCM_GC_MALLOC(size) GC_MALLOC (size)
+#define SCM_GC_MALLOC_POINTERLESS(size) GC_MALLOC_ATOMIC (size)
+#else
+#define SCM_GC_MALLOC(size) scm_gc_malloc (size, NULL)
+#define SCM_GC_MALLOC_POINTERLESS(size) scm_gc_malloc_pointerless (size, NULL)
+#endif
+
+
+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
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_cell (scm_t_bits car, scm_t_bits cdr)
+{
+ 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
+ can actually run during this code, which it can't since the GC only runs
+ when all other threads are stopped. */
+ SCM_GC_SET_CELL_WORD (cell, 1, cdr);
+ SCM_GC_SET_CELL_WORD (cell, 0, car);
+
+ return cell;
+}
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr)
+{
+ SCM z;
+
+ z = SCM_PACK_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
+ since the GC only runs when all other threads are stopped.
+ */
+ SCM_GC_SET_CELL_WORD (z, 1, cbr);
+ SCM_GC_SET_CELL_WORD (z, 2, ccr);
+ SCM_GC_SET_CELL_WORD (z, 3, cdr);
+ SCM_GC_SET_CELL_WORD (z, 0, car);
+
+ /* When this function is inlined, it's possible that the last
+ SCM_GC_SET_CELL_WORD above will be adjacent to a following
+ initialization of z. E.g., it occurred in scm_make_real. GCC
+ from around version 3 (e.g., certainly 3.2) began taking
+ advantage of strict C aliasing rules which say that it's OK to
+ interchange the initialization above and the one below when the
+ pointer types appear to differ sufficiently. We don't want that,
+ of course. GCC allows this behaviour to be disabled with the
+ -fno-strict-aliasing option, but would also need to be supplied
+ by Guile users. Instead, the following statements prevent the
+ reordering.
+ */
+#ifdef __GNUC__
+ __asm__ volatile ("" : : : "memory");
+#else
+ /* portable version, just in case any other compiler does the same
+ thing. */
+ scm_remember_upto_here_1 (z);
+#endif
+
+ return z;
+}
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_words (scm_t_bits car, scm_t_uint16 n_words)
+{
+ SCM z;
+
+ 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? */
+
+ /* When this function is inlined, it's possible that the last
+ SCM_GC_SET_CELL_WORD above will be adjacent to a following
+ initialization of z. E.g., it occurred in scm_make_real. GCC
+ from around version 3 (e.g., certainly 3.2) began taking
+ advantage of strict C aliasing rules which say that it's OK to
+ interchange the initialization above and the one below when the
+ pointer types appear to differ sufficiently. We don't want that,
+ of course. GCC allows this behaviour to be disabled with the
+ -fno-strict-aliasing option, but would also need to be supplied
+ by Guile users. Instead, the following statements prevent the
+ reordering.
+ */
+#ifdef __GNUC__
+ __asm__ volatile ("" : : : "memory");
+#else
+ /* portable version, just in case any other compiler does the same
+ thing. */
+ scm_remember_upto_here_1 (z);
+#endif
+
+ return z;
+}
+
+#endif /* SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES */
+
SCM_API void scm_remember_upto_here_1 (SCM obj);
SCM_API void scm_remember_upto_here_2 (SCM obj1, SCM obj2);
SCM_API void scm_remember_upto_here (SCM obj1, ...);
@@ -244,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/gdbint.c b/libguile/gdbint.c
index 77fdbd17a..b502c7c46 100644
--- a/libguile/gdbint.c
+++ b/libguile/gdbint.c
@@ -150,7 +150,7 @@ gdb_read (char *str)
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_puts_unlocked (str, gdb_input_port);
scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
@@ -158,7 +158,7 @@ gdb_read (char *str)
ans = scm_read (gdb_input_port);
if (SCM_GC_P)
{
- if (SCM_NIMP (ans))
+ if (SCM_HEAP_OBJECT_P (ans))
{
SEND_STRING ("Non-immediate created during gc. Memory may be trashed.");
status = -1;
@@ -167,7 +167,7 @@ gdb_read (char *str)
}
gdb_result = ans;
/* Protect answer from future GC (FIXME: still needed with BDW-GC?) */
- if (SCM_NIMP (ans))
+ if (SCM_HEAP_OBJECT_P (ans))
scm_permanent_object (ans);
exit:
remark_port (gdb_input_port);
@@ -213,7 +213,7 @@ gdb_print (SCM obj)
{
scm_t_port *pt = SCM_PTAB_ENTRY (gdb_output_port);
- scm_flush (gdb_output_port);
+ scm_flush_unlocked (gdb_output_port);
*(pt->write_buf + pt->read_buf_size) = 0;
SEND_STRING (pt->read_buf);
}
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index 176f25c02..422f826c3 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -37,9 +37,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
@@ -383,15 +383,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 2f9cf30b9..5e846eeae 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -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
@@ -172,7 +164,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 +191,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 +218,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;
@@ -934,7 +921,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 +955,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);
}
@@ -982,7 +967,7 @@ create_basic_classes (void)
/**** <class> ****/
SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
SCM name = scm_from_latin1_symbol ("<class>");
- scm_class_class = scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL);
+ scm_class_class = scm_i_make_vtable_vtable (cs);
SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_METACLASS));
@@ -1000,21 +985,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);
/**** <top> ****/
name = scm_from_latin1_symbol ("<top>");
scm_class_top = scm_basic_make_class (scm_class_class, name,
SCM_EOL, SCM_EOL);
- DEFVAR(name, scm_class_top);
+ scm_module_define (scm_module_goops, name, scm_class_top);
/**** <object> ****/
name = scm_from_latin1_symbol ("<object>");
scm_class_object = scm_basic_make_class (scm_class_class, name,
scm_list_1 (scm_class_top), SCM_EOL);
- DEFVAR (name, scm_class_object);
+ scm_module_define (scm_module_goops, name, scm_class_object);
/* <top> <object> and <class> were partially initialized. Correct them here */
SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class));
@@ -1733,36 +1718,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 +1861,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 +2363,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);
}
@@ -2572,30 +2568,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 +2597,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 +2706,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));
}
@@ -2843,7 +2828,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
index b6f261faf..84846cf35 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -791,7 +791,7 @@ create_gsubr (int define, const char *name,
scm_t_bits flags;
/* make objtable */
- sname = scm_from_locale_symbol (name);
+ sname = scm_from_utf8_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);
@@ -858,13 +858,13 @@ scm_c_define_gsubr_with_generic (const char *name,
SCM
gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
{
- scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
+ scm_puts_unlocked ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
scm_display(req1, scm_cur_outp);
- scm_puts ("\n req2: ", scm_cur_outp);
+ scm_puts_unlocked ("\n req2: ", scm_cur_outp);
scm_display(req2, scm_cur_outp);
- scm_puts ("\n opt: ", scm_cur_outp);
+ scm_puts_unlocked ("\n opt: ", scm_cur_outp);
scm_display(opt, scm_cur_outp);
- scm_puts ("\n rest: ", scm_cur_outp);
+ scm_puts_unlocked ("\n rest: ", scm_cur_outp);
scm_display(rst, scm_cur_outp);
scm_newline(scm_cur_outp);
return SCM_UNSPECIFIED;
diff --git a/libguile/guardians.c b/libguile/guardians.c
index 81313df31..532137857 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -57,7 +57,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"
@@ -87,16 +86,16 @@ guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
{
t_guardian *g = GUARDIAN_DATA (guardian);
- scm_puts ("#<guardian ", port);
+ scm_puts_unlocked ("#<guardian ", port);
scm_uintprint ((scm_t_bits) g, 16, port);
- scm_puts (" (reachable: ", port);
+ scm_puts_unlocked (" (reachable: ", port);
scm_display (scm_from_uint (g->live), port);
- scm_puts (" unreachable: ", port);
+ scm_puts_unlocked (" unreachable: ", port);
scm_display (scm_length (g->zombies), port);
- scm_puts (")", port);
+ scm_puts_unlocked (")", port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
@@ -109,9 +108,9 @@ finalize_guarded (GC_PTR ptr, GC_PTR 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",
@@ -131,9 +130,12 @@ finalize_guarded (GC_PTR ptr, GC_PTR 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
@@ -142,7 +144,7 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
continue;
}
- g = GUARDIAN_DATA (SCM_CAR (guardian_list));
+ g = GUARDIAN_DATA (guardian);
if (g->live == 0)
abort ();
@@ -166,8 +168,8 @@ finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
GC_finalization_proc finalizer, prev_finalizer;
GC_PTR 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 ();
@@ -191,7 +193,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
@@ -209,13 +211,17 @@ 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),
+ /* FIXME: should be SCM_HEAP_OBJECT_BASE, but will the finalizer
+ strip the tag bits of pairs or structs? */
+ 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)
@@ -227,7 +233,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 ();
@@ -244,8 +250,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);
}
}
diff --git a/libguile/guile.c b/libguile/guile.c
index ac22b83df..133afc43e 100644
--- a/libguile/guile.c
+++ b/libguile/guile.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1996,1997,2000,2001, 2006, 2008, 2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1996, 1997, 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
* as published by the Free Software Foundation; either version 3 of
@@ -36,6 +37,7 @@
#include <libguile/scmconfig.h>
#endif
#include <ltdl.h>
+#include <locale.h>
#ifdef HAVE_WINSOCK2_H
#include <winsock2.h>
@@ -67,6 +69,14 @@ inner_main (void *closure SCM_UNUSED, int argc, char **argv)
int
main (int argc, char **argv)
{
+ /* Install the locale right at the beginning so that string conversion
+ for command-line arguments, along with possible error messages, use
+ the right locale. See
+ <https://lists.gnu.org/archive/html/guile-devel/2011-11/msg00041.html>
+ for the rationale. */
+ if (setlocale (LC_ALL, "") == NULL)
+ fprintf (stderr, "guile: warning: failed to install locale\n");
+
scm_install_gmp_memory_functions = 1;
scm_boot_guile (argc, argv, inner_main, 0);
return 0; /* never reached */
diff --git a/libguile/hash.c b/libguile/hash.c
index a79f03d95..d47c7e054 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -45,232 +45,271 @@ 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)
{
- ucs4_t c;
- int nbytes;
-
- nbytes = u8_mbtouc (&c, ustr + byte_idx, len - byte_idx);
- if (nbytes == 0)
- break;
- else if (nbytes < 0)
- /* Bad UTF-8; punt. */
- return scm_i_string_hash (scm_from_utf8_stringn (str, len));
-
- h = (unsigned long) c + h * 37;
- byte_idx += nbytes;
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ a += u32;
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ b += u32;
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ c += u32;
+ mix (a, b, c);
+ length -= 3;
}
- return h;
-}
+ /* Handle the last 3 elements's. */
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ a += u32;
+ if (--length)
+ {
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ b += u32;
+ if (--length)
+ {
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ c += u32;
+ }
+ }
+ final (a, b, c);
-/* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
-/* Dirk:FIXME:: scm_hasher could be made static. */
+ 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;
+}
-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;
- }
+ 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);
+ 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;
}
@@ -300,13 +339,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;
}
@@ -336,7 +372,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 c4f2b5eb0..4091afeb9 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -53,9 +53,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.
*/
@@ -75,201 +72,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;
@@ -278,9 +82,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);
@@ -288,8 +89,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),
@@ -322,13 +121,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;
@@ -342,13 +134,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);
@@ -368,10 +153,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));
@@ -386,26 +167,19 @@ 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 ("#<hash-table ", port);
scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
- scm_putc ('/', port);
+ scm_putc_unlocked ('/', port);
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
10, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
SCM
scm_c_make_hash_table (unsigned long k)
{
- return make_hash_table (0, k, "scm_c_make_hash_table");
+ return make_hash_table (k, "scm_c_make_hash_table");
}
SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
@@ -413,171 +187,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
@@ -602,69 +223,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;
}
@@ -690,11 +249,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;
@@ -702,29 +257,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))
@@ -760,36 +295,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,
@@ -801,24 +306,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 ((GC_PTR) SCM_CDRLOC (pair));
- else
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) SCM_CDRLOC (pair),
- (GC_PTR) SCM2PTR (val));
- }
- else
- SCM_SETCDR (pair, val);
- }
+ SCM_SETCDR (pair, val);
return val;
}
@@ -845,11 +333,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))
{
@@ -868,6 +352,9 @@ 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))
+ return scm_weak_table_clear_x (table);
+
SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
@@ -887,9 +374,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,
@@ -905,9 +389,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,
@@ -926,6 +407,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,
@@ -941,6 +426,9 @@ SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
"store @var{value} there. Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_set_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_putq_x (table, key, val);
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@@ -956,6 +444,9 @@ 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))
+ return scm_weak_table_remq_x (table, key);
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
@@ -974,9 +465,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,
@@ -992,9 +480,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,
@@ -1003,6 +488,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"
@@ -1013,6 +504,11 @@ 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, SCM_PACK (key), dflt);
+
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -1028,6 +524,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, SCM_PACK (key),
+ key, val);
+ return SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -1042,6 +546,13 @@ 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, SCM_PACK (key));
+ return SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
@@ -1059,9 +570,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,
@@ -1077,9 +585,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,
@@ -1088,6 +593,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"
@@ -1098,6 +609,11 @@ 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, SCM_PACK (key), dflt);
+
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -1114,6 +630,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, SCM_PACK (key),
+ key, val);
+ return SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -1129,6 +653,13 @@ 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, SCM_PACK (key));
+ return SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
@@ -1143,10 +674,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)
{
@@ -1156,8 +686,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)
{
@@ -1165,6 +693,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),
@@ -1179,9 +721,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);
@@ -1202,9 +742,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);
@@ -1231,6 +769,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);
}
@@ -1255,6 +802,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 SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
(void *)&closure);
}
@@ -1276,6 +833,16 @@ 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);
+ return SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
}
@@ -1296,6 +863,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);
@@ -1317,6 +888,10 @@ 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))
+ return scm_weak_table_for_each (proc, table);
+
SCM_VALIDATE_HASHTABLE (2, table);
scm_internal_hash_for_each_handle (for_each_proc,
@@ -1335,9 +910,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);
@@ -1360,6 +932,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),
@@ -1378,6 +954,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);
@@ -1390,14 +969,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 314994630..8eb685a0e 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 ("#<hook ", port);
+ scm_puts_unlocked ("#<hook ", port);
scm_intprint (SCM_HOOK_ARITY (hook), 10, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_UNPACK (hook), 16, port);
ls = SCM_HOOK_PROCEDURES (hook);
- while (SCM_NIMP (ls))
+ while (scm_is_pair (ls))
{
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
name = scm_procedure_name (SCM_CAR (ls));
if (scm_is_true (name))
scm_iprin1 (name, port, pstate);
else
- scm_putc ('?', port);
+ scm_putc_unlocked ('?', port);
ls = SCM_CDR (ls);
}
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
@@ -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 633f8c681..35ab85603 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -133,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"
@@ -383,11 +382,11 @@ 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 */
@@ -488,7 +487,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 */
@@ -515,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 ();
diff --git a/libguile/inline.c b/libguile/inline.c
index 79728ff13..7b900f71a 100644
--- a/libguile/inline.c
+++ b/libguile/inline.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 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
@@ -20,5 +20,9 @@
# include <config.h>
#endif
-#define SCM_INLINE_C_INCLUDING_INLINE_H 1
+#define SCM_IMPLEMENT_INLINES 1
+#define SCM_INLINE_C_IMPLEMENTING_INLINES 1
#include "libguile/inline.h"
+#include "libguile/gc.h"
+#include "libguile/smob.h"
+#include "libguile/ports.h"
diff --git a/libguile/inline.h b/libguile/inline.h
index a78cac515..fe9cac70f 100644
--- a/libguile/inline.h
+++ b/libguile/inline.h
@@ -23,12 +23,9 @@
*/
/* This file is for inline functions. On platforms that don't support
- inlining functions, they are turned into ordinary functions. See
- "inline.c".
-*/
-
-#include <stdio.h>
-#include <string.h>
+ 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"
@@ -41,174 +38,21 @@
#include "libguile/error.h"
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-
-/* GCC has `__inline__' in all modes, including strict ansi. GCC 4.3 and
- above with `-std=c99' or `-std=gnu99' implements ISO C99 inline semantics,
- unless `-fgnu89-inline' is used. Here we want GNU "extern inline"
- semantics, hence the `__gnu_inline__' attribute, in accordance with:
- http://gcc.gnu.org/gcc-4.3/porting_to.html .
-
- With GCC 4.2, `__GNUC_STDC_INLINE__' is never defined (because C99 inline
- semantics are not supported), but a warning is issued in C99 mode if
- `__gnu_inline__' is not used.
-
- Apple's GCC build >5400 (since Xcode 3.0) doesn't support GNU inline in
- C99 mode and doesn't define `__GNUC_STDC_INLINE__'. Fall back to "static
- inline" in that case. */
-
-# if (defined __GNUC__) && (!(((defined __APPLE_CC__) && (__APPLE_CC__ > 5400)) && __STDC_VERSION__ >= 199901L))
-# define SCM_C_USE_EXTERN_INLINE 1
-# if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2)
-# define SCM_C_EXTERN_INLINE \
- extern __inline__ __attribute__ ((__gnu_inline__))
-# else
-# define SCM_C_EXTERN_INLINE extern __inline__
-# endif
-# elif (defined SCM_C_INLINE)
-# define SCM_C_EXTERN_INLINE static SCM_C_INLINE
-# endif
-
-#endif /* SCM_INLINE_C_INCLUDING_INLINE_H */
-
-
-#if (!defined SCM_C_INLINE) || (defined SCM_INLINE_C_INCLUDING_INLINE_H) \
- || (defined SCM_C_USE_EXTERN_INLINE)
-
-/* The `extern' declarations. They should only appear when used from
- "inline.c", when `inline' is not supported at all or when "extern inline"
- is used. */
+SCM_INLINE SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
+SCM_INLINE void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val);
-#include "libguile/bdw-gc.h"
+SCM_INLINE int scm_is_pair (SCM x);
+SCM_INLINE int scm_is_string (SCM x);
-
-SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
-SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+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_API SCM scm_words (scm_t_bits car, scm_t_uint16 n_words);
-
-SCM_API SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
-SCM_API void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val);
-
-SCM_API int scm_is_pair (SCM x);
-SCM_API int scm_is_string (SCM x);
-
-SCM_API int scm_get_byte_or_eof (SCM port);
-SCM_API int scm_peek_byte_or_eof (SCM port);
-SCM_API void scm_putc (char c, SCM port);
-SCM_API void scm_puts (const char *str_data, SCM port);
-
-#endif
-
-
-#if defined SCM_C_EXTERN_INLINE || defined SCM_INLINE_C_INCLUDING_INLINE_H
-/* either inlining, or being included from inline.c. We use (and
- repeat) this long #if test here and below so that we don't have to
- introduce any extraneous symbols into the public namespace. We
- only need SCM_C_INLINE to be seen publically . */
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-
-SCM
-scm_cell (scm_t_bits car, scm_t_bits cdr)
-{
- SCM cell = PTR2SCM (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
- can actually run during this code, which it can't since the GC only runs
- when all other threads are stopped. */
- SCM_GC_SET_CELL_WORD (cell, 1, cdr);
- SCM_GC_SET_CELL_WORD (cell, 0, car);
-
- return cell;
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-SCM
-scm_double_cell (scm_t_bits car, scm_t_bits cbr,
- scm_t_bits ccr, scm_t_bits cdr)
-{
- SCM z;
-
- z = PTR2SCM (GC_MALLOC (2 * sizeof (scm_t_cell)));
- /* Initialize the type slot last so that the cell is ignored by the
- GC until it is completely initialized. This is only relevant
- when the GC can actually run during this code, which it can't
- since the GC only runs when all other threads are stopped.
- */
- SCM_GC_SET_CELL_WORD (z, 1, cbr);
- SCM_GC_SET_CELL_WORD (z, 2, ccr);
- SCM_GC_SET_CELL_WORD (z, 3, cdr);
- SCM_GC_SET_CELL_WORD (z, 0, car);
-
- /* When this function is inlined, it's possible that the last
- SCM_GC_SET_CELL_WORD above will be adjacent to a following
- initialization of z. E.g., it occurred in scm_make_real. GCC
- from around version 3 (e.g., certainly 3.2) began taking
- advantage of strict C aliasing rules which say that it's OK to
- interchange the initialization above and the one below when the
- pointer types appear to differ sufficiently. We don't want that,
- of course. GCC allows this behaviour to be disabled with the
- -fno-strict-aliasing option, but would also need to be supplied
- by Guile users. Instead, the following statements prevent the
- reordering.
- */
-#ifdef __GNUC__
- __asm__ volatile ("" : : : "memory");
-#else
- /* portable version, just in case any other compiler does the same
- thing. */
- scm_remember_upto_here_1 (z);
-#endif
-
- return z;
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-SCM
-scm_words (scm_t_bits car, scm_t_uint16 n_words)
-{
- SCM z;
-
- z = PTR2SCM (GC_MALLOC (sizeof (scm_t_bits) * n_words));
- SCM_GC_SET_CELL_WORD (z, 0, car);
+SCM_INLINE SCM scm_words (scm_t_bits car, scm_t_uint16 n_words);
- /* FIXME: is the following concern even relevant with BDW-GC? */
+#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
+/* Either inlining, or being included from inline.c. */
- /* When this function is inlined, it's possible that the last
- SCM_GC_SET_CELL_WORD above will be adjacent to a following
- initialization of z. E.g., it occurred in scm_make_real. GCC
- from around version 3 (e.g., certainly 3.2) began taking
- advantage of strict C aliasing rules which say that it's OK to
- interchange the initialization above and the one below when the
- pointer types appear to differ sufficiently. We don't want that,
- of course. GCC allows this behaviour to be disabled with the
- -fno-strict-aliasing option, but would also need to be supplied
- by Guile users. Instead, the following statements prevent the
- reordering.
- */
-#ifdef __GNUC__
- __asm__ volatile ("" : : : "memory");
-#else
- /* portable version, just in case any other compiler does the same
- thing. */
- scm_remember_upto_here_1 (z);
-#endif
-
- return z;
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-SCM
+SCM_INLINE_IMPLEMENTATION SCM
scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
{
if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
@@ -218,10 +62,7 @@ scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
return h->impl->vref (h, h->base + p);
}
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-void
+SCM_INLINE_IMPLEMENTATION void
scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
{
if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
@@ -231,10 +72,7 @@ scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
h->impl->vset (h, h->base + p, v);
}
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
+SCM_INLINE_IMPLEMENTATION int
scm_is_pair (SCM x)
{
/* The following "workaround_for_gcc_295" avoids bad code generated by
@@ -261,92 +99,11 @@ scm_is_pair (SCM x)
return SCM_I_CONSP (x);
}
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
+SCM_INLINE_IMPLEMENTATION int
scm_is_string (SCM x)
{
- return SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string);
-}
-
-/* Port I/O. */
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
-scm_get_byte_or_eof (SCM port)
-{
- int c;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (pt->rw_active == SCM_PORT_WRITE)
- /* may be marginally faster than calling scm_flush. */
- scm_ptobs[SCM_PTOBNUM (port)].flush (port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
-
- if (pt->read_pos >= pt->read_end)
- {
- if (SCM_UNLIKELY (scm_fill_input (port) == EOF))
- return EOF;
- }
-
- c = *(pt->read_pos++);
-
- return c;
-}
-
-/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
-scm_peek_byte_or_eof (SCM port)
-{
- int c;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (pt->rw_active == SCM_PORT_WRITE)
- /* may be marginally faster than calling scm_flush. */
- scm_ptobs[SCM_PTOBNUM (port)].flush (port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
-
- if (pt->read_pos >= pt->read_end)
- {
- if (SCM_UNLIKELY (scm_fill_input (port) == EOF))
- return EOF;
- }
-
- c = *pt->read_pos;
-
- return c;
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-void
-scm_putc (char c, SCM port)
-{
- SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
- scm_lfwrite (&c, 1, port);
+ return SCM_HAS_TYP7 (x, scm_tc7_string);
}
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-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
diff --git a/libguile/instructions.c b/libguile/instructions.c
index ef4a9ce17..f3b8963d2 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -72,7 +72,7 @@ fetch_instruction_table ()
{
table[i].opcode = i;
if (table[i].name)
- table[i].symname = scm_from_locale_symbol (table[i].name);
+ table[i].symname = scm_from_utf8_symbol (table[i].name);
else
table[i].symname = SCM_BOOL_F;
}
diff --git a/libguile/ioext.c b/libguile/ioext.c
index 6b0c9b88c..b1addf4c1 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/keywords.c b/libguile/keywords.c
index 3b9a9228c..e4a79ac4d 100644
--- a/libguile/keywords.c
+++ b/libguile/keywords.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,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
@@ -47,7 +47,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 221ee79d0..8297b17c5 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 007621883..135a621cb 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -667,11 +667,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;
@@ -686,10 +686,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 ());
@@ -718,16 +718,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;
}
@@ -736,22 +736,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 ());
}
@@ -769,7 +769,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;
@@ -788,9 +788,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);
}
@@ -937,7 +937,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);
@@ -1002,7 +1002,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/macros.c b/libguile/macros.c
index 556e60f57..7423e9758 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 ("#<primitive-syntax-transformer ", port);
+ scm_puts_unlocked ("#<primitive-syntax-transformer ", port);
else
- scm_puts ("#<syntax-transformer ", port);
+ scm_puts_unlocked ("#<syntax-transformer ", port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
@@ -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;
@@ -103,7 +103,7 @@ SCM_DEFINE (scm_make_syntax_transformer, "make-syntax-transformer", 3, 0, 0,
SCM_VALIDATE_SYMBOL (2, type);
z = scm_words (scm_tc16_macro, 5);
- SCM_SET_SMOB_DATA_N (z, 1, prim);
+ SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)prim);
SCM_SET_SMOB_OBJECT_N (z, 2, name);
SCM_SET_SMOB_OBJECT_N (z, 3, type);
SCM_SET_SMOB_OBJECT_N (z, 4, binding);
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("#<malloc ", port);
+ scm_puts_unlocked("#<malloc ", port);
scm_uintprint (SCM_SMOB_DATA (exp), 16, port);
- scm_putc('>', port);
+ scm_putc_unlocked('>', port);
return 1;
}
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 911d97294..1be276b36 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -67,8 +67,8 @@ scm_t_bits scm_tc16_memoized;
#define MAKMEMO(n, args) \
(scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args)))
-#define MAKMEMO_BEGIN(exps) \
- MAKMEMO (SCM_M_BEGIN, exps)
+#define MAKMEMO_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) \
@@ -124,7 +124,7 @@ scm_t_bits scm_tc16_memoizer;
/* This table must agree with the list of M_ constants in memoize.h */
static const char *const memoized_tags[] =
{
- "begin",
+ "seq",
"if",
"lambda",
"let",
@@ -148,9 +148,9 @@ static const char *const memoized_tags[] =
static int
scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<memoized ", port);
+ scm_puts_unlocked ("#<memoized ", port);
scm_write (scm_unmemoize_expression (memoized), port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
@@ -241,12 +241,12 @@ 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)
{
@@ -263,8 +263,23 @@ memoize (SCM exp, SCM env)
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 proc, args;
+
+ if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
+ proc = MAKMEMO_TOP_REF (REF (exp, PRIMCALL, NAME));
+ else
+ proc = MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMCALL, NAME),
+ SCM_BOOL_F);
+ args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
+
+ return MAKMEMO_CALL (proc, scm_ilength (args), 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. */
@@ -394,18 +409,21 @@ memoize (SCM exp, SCM env)
if (in_order_p)
{
- SCM body_exps = SCM_EOL;
+ SCM body_exps = SCM_EOL, seq;
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));
+
+ seq = memoize (body, new_env);
+ for (; scm_is_pair (body_exps); body_exps = CDR (body_exps))
+ seq = MAKMEMO_SEQ (CAR (body_exps), seq);
+
+ return MAKMEMO_LET (undefs, seq);
}
else
{
- SCM sets = SCM_EOL, inits = SCM_EOL;
+ SCM sets = SCM_EOL, inits = SCM_EOL, set_seq;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
{
sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
@@ -414,10 +432,18 @@ memoize (SCM exp, SCM env)
inits = scm_cons (memoize (CAR (exps), new_env), inits);
}
inits = scm_reverse_x (inits, SCM_UNDEFINED);
- return MAKMEMO_LET
- (undefs,
- MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)),
- memoize (body, new_env))));
+
+ sets = scm_reverse_x (sets, SCM_UNDEFINED);
+ if (scm_is_null (sets))
+ return memoize (body, env);
+
+ for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets);
+ sets = CDR (sets))
+ set_seq = MAKMEMO_SEQ (CAR (sets), set_seq);
+
+ return MAKMEMO_LET (undefs,
+ MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq),
+ memoize (body, new_env)));
}
}
@@ -592,7 +618,7 @@ unmemoize_lexical (SCM n)
char buf[16];
buf[15] = 0;
snprintf (buf, 15, "<%u>", scm_to_uint32 (n));
- return scm_from_locale_symbol (buf);
+ return scm_from_utf8_symbol (buf);
}
static SCM
@@ -608,8 +634,9 @@ unmemoize (const SCM expr)
{
case SCM_M_APPLY:
return scm_cons (scm_sym_atapply, unmemoize_exprs (args));
- case SCM_M_BEGIN:
- return scm_cons (scm_sym_begin, unmemoize_exprs (args));
+ case SCM_M_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:
diff --git a/libguile/memoize.h b/libguile/memoize.h
index 26bd5b1c1..da78b06fa 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
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -72,7 +72,7 @@ SCM_INTERNAL scm_t_bits scm_tc16_memoized;
enum
{
- SCM_M_BEGIN,
+ SCM_M_SEQ,
SCM_M_IF,
SCM_M_LAMBDA,
SCM_M_LET,
diff --git a/libguile/modules.c b/libguile/modules.c
index 6c3f2629e..7498549ee 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -153,7 +153,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);
}
@@ -218,7 +218,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)
@@ -226,7 +226,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);
@@ -695,7 +695,7 @@ scm_sym2var (SCM sym, SCM proc, SCM definep)
{
SCM var;
- if (SCM_NIMP (proc))
+ if (SCM_HEAP_OBJECT_P (proc))
{
if (SCM_EVAL_CLOSURE_P (proc))
{
@@ -734,7 +734,7 @@ scm_sym2var (SCM sym, SCM proc, SCM definep)
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
@@ -754,7 +754,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
@@ -807,14 +807,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
@@ -849,14 +849,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
@@ -875,20 +875,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
@@ -907,7 +907,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,
@@ -960,16 +960,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);
}
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 693838138..46a195a98 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -183,7 +183,7 @@ finalize_bignum (GC_PTR ptr, GC_PTR data)
{
SCM bignum;
- bignum = PTR2SCM (ptr);
+ bignum = SCM_PACK_POINTER (ptr);
mpz_clear (SCM_I_BIG_MPZ (bignum));
}
@@ -562,7 +562,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
@@ -583,7 +583,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
@@ -622,7 +622,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
@@ -656,7 +656,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
@@ -671,7 +671,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
@@ -686,7 +686,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
@@ -701,7 +701,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
@@ -828,7 +828,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
@@ -843,10 +843,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
@@ -864,10 +864,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
@@ -886,10 +886,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
@@ -910,10 +910,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,
@@ -1045,8 +1044,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))
{
@@ -1086,8 +1085,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))
{
@@ -1096,8 +1095,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))
{
@@ -1107,12 +1106,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
@@ -1205,8 +1204,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))
{
@@ -1241,8 +1240,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))
{
@@ -1251,8 +1250,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))
{
@@ -1262,12 +1261,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
@@ -1578,8 +1577,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))
{
@@ -1619,8 +1618,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))
{
@@ -1629,8 +1628,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))
{
@@ -1640,12 +1639,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
@@ -1748,8 +1747,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))
{
@@ -1784,8 +1783,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))
{
@@ -1794,8 +1793,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))
{
@@ -1805,12 +1804,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
@@ -2110,8 +2109,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))
{
@@ -2151,8 +2150,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))
{
@@ -2161,8 +2160,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))
{
@@ -2172,12 +2171,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
@@ -2245,8 +2244,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))
{
@@ -2279,8 +2278,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))
{
@@ -2289,8 +2288,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))
{
@@ -2300,12 +2299,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
@@ -2592,8 +2591,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))
{
@@ -2641,8 +2640,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))
{
@@ -2651,8 +2650,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))
{
@@ -2662,12 +2661,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
@@ -2806,8 +2805,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))
{
@@ -2847,8 +2846,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))
{
@@ -2857,8 +2856,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))
{
@@ -2868,12 +2867,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
@@ -3288,8 +3287,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))
{
@@ -3339,8 +3338,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))
{
@@ -3349,8 +3348,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))
{
@@ -3360,12 +3359,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
@@ -3492,8 +3491,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))
{
@@ -3540,8 +3539,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))
{
@@ -3550,8 +3549,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))
{
@@ -3561,12 +3560,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
@@ -3950,7 +3949,7 @@ scm_gcd (SCM x, SCM y)
goto big_inum;
}
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))
{
@@ -3980,10 +3979,10 @@ scm_gcd (SCM x, SCM y)
return scm_i_normbig (result);
}
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,
@@ -4014,10 +4013,11 @@ scm_lcm (SCM n1, SCM n2)
n2 = SCM_I_MAKINUM (1L);
}
- SCM_GASSERT2 (SCM_I_INUMP (n1) || SCM_BIGP (n1),
- g_lcm, n1, n2, SCM_ARG1, s_lcm);
- SCM_GASSERT2 (SCM_I_INUMP (n2) || SCM_BIGP (n2),
- g_lcm, n1, n2, SCM_ARGn, s_lcm);
+ if (SCM_UNLIKELY (!(SCM_I_INUMP (n1) || SCM_BIGP (n1))))
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
+
+ if (SCM_UNLIKELY (!(SCM_I_INUMP (n2) || SCM_BIGP (n2))))
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
if (SCM_I_INUMP (n1))
{
@@ -5147,12 +5147,6 @@ idbl2str (double f, char *a, int radix)
exp++;
}
zero:
-#ifdef ENGNOT
- /* adding 9999 makes this equivalent to abs(x) % 3 */
- dpt = (exp + 9999) % 3;
- exp -= dpt++;
- efmt = 1;
-#else
efmt = (exp < -3) || (exp > wp + 2);
if (!efmt)
{
@@ -5169,7 +5163,6 @@ idbl2str (double f, char *a, int radix)
}
else
dpt = 1;
-#endif
do
{
@@ -5191,7 +5184,6 @@ idbl2str (double f, char *a, int radix)
if (dpt > 0)
{
-#ifndef ENGNOT
if ((dpt > 4) && (exp > 6))
{
d = (a[0] == '-' ? 2 : 1);
@@ -5201,7 +5193,6 @@ idbl2str (double f, char *a, int radix)
efmt = 1;
}
else
-#endif
{
while (--dpt)
a[ch++] = '0';
@@ -5363,7 +5354,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;
}
@@ -5371,7 +5362,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
@@ -5379,7 +5370,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;
}
@@ -5387,7 +5378,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
@@ -5408,7 +5399,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;
}
@@ -6245,7 +6236,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))
{
@@ -6280,7 +6272,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))
{
@@ -6318,7 +6311,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))
{
@@ -6356,7 +6350,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))
{
@@ -6390,10 +6385,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);
}
@@ -6452,7 +6449,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))
{
@@ -6480,7 +6478,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))
{
@@ -6508,7 +6507,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))
{
@@ -6541,10 +6541,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);
}
@@ -6573,9 +6575,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);
}
@@ -6607,9 +6609,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
@@ -6643,9 +6645,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
@@ -6672,7 +6674,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
@@ -6696,7 +6698,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
@@ -6720,7 +6722,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
@@ -6754,11 +6756,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))
@@ -6797,7 +6799,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))
{
@@ -6827,7 +6829,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))
{
@@ -6882,7 +6884,7 @@ scm_max (SCM x, SCM y)
return (xx < yy) ? scm_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))
{
@@ -6905,10 +6907,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);
}
@@ -6935,11 +6937,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))
@@ -6968,7 +6970,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))
{
@@ -6998,7 +7000,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))
{
@@ -7042,7 +7044,7 @@ scm_min (SCM x, SCM y)
return (yy < xx) ? scm_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))
{
@@ -7065,10 +7067,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);
}
@@ -7097,7 +7099,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)))
@@ -7130,7 +7132,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))
@@ -7195,7 +7197,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))
{
@@ -7215,7 +7217,7 @@ scm_sum (SCM x, SCM y)
else if (SCM_FRACTIONP (y))
return scm_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))
{
@@ -7239,7 +7241,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))
{
@@ -7262,10 +7264,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);
}
@@ -7305,7 +7307,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))
{
@@ -7328,7 +7330,7 @@ scm_difference (SCM x, SCM y)
return scm_i_make_ratio (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)))
@@ -7415,7 +7417,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))
{
@@ -7479,7 +7481,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))
{
@@ -7499,7 +7502,7 @@ scm_difference (SCM x, SCM y)
else if (SCM_FRACTIONP (y))
return scm_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))
{
@@ -7523,7 +7526,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))
{
@@ -7547,10 +7550,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
@@ -7593,7 +7596,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)))
@@ -7626,7 +7629,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:
/*
@@ -7671,7 +7674,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))
{
@@ -7706,7 +7709,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))
{
@@ -7729,7 +7732,7 @@ scm_product (SCM x, SCM y)
else if (SCM_FRACTIONP (y))
return scm_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))
{
@@ -7762,7 +7765,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))
{
@@ -7787,10 +7790,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)) \
@@ -7854,7 +7857,7 @@ do_divide (SCM x, SCM y, int inexact)
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);
@@ -7908,7 +7911,7 @@ do_divide (SCM x, SCM y, int inexact)
return scm_i_make_ratio (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)))
@@ -7982,7 +7985,7 @@ do_divide (SCM x, SCM y, int inexact)
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))
{
@@ -8081,7 +8084,7 @@ do_divide (SCM x, SCM y, int inexact)
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))
{
@@ -8120,7 +8123,7 @@ do_divide (SCM x, SCM y, int inexact)
else if (SCM_FRACTIONP (y))
return scm_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))
{
@@ -8178,7 +8181,7 @@ do_divide (SCM x, SCM y, int inexact)
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))
{
@@ -8217,10 +8220,10 @@ do_divide (SCM x, SCM y, int inexact)
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);
}
SCM
@@ -8297,7 +8300,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
@@ -8317,8 +8320,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
@@ -8335,7 +8338,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
@@ -8352,7 +8355,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
@@ -8391,9 +8394,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
@@ -8420,7 +8423,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
@@ -8441,7 +8444,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
@@ -8466,7 +8469,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
@@ -8487,7 +8490,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
@@ -8508,7 +8511,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
@@ -8533,7 +8536,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
@@ -8561,7 +8564,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
@@ -8591,7 +8594,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
@@ -8618,17 +8621,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_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
@@ -8646,7 +8649,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
@@ -8664,7 +8667,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
@@ -8682,7 +8685,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
@@ -8691,7 +8694,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;
@@ -8783,7 +8786,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
@@ -8798,7 +8801,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
@@ -8814,7 +8817,7 @@ SCM_PRIMITIVE_GENERIC (scm_numerator, "numerator", 1, 0, 0,
else if (SCM_REALP (z))
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
@@ -8831,7 +8834,8 @@ SCM_PRIMITIVE_GENERIC (scm_denominator, "denominator", 1, 0, 0,
else if (SCM_REALP (z))
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
@@ -8873,7 +8877,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
@@ -8919,7 +8924,7 @@ SCM_PRIMITIVE_GENERIC (scm_angle, "angle", 1, 0, 0,
else return scm_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
@@ -8938,7 +8943,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
@@ -8959,7 +8965,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 (DOUBLE_IS_FINITE (val)))
SCM_OUT_OF_RANGE (1, z);
@@ -9339,7 +9346,7 @@ scm_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;
@@ -9347,46 +9354,6 @@ scm_from_double (double val)
return z;
}
-#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)
{
@@ -9536,7 +9503,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
@@ -9583,7 +9550,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
@@ -9611,7 +9578,7 @@ SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0,
return scm_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
@@ -9716,7 +9683,7 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
return scm_from_double (sqrt (xx));
}
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 68f321ef7..b7bcfe48c 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -125,22 +125,21 @@ 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)
-#define SCM_COMPLEX_IMAG(x) (((scm_t_complex *) SCM2PTR (x))->imag)
+#define SCM_REAL_VALUE(x) (((scm_t_double *) SCM_HEAP_OBJECT_BASE (x))->real)
+#define SCM_COMPLEX_REAL(x) (((scm_t_complex *) SCM_HEAP_OBJECT_BASE (x))->real)
+#define SCM_COMPLEX_IMAG(x) (((scm_t_complex *) SCM_HEAP_OBJECT_BASE (x))->imag)
/* 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))
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 004dd6118..df10ea3ce 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -376,17 +376,14 @@ SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0,
"")
#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);
+ return scm_c_take_gc_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode),
+ len, objcode);
}
#undef FUNC_NAME
@@ -422,9 +419,10 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
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);
+ scm_c_write_unlocked (port, cookie, strlen (SCM_OBJCODE_COOKIE));
+ scm_c_write_unlocked (port, SCM_OBJCODE_DATA (objcode),
+ sizeof (struct scm_objcode)
+ + total_size);
return SCM_UNSPECIFIED;
}
@@ -433,9 +431,9 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
void
scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<objcode ", port);
+ scm_puts_unlocked ("#<objcode ", port);
scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 0cfc8e027..0c3865ceb 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -40,7 +40,7 @@ struct scm_objcode
#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_P(x) (SCM_HAS_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)
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/ports.c b/libguile/ports.c
index a6311003a..c0e13f374 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -56,7 +56,7 @@
#include "libguile/validate.h"
#include "libguile/ports.h"
#include "libguile/vectors.h"
-#include "libguile/weaks.h"
+#include "libguile/weak-set.h"
#include "libguile/fluids.h"
#include "libguile/eq.h"
@@ -98,19 +98,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;
}
/*
@@ -134,235 +194,91 @@ 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_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;
+ scm_t_ptob_descriptor *desc;
+ long ptobnum;
- scm_ptobs[scm_numptob].write = write;
- scm_ptobs[scm_numptob].flush = flush_port_default;
+ desc = scm_gc_malloc_pointerless (sizeof (*desc), "port-type");
+ memset (desc, 0, sizeof (*desc));
- scm_ptobs[scm_numptob].end_input = end_input_default;
- scm_ptobs[scm_numptob].fill_input = fill_input;
- scm_ptobs[scm_numptob].input_waiting = 0;
+ 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].seek = 0;
- scm_ptobs[scm_numptob].truncate = 0;
+ ptobnum = scm_c_port_type_add_x (desc);
- 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_c_port_type_ref (SCM_TC2PTOBNUM (tc))->flush = 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;
}
-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 chars from port's putback and/or read buffers
- into memory starting at dest. returns the number of chars moved. */
-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 chars_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;
- chars_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;
- chars_read += from_buf;
- }
- }
- return chars_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;
@@ -525,21 +441,95 @@ 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.
+/* 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
*/
-SCM scm_i_port_weak_hash;
-scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static long
+scm_i_mode_bits_n (SCM modes)
+{
+ return (SCM_OPN
+ | (scm_i_string_contains_char (modes, 'r')
+ || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0)
+ | (scm_i_string_contains_char (modes, 'w')
+ || scm_i_string_contains_char (modes, 'a')
+ || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0)
+ | (scm_i_string_contains_char (modes, '0') ? SCM_BUF0 : 0)
+ | (scm_i_string_contains_char (modes, 'l') ? SCM_BUFLINE : 0));
+}
+
+long
+scm_mode_bits (char *modes)
+{
+ return scm_i_mode_bits (scm_from_locale_string (modes));
+}
+
+long
+scm_i_mode_bits (SCM modes)
+{
+ 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;
+}
+
+/* Return the mode flags from an open port.
+ * Some modes such as "append" are only used when opening
+ * a file and are not returned here. */
+
+SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
+ (SCM port),
+ "Return the port modes associated with the open port @var{port}.\n"
+ "These will not necessarily be identical to the modes used when\n"
+ "the port was opened, since modes such as \"append\" which are\n"
+ "used only during port creation are not retained.")
+#define FUNC_NAME s_scm_port_mode
+{
+ char modes[4];
+ modes[0] = '\0';
+
+ 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_latin1_string (modes);
+}
+#undef FUNC_NAME
+
-/* Port finalization. */
+
+/* The port table --- a weak set of all 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_set;
+
+
+/* Port finalization. */
+
static void finalize_port (GC_PTR, GC_PTR);
/* Register a finalizer for PORT. */
@@ -551,7 +541,8 @@ register_finalizer_for_port (SCM port)
/* Register a finalizer for PORT so that its iconv CDs get freed and
optionally its type's `free' function gets called. */
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port), finalize_port, 0,
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (port),
+ finalize_port, 0,
&prev_finalizer,
&prev_finalization_data);
}
@@ -560,8 +551,7 @@ register_finalizer_for_port (SCM port)
static void
finalize_port (GC_PTR ptr, GC_PTR data)
{
- long port_type;
- SCM port = PTR2SCM (ptr);
+ SCM port = SCM_PACK_POINTER (ptr);
if (!SCM_PORTP (port))
abort ();
@@ -573,16 +563,13 @@ finalize_port (GC_PTR ptr, GC_PTR data)
register_finalizer_for_port (port);
else
{
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
scm_t_port *entry;
- port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port));
- if (port_type >= scm_numptob)
- abort ();
-
- if (scm_ptobs[port_type].free)
- /* Yes, I really do mean `.free' rather than `.close'. `.close'
+ if (ptob->free)
+ /* Yes, I really do mean `free' rather than `close'. `close'
is for explicit `close-port' by user. */
- scm_ptobs[port_type].free (port);
+ ptob->free (port);
entry = SCM_PTAB_ENTRY (port);
@@ -600,73 +587,61 @@ finalize_port (GC_PTR ptr, GC_PTR data)
}
-
-/* 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_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)
{
- /*
- 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_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
- const char *enc;
+ SCM ret;
+ scm_t_port *entry;
+ scm_t_ptob_descriptor *ptob;
- entry->file_name = SCM_BOOL_F;
- entry->rw_active = SCM_PORT_NEITHER;
- entry->port = z;
+ entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
+ ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tag));
- /* Initialize this port with the thread's current default
- encoding. */
- enc = scm_i_default_port_encoding ();
- entry->encoding = enc ? scm_gc_strdup (enc, "port") : NULL;
+ 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);
+ entry->lock = scm_gc_malloc_pointerless (sizeof (*entry->lock), "port lock");
+ scm_i_pthread_mutex_init (entry->lock, scm_i_pthread_mutexattr_recursive);
+
+ entry->file_name = SCM_BOOL_F;
+ entry->rw_active = SCM_PORT_NEITHER;
+ entry->port = ret;
+ entry->stream = stream;
+ entry->encoding = encoding ? scm_gc_strdup (encoding, "port") : NULL;
/* The conversion descriptors will be opened lazily. */
entry->input_cd = (iconv_t) -1;
entry->output_cd = (iconv_t) -1;
+ entry->ilseq_handler = handler;
- entry->ilseq_handler = scm_i_get_conversion_strategy (SCM_BOOL_F);
-
- SCM_SET_CELL_TYPE (z, tag);
- SCM_SETPTAB_ENTRY (z, entry);
-
- scm_hashq_set_x (scm_i_port_weak_hash, z, SCM_BOOL_F);
+ scm_weak_set_add_x (scm_i_port_weak_set, ret);
/* For each new port, register a finalizer so that it port type's free
function can be invoked eventually. */
- register_finalizer_for_port (z);
+ register_finalizer_for_port (ret);
- return z;
+ return ret;
}
-#undef FUNC_NAME
-#if SCM_ENABLE_DEPRECATED==1
-scm_t_port *
-scm_add_to_port_table (SCM port)
+SCM
+scm_c_make_port (scm_t_bits tag, unsigned long mode_bits, scm_t_bits stream)
{
- SCM z;
- scm_t_port * pt;
-
- scm_c_issue_deprecation_warning ("scm_add_to_port_table is deprecated.");
-
- 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);
-
- return pt;
+ return scm_c_make_port_with_encoding (tag, mode_bits,
+ scm_i_default_port_encoding (),
+ scm_i_get_conversion_strategy (SCM_BOOL_F),
+ stream);
}
-#endif
+SCM
+scm_new_port_table_entry (scm_t_bits tag)
+{
+ return scm_c_make_port (tag, 0, 0);
+}
/* Remove a port from the table and destroy it. */
@@ -676,10 +651,11 @@ scm_i_remove_port (SCM port)
{
scm_t_port *p;
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
-
p = SCM_PTAB_ENTRY (port);
scm_port_non_buffer (p);
+ SCM_SETPTAB_ENTRY (port, 0);
+ scm_weak_set_remove_x (scm_i_port_weak_set, port);
+
p->putback_buf = NULL;
p->putback_buf_size = 0;
@@ -694,155 +670,72 @@ scm_i_remove_port (SCM port)
iconv_close (p->output_cd);
p->output_cd = (iconv_t) -1;
}
-
- SCM_SETPTAB_ENTRY (port, 0);
-
- scm_hashq_remove_x (scm_i_port_weak_hash, port);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
}
#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)
-{
- 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;
-}
-
-/* Revealed counts --- an oddity inherited from SCSH. */
-
-/* Find a port in the table and return its revealed count.
- Also used by the garbage collector.
- */
-
-int
-scm_revealed_count (SCM port)
-{
- return SCM_REVEALED(port);
-}
-
+/* Predicates. */
-/* Return the revealed count for a port. */
-
-SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
- (SCM port),
- "Return the revealed count for @var{port}.")
-#define FUNC_NAME s_scm_port_revealed
+SCM_DEFINE (scm_port_p, "port?", 1, 0, 0,
+ (SCM x),
+ "Return a boolean indicating whether @var{x} is a port.\n"
+ "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
+ "@var{x}))}.")
+#define FUNC_NAME s_scm_port_p
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_int (scm_revealed_count (port));
+ return scm_from_bool (SCM_PORTP (x));
}
#undef FUNC_NAME
-/* Set the revealed count for a port. */
-SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
- (SCM port, SCM rcount),
- "Sets the revealed count for a port to a given value.\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_set_port_revealed_x
+SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an input port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
+#define FUNC_NAME s_scm_input_port_p
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- SCM_REVEALED (port) = scm_to_int (rcount);
- return SCM_UNSPECIFIED;
+ return scm_from_bool (SCM_INPUT_PORT_P (x));
}
#undef FUNC_NAME
-
-
-/* Retrieving a port's mode. */
-
-/* Return the flags that characterize a port based on the mode
- * string used to open a file for that port.
- *
- * See PORT FLAGS in scm.h
- */
-
-static long
-scm_i_mode_bits_n (SCM modes)
-{
- return (SCM_OPN
- | (scm_i_string_contains_char (modes, 'r')
- || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0)
- | (scm_i_string_contains_char (modes, 'w')
- || scm_i_string_contains_char (modes, 'a')
- || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0)
- | (scm_i_string_contains_char (modes, '0') ? SCM_BUF0 : 0)
- | (scm_i_string_contains_char (modes, 'l') ? SCM_BUFLINE : 0));
-}
-
-long
-scm_mode_bits (char *modes)
+SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an output port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
+#define FUNC_NAME s_scm_output_port_p
{
- return scm_i_mode_bits (scm_from_locale_string (modes));
+ x = SCM_COERCE_OUTPORT (x);
+ return scm_from_bool (SCM_OUTPUT_PORT_P (x));
}
+#undef FUNC_NAME
-long
-scm_i_mode_bits (SCM modes)
+SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0,
+ (SCM port),
+ "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
+ "open.")
+#define FUNC_NAME s_scm_port_closed_p
{
- long bits;
-
- if (!scm_is_string (modes))
- scm_wrong_type_arg_msg (NULL, 0, modes, "string");
-
- bits = scm_i_mode_bits_n (modes);
- scm_remember_upto_here_1 (modes);
- return bits;
+ SCM_VALIDATE_PORT (1, port);
+ return scm_from_bool (!SCM_OPPORTP (port));
}
+#undef FUNC_NAME
-/* Return the mode flags from an open port.
- * Some modes such as "append" are only used when opening
- * a file and are not returned here. */
-
-SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
- (SCM port),
- "Return the port modes associated with the open port @var{port}.\n"
- "These will not necessarily be identical to the modes used when\n"
- "the port was opened, since modes such as \"append\" which are\n"
- "used only during port creation are not retained.")
-#define FUNC_NAME s_scm_port_mode
+SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
+ "return @code{#f}.")
+#define FUNC_NAME s_scm_eof_object_p
{
- char modes[4];
- modes[0] = '\0';
-
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPPORT (1, port);
- if (SCM_CELL_WORD_0 (port) & SCM_RDNG) {
- if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- strcpy (modes, "r+");
- else
- strcpy (modes, "r");
- }
- else if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- strcpy (modes, "w");
- if (SCM_CELL_WORD_0 (port) & SCM_BUF0)
- strcat (modes, "0");
- return scm_from_locale_string (modes);
+ return scm_from_bool (SCM_EOF_OBJECT_P (x));
}
#undef FUNC_NAME
+
/* Closing ports. */
/* scm_close_port
@@ -859,7 +752,6 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
"descriptors.")
#define FUNC_NAME s_scm_close_port
{
- size_t i;
int rv;
port = SCM_COERCE_OUTPORT (port);
@@ -867,9 +759,8 @@ 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);
+ if (SCM_PORT_DESCRIPTOR (port)->close)
+ rv = SCM_PORT_DESCRIPTOR (port)->close (port);
else
rv = 0;
scm_i_remove_port (port);
@@ -909,183 +800,616 @@ 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)
+
+
+
+/* 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_i_set_default_port_encoding (const char *encoding)
+{
+ 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);
+
+ if (encoding == NULL
+ || !strcmp (encoding, "ASCII")
+ || !strcmp (encoding, "ANSI_X3.4-1968")
+ || !strcmp (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_locale_string (encoding));
+}
+
+/* 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)
{
- return scm_cons (key, result);
+ if (!scm_port_encoding_init)
+ return NULL;
+ else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
+ return NULL;
+ else
+ {
+ SCM encoding;
+
+ 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);
+ }
}
void
-scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
+scm_i_set_port_encoding_x (SCM port, const char *encoding)
{
- SCM ports;
+ scm_t_port *pt;
+ iconv_t new_input_cd, new_output_cd;
+
+ new_input_cd = (iconv_t) -1;
+ new_output_cd = (iconv_t) -1;
- /* 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);
+ /* Set the character encoding for this port. */
+ pt = SCM_PTAB_ENTRY (port);
+
+ if (encoding == NULL)
+ encoding = "ISO-8859-1";
+
+ if (pt->encoding != encoding)
+ pt->encoding = scm_gc_strdup (encoding, "port");
- for (; scm_is_pair (ports); ports = scm_cdr (ports))
+ /* If ENCODING is UTF-8, then no conversion descriptor is opened
+ because we do I/O ourselves. This saves 100+ KiB for each
+ descriptor. */
+ if (strcmp (encoding, "UTF-8"))
{
- SCM p = scm_car (ports);
- if (SCM_PORTP (p))
- proc (data, p);
+ if (SCM_CELL_WORD_0 (port) & SCM_RDNG)
+ {
+ /* Open an input iconv conversion descriptor, from ENCODING
+ to UTF-8. We choose UTF-8, not UTF-32, because iconv
+ implementations can typically convert from anything to
+ UTF-8, but not to UTF-32 (see
+ <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
+ new_input_cd = iconv_open ("UTF-8", encoding);
+ if (new_input_cd == (iconv_t) -1)
+ goto invalid_encoding;
+ }
+
+ if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
+ {
+ new_output_cd = iconv_open (encoding, "UTF-8");
+ if (new_output_cd == (iconv_t) -1)
+ {
+ if (new_input_cd != (iconv_t) -1)
+ iconv_close (new_input_cd);
+ goto invalid_encoding;
+ }
+ }
}
+
+ if (pt->input_cd != (iconv_t) -1)
+ iconv_close (pt->input_cd);
+ if (pt->output_cd != (iconv_t) -1)
+ iconv_close (pt->output_cd);
+
+ pt->input_cd = new_input_cd;
+ pt->output_cd = new_output_cd;
+
+ return;
+
+ invalid_encoding:
+ {
+ SCM err;
+ err = scm_from_locale_string (encoding);
+ scm_misc_error ("scm_i_set_port_encoding_x",
+ "invalid or unknown character encoding ~s",
+ scm_list_1 (err));
+ }
}
-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 @var{port-for-each} is invoked.\n"
- "Changes to the port table while @var{port-for-each} is running\n"
- "have no effect as far as @var{port-for-each} is concerned.")
-#define FUNC_NAME s_scm_port_for_each
+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 ports;
+ scm_t_port *pt;
+ const char *enc;
- SCM_VALIDATE_PROC (1, proc);
+ SCM_VALIDATE_PORT (1, port);
- /* 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);
+ pt = SCM_PTAB_ENTRY (port);
+ enc = pt->encoding;
+ if (enc)
+ return scm_from_locale_string (pt->encoding);
+ else
+ return SCM_BOOL_F;
+}
+#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
+{
+ char *enc_str;
+
+ SCM_VALIDATE_PORT (1, port);
+ SCM_VALIDATE_STRING (2, enc);
- for (; scm_is_pair (ports); ports = scm_cdr (ports))
- if (SCM_PORTP (SCM_CAR (ports)))
- scm_call_1 (proc, SCM_CAR (ports));
+ enc_str = scm_to_locale_string (enc);
+ scm_i_set_port_encoding_x (port, enc_str);
+ free (enc_str);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-
-/* Utter miscellany. Gosh, we should clean this up some time. */
+/* This determines how conversions handle unconvertible characters. */
+SCM_GLOBAL_VARIABLE (scm_conversion_strategy, "%port-conversion-strategy");
+static int scm_conversion_strategy_init = 0;
-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
+scm_t_string_failed_conversion_handler
+scm_i_get_conversion_strategy (SCM port)
{
- return scm_from_bool (SCM_INPUT_PORT_P (x));
+ SCM encoding;
+
+ if (scm_is_false (port))
+ {
+ if (!scm_conversion_strategy_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
+ return SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else
+ {
+ encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy));
+ if (scm_is_false (encoding))
+ return SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else
+ return (scm_t_string_failed_conversion_handler) scm_to_int (encoding);
+ }
+ }
+ else
+ {
+ scm_t_port *pt;
+ pt = SCM_PTAB_ENTRY (port);
+ return pt->ilseq_handler;
+ }
+
+}
+
+void
+scm_i_set_conversion_strategy_x (SCM port,
+ scm_t_string_failed_conversion_handler handler)
+{
+ SCM strategy;
+ scm_t_port *pt;
+
+ strategy = scm_from_int ((int) handler);
+
+ if (scm_is_false (port))
+ {
+ /* Set the default encoding for future ports. */
+ if (!scm_conversion_strategy_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
+ scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
+ SCM_EOL);
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), strategy);
+ }
+ else
+ {
+ /* Set the character encoding for this port. */
+ pt = SCM_PTAB_ENTRY (port);
+ pt->ilseq_handler = handler;
+ }
+}
+
+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_VALIDATE_OPPORT (1, port);
+
+ if (!scm_is_false (port))
+ {
+ SCM_VALIDATE_OPPORT (1, port);
+ }
+
+ h = scm_i_get_conversion_strategy (port);
+ 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
-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
+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
{
- x = SCM_COERCE_OUTPORT (x);
- return scm_from_bool (SCM_OUTPUT_PORT_P (x));
+ SCM err;
+ SCM qm;
+ SCM esc;
+
+ if (!scm_is_false (port))
+ {
+ SCM_VALIDATE_OPPORT (1, port);
+ }
+
+ err = scm_from_latin1_symbol ("error");
+ if (scm_is_true (scm_eqv_p (sym, err)))
+ {
+ scm_i_set_conversion_strategy_x (port, SCM_FAILED_CONVERSION_ERROR);
+ return SCM_UNSPECIFIED;
+ }
+
+ qm = scm_from_latin1_symbol ("substitute");
+ if (scm_is_true (scm_eqv_p (sym, qm)))
+ {
+ scm_i_set_conversion_strategy_x (port,
+ SCM_FAILED_CONVERSION_QUESTION_MARK);
+ return SCM_UNSPECIFIED;
+ }
+
+ esc = scm_from_latin1_symbol ("escape");
+ if (scm_is_true (scm_eqv_p (sym, esc)))
+ {
+ scm_i_set_conversion_strategy_x (port,
+ SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
+ return SCM_UNSPECIFIED;
+ }
+
+ SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym));
+
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-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
+
+
+
+/* The port lock. */
+
+static void
+lock_port (void *mutex)
{
- return scm_from_bool (SCM_PORTP (x));
+ scm_i_pthread_mutex_lock (mutex);
+}
+
+static void
+unlock_port (void *mutex)
+{
+ scm_i_pthread_mutex_unlock (mutex);
+}
+
+void
+scm_dynwind_lock_port (SCM port)
+#define FUNC_NAME "dynwind-lock-port"
+{
+ scm_i_pthread_mutex_t *lock;
+ SCM_VALIDATE_OPPORT (SCM_ARG1, port);
+ scm_c_lock_port (port, &lock);
+ if (lock)
+ {
+ scm_dynwind_unwind_handler (unlock_port, lock, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_rewind_handler (lock_port, lock, 0);
+ }
}
#undef FUNC_NAME
-SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0,
+
+
+
+/* Revealed counts --- an oddity inherited from SCSH. */
+
+/* Find a port in the table and return its revealed count.
+ Also used by the garbage collector.
+ */
+int
+scm_revealed_count (SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ int ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = SCM_REVEALED (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+ return ret;
+}
+
+SCM_DEFINE (scm_port_revealed, "port-revealed", 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
+ "Return the revealed count for @var{port}.")
+#define FUNC_NAME s_scm_port_revealed
{
- SCM_VALIDATE_PORT (1, port);
- return scm_from_bool (!SCM_OPPORTP (port));
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return scm_from_int (scm_revealed_count (port));
}
#undef FUNC_NAME
-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
+/* 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
{
- return scm_from_bool(SCM_EOF_OBJECT_P (x));
+ int r;
+ scm_i_pthread_mutex_t *lock;
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ r = scm_to_int (rcount);
+ scm_c_lock_port (port, &lock);
+ SCM_REVEALED (port) = r;
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+ return SCM_UNSPECIFIED;
}
#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"
+/* 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_force_output
+#define FUNC_NAME s_scm_adjust_port_revealed_x
{
- if (SCM_UNBNDP (port))
- port = scm_current_output_port ();
- else
- {
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPOUTPORT (1, port);
- }
- scm_flush (port);
+ scm_i_pthread_mutex_t *lock;
+ int a;
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ a = scm_to_int (addend);
+ scm_c_lock_port (port, &lock);
+ SCM_REVEALED (port) += a;
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-static void
-flush_output_port (void *closure, SCM port)
+
+
+/* Input. */
+
+int
+scm_get_byte_or_eof (SCM port)
{
- if (SCM_OPOUTPORTP (port))
- scm_flush (port);
+ scm_i_pthread_mutex_t *lock;
+ int ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_get_byte_or_eof_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+ return ret;
}
-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
+int
+scm_peek_byte_or_eof (SCM port)
{
- scm_c_port_for_each (&flush_output_port, NULL);
- return SCM_UNSPECIFIED;
+ scm_i_pthread_mutex_t *lock;
+ int ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_peek_byte_or_eof_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+ return ret;
}
-#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
+/* scm_c_read
+ *
+ * Used by an application to read arbitrary number of bytes from an
+ * SCM port. Same semantics as libc read, except that scm_c_read only
+ * returns less than SIZE bytes if at end-of-file.
+ *
+ * Warning: Doesn't update port line and column counts! */
+
+/* This structure, and the following swap_buffer function, are used
+ for temporarily swapping a port's own read buffer, and the buffer
+ that the caller of scm_c_read provides. */
+struct port_and_swap_buffer
{
- scm_t_wchar c;
- if (SCM_UNBNDP (port))
- port = scm_current_input_port ();
+ scm_t_port *pt;
+ unsigned char *buffer;
+ size_t size;
+};
+
+static void
+swap_buffer (void *data)
+{
+ struct port_and_swap_buffer *psb = (struct port_and_swap_buffer *) data;
+ unsigned char *old_buf = psb->pt->read_buf;
+ size_t old_size = psb->pt->read_buf_size;
+
+ /* Make the port use (buffer, size) from the struct. */
+ psb->pt->read_pos = psb->pt->read_buf = psb->pt->read_end = psb->buffer;
+ psb->pt->read_buf_size = psb->size;
+
+ /* Save the port's old (buffer, size) in the struct. */
+ psb->buffer = old_buf;
+ psb->size = old_size;
+}
+
+size_t
+scm_c_read_unlocked (SCM port, void *buffer, size_t size)
+#define FUNC_NAME "scm_c_read"
+{
+ scm_t_port *pt;
+ size_t n_read = 0, n_available;
+ struct port_and_swap_buffer psb;
+
SCM_VALIDATE_OPINPORT (1, port);
- c = scm_getc (port);
- if (EOF == c)
- return SCM_EOF_VAL;
- return SCM_MAKE_CHAR (c);
+
+ pt = SCM_PTAB_ENTRY (port);
+ if (pt->rw_active == SCM_PORT_WRITE)
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ /* Take bytes first from the port's read buffer. */
+ if (pt->read_pos < pt->read_end)
+ {
+ n_available = min (size, pt->read_end - pt->read_pos);
+ memcpy (buffer, pt->read_pos, n_available);
+ buffer = (char *) buffer + n_available;
+ pt->read_pos += n_available;
+ n_read += n_available;
+ size -= n_available;
+ }
+
+ /* Avoid the scm_dynwind_* costs if we now have enough data. */
+ if (size == 0)
+ return n_read;
+
+ /* Now we will call scm_fill_input repeatedly until we have read the
+ requested number of bytes. (Note that a single scm_fill_input
+ call does not guarantee to fill the whole of the port's read
+ buffer.) */
+ if (pt->read_buf_size <= 1 && pt->encoding == NULL)
+ {
+ /* The port that we are reading from is unbuffered - i.e. does
+ not have its own persistent buffer - but we have a buffer,
+ provided by our caller, that is the right size for the data
+ that is wanted. For the following scm_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_fill_input () calls
+ throws an exception; we use the scm_dynwind_* API to achieve
+ that.
+
+ A consequence of this optimization is that the fill_input
+ functions can't unget characters. That'll push data to the
+ pushback buffer instead of this psb buffer. */
+#if SCM_DEBUG == 1
+ unsigned char *pback = pt->putback_buf;
+#endif
+ psb.pt = pt;
+ psb.buffer = buffer;
+ psb.size = size;
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
+
+ /* Call scm_fill_input until we have all the bytes that we need,
+ or we hit EOF. */
+ while (pt->read_buf_size && (scm_fill_input_unlocked (port) != EOF))
+ {
+ pt->read_buf_size -= (pt->read_end - pt->read_pos);
+ pt->read_pos = pt->read_buf = pt->read_end;
+ }
+#if SCM_DEBUG == 1
+ if (pback != pt->putback_buf
+ || pt->read_buf - (unsigned char *) buffer < 0)
+ scm_misc_error (FUNC_NAME,
+ "scm_c_read must not call a fill function that pushes "
+ "back characters onto an unbuffered port", SCM_EOL);
+#endif
+ n_read += pt->read_buf - (unsigned char *) buffer;
+
+ /* Reinstate the port's normal buffer. */
+ scm_dynwind_end ();
+ }
+ else
+ {
+ /* The port has its own buffer. It is important that we use it,
+ even if it happens to be smaller than our caller's buffer, so
+ that a custom port implementation's entry points (in
+ particular, fill_input) can rely on the buffer always being
+ the same as they first set up. */
+ while (size && (scm_fill_input_unlocked (port) != EOF))
+ {
+ n_available = min (size, pt->read_end - pt->read_pos);
+ memcpy (buffer, pt->read_pos, n_available);
+ buffer = (char *) buffer + n_available;
+ pt->read_pos += n_available;
+ n_read += n_available;
+ size -= n_available;
+ }
+ }
+
+ return n_read;
}
#undef FUNC_NAME
+size_t
+scm_c_read (SCM port, void *buffer, size_t size)
+{
+ scm_i_pthread_mutex_t *lock;
+ size_t ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_c_read_unlocked (port, buffer, size);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+
+ return ret;
+}
+
/* Update the line and column number of PORT after consumption of C. */
static inline void
update_port_lf (scm_t_wchar c, SCM port)
@@ -1172,7 +1496,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
*len = 0;
pt = SCM_PTAB_ENTRY (port);
- byte = scm_get_byte_or_eof (port);
+ byte = scm_get_byte_or_eof_unlocked (port);
if (byte == EOF)
{
*codepoint = EOF;
@@ -1188,7 +1512,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
else if (buf[0] >= 0xc2 && buf[0] <= 0xdf)
{
/* 2-byte form. */
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
@@ -1204,7 +1528,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
else if ((buf[0] & 0xf0) == 0xe0)
{
/* 3-byte form. */
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY ((byte & 0xc0) != 0x80
@@ -1216,7 +1540,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
buf[1] = (scm_t_uint8) byte;
*len = 2;
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
@@ -1233,7 +1557,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
else if (buf[0] >= 0xf0 && buf[0] <= 0xf4)
{
/* 4-byte form. */
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY (((byte & 0xc0) != 0x80)
@@ -1245,7 +1569,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
buf[1] = (scm_t_uint8) byte;
*len = 2;
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
@@ -1255,7 +1579,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint,
buf[2] = (scm_t_uint8) byte;
*len = 3;
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
@@ -1310,7 +1634,7 @@ get_iconv_codepoint (SCM port, scm_t_wchar *codepoint,
char *input;
size_t input_left, output_left, done;
- byte_read = scm_get_byte_or_eof (port);
+ byte_read = scm_get_byte_or_eof_unlocked (port);
if (byte_read == EOF)
{
if (bytes_consumed == 0)
@@ -1390,7 +1714,7 @@ get_codepoint (SCM port, scm_t_wchar *codepoint,
/* Read a codepoint from PORT and return it. */
scm_t_wchar
-scm_getc (SCM port)
+scm_getc_unlocked (SCM port)
#define FUNC_NAME "scm_getc"
{
int err;
@@ -1408,274 +1732,50 @@ scm_getc (SCM port)
}
#undef FUNC_NAME
-/* 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). */
-int
-scm_fill_input (SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- assert (pt->read_pos == pt->read_end);
-
- 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_ptobs[SCM_PTOBNUM (port)].fill_input (port);
-}
-
-
-/* scm_lfwrite
- *
- * 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_display (scm_c_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! */
-
-/* This structure, and the following swap_buffer function, are used
- for temporarily swapping a port's own read buffer, and the buffer
- that the caller of scm_c_read provides. */
-struct port_and_swap_buffer
-{
- scm_t_port *pt;
- unsigned char *buffer;
- size_t size;
-};
-
-static void
-swap_buffer (void *data)
+scm_t_wchar
+scm_getc (SCM port)
{
- struct port_and_swap_buffer *psb = (struct port_and_swap_buffer *) data;
- unsigned char *old_buf = psb->pt->read_buf;
- size_t old_size = psb->pt->read_buf_size;
+ scm_i_pthread_mutex_t *lock;
+ scm_t_wchar ret;
- /* Make the port use (buffer, size) from the struct. */
- psb->pt->read_pos = psb->pt->read_buf = psb->pt->read_end = psb->buffer;
- psb->pt->read_buf_size = psb->size;
+ scm_c_lock_port (port, &lock);
+ ret = scm_getc_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
- /* Save the port's old (buffer, size) in the struct. */
- psb->buffer = old_buf;
- psb->size = old_size;
+ return ret;
}
-size_t
-scm_c_read (SCM port, void *buffer, size_t size)
-#define FUNC_NAME "scm_c_read"
+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_port *pt;
- size_t n_read = 0, n_available;
- struct port_and_swap_buffer psb;
-
+ scm_t_wchar c;
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
SCM_VALIDATE_OPINPORT (1, port);
-
- pt = SCM_PTAB_ENTRY (port);
- if (pt->rw_active == SCM_PORT_WRITE)
- scm_ptobs[SCM_PTOBNUM (port)].flush (port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
-
- /* Take bytes first from the port's read buffer. */
- if (pt->read_pos < pt->read_end)
- {
- n_available = min (size, pt->read_end - pt->read_pos);
- memcpy (buffer, pt->read_pos, n_available);
- buffer = (char *) buffer + n_available;
- pt->read_pos += n_available;
- n_read += n_available;
- size -= n_available;
- }
-
- /* Avoid the scm_dynwind_* costs if we now have enough data. */
- if (size == 0)
- return n_read;
-
- /* Now we will call scm_fill_input repeatedly until we have read the
- requested number of bytes. (Note that a single scm_fill_input
- call does not guarantee to fill the whole of the port's read
- buffer.) */
- if (pt->read_buf_size <= 1 && pt->encoding == NULL)
- {
- /* The port that we are reading from is unbuffered - i.e. does
- not have its own persistent buffer - but we have a buffer,
- provided by our caller, that is the right size for the data
- that is wanted. For the following scm_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_fill_input () calls
- throws an exception; we use the scm_dynwind_* API to achieve
- that.
-
- A consequence of this optimization is that the fill_input
- functions can't unget characters. That'll push data to the
- pushback buffer instead of this psb buffer. */
-#if SCM_DEBUG == 1
- unsigned char *pback = pt->putback_buf;
-#endif
- psb.pt = pt;
- psb.buffer = buffer;
- psb.size = size;
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
-
- /* Call scm_fill_input until we have all the bytes that we need,
- or we hit EOF. */
- while (pt->read_buf_size && (scm_fill_input (port) != EOF))
- {
- pt->read_buf_size -= (pt->read_end - pt->read_pos);
- pt->read_pos = pt->read_buf = pt->read_end;
- }
-#if SCM_DEBUG == 1
- if (pback != pt->putback_buf
- || pt->read_buf - (unsigned char *) buffer < 0)
- scm_misc_error (FUNC_NAME,
- "scm_c_read must not call a fill function that pushes "
- "back characters onto an unbuffered port", SCM_EOL);
-#endif
- n_read += pt->read_buf - (unsigned char *) buffer;
-
- /* Reinstate the port's normal buffer. */
- scm_dynwind_end ();
- }
- else
- {
- /* The port has its own buffer. It is important that we use it,
- even if it happens to be smaller than our caller's buffer, so
- that a custom port implementation's entry points (in
- particular, fill_input) can rely on the buffer always being
- the same as they first set up. */
- while (size && (scm_fill_input (port) != EOF))
- {
- n_available = min (size, pt->read_end - pt->read_pos);
- memcpy (buffer, pt->read_pos, n_available);
- buffer = (char *) buffer + n_available;
- pt->read_pos += n_available;
- n_read += n_available;
- size -= n_available;
- }
- }
-
- return n_read;
-}
-#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"
-{
- 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);
-
- ptob->write (port, ptr, size);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
+ c = scm_getc_unlocked (port);
+ if (EOF == c)
+ return SCM_EOF_VAL;
+ return SCM_MAKE_CHAR (c);
}
#undef FUNC_NAME
-void
-scm_flush (SCM port)
-{
- long i = SCM_PTOBNUM (port);
- assert (i >= 0);
- (scm_ptobs[i].flush) (port);
-}
-
-void
-scm_end_input (SCM port)
-{
- long offset;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (pt->read_buf == pt->putback_buf)
- {
- offset = pt->read_end - pt->read_pos;
- pt->read_buf = pt->saved_read_buf;
- pt->read_pos = pt->saved_read_pos;
- pt->read_end = pt->saved_read_end;
- pt->read_buf_size = pt->saved_read_buf_size;
- }
- else
- offset = 0;
-
- scm_ptobs[SCM_PTOBNUM (port)].end_input (port, offset);
-}
+/* Pushback. */
void
-scm_unget_byte (int c, SCM port)
+scm_unget_byte_unlocked (int c, SCM port)
#define FUNC_NAME "scm_unget_byte"
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -1738,8 +1838,19 @@ scm_unget_byte (int c, SCM port)
}
#undef FUNC_NAME
+void
+scm_unget_byte (int c, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_unget_byte_unlocked (c, 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);
@@ -1766,7 +1877,7 @@ scm_ungetc (scm_t_wchar c, SCM port)
SCM_BOOL_F, SCM_MAKE_CHAR (c));
for (i = len - 1; i >= 0; i--)
- scm_unget_byte (result[i], port);
+ scm_unget_byte_unlocked (result[i], port);
if (SCM_UNLIKELY (result != result_buf))
free (result);
@@ -1783,9 +1894,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
@@ -1794,9 +1915,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),
@@ -1838,7 +1969,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
err = get_codepoint (port, &c, bytes, &len);
for (i = len - 1; i >= 0; i--)
- scm_unget_byte (bytes[i], port);
+ scm_unget_byte_unlocked (bytes[i], port);
SCM_COL (port) = column;
SCM_LINUM (port) = line;
@@ -1876,7 +2007,7 @@ SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0,
c = SCM_CHAR (cobj);
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return cobj;
}
#undef FUNC_NAME
@@ -1898,12 +2029,382 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0,
n = scm_i_string_length (str);
while (n--)
- scm_ungetc (scm_i_string_ref (str, n), port);
+ scm_ungetc_unlocked (scm_i_string_ref (str, n), port);
return str;
}
#undef FUNC_NAME
+
+
+
+/* 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)
+{
+ 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;
+}
+
+/* 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). */
+int
+scm_fill_input_unlocked (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ assert (pt->read_pos == pt->read_end);
+
+ 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);
+}
+
+int
+scm_fill_input (SCM 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;
+}
+
+/* move up to read_len chars from port's putback and/or read buffers
+ into memory starting at dest. returns the number of chars moved. */
+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 chars_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;
+ chars_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;
+ chars_read += from_buf;
+ }
+ }
+ return chars_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
+
+void
+scm_end_input_unlocked (SCM port)
+{
+ long offset;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->read_buf == pt->putback_buf)
+ {
+ offset = pt->read_end - pt->read_pos;
+ pt->read_buf = pt->saved_read_buf;
+ pt->read_pos = pt->saved_read_pos;
+ pt->read_end = pt->saved_read_end;
+ pt->read_buf_size = pt->saved_read_buf_size;
+ }
+ else
+ offset = 0;
+
+ SCM_PORT_DESCRIPTOR (port)->end_input (port, offset);
+}
+
+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);
+
+}
+
+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 (SCM_UNBNDP (port))
+ port = scm_current_output_port ();
+ else
+ {
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ }
+ scm_flush_unlocked (port);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_flush_unlocked (SCM port)
+{
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
+}
+
+void
+scm_flush (SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_flush_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
+
+
+
+
+/* Output. */
+
+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);
+
+}
+
+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;
+
+ SCM_VALIDATE_OPOUTPORT (1, port);
+
+ pt = SCM_PTAB_ENTRY (port);
+ ptob = SCM_PORT_DESCRIPTOR (port);
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (port);
+
+ ptob->write (port, ptr, size);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
+}
+#undef FUNC_NAME
+
+void
+scm_c_write (SCM port, const void *ptr, size_t size)
+{
+ 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);
+
+}
+
+/* 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 *pt = SCM_PTAB_ENTRY (port);
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (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;
+}
+
+void
+scm_lfwrite (const char *ptr, size_t size, SCM port)
+{
+ 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);
+
+}
+
+/* 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_unlocked (port);
+
+ if (end == (size_t) -1)
+ end = scm_i_string_length (str);
+
+ scm_display (scm_c_substring (str, start, end), port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
+}
+
+
+
+
+/* Querying and setting positions, and character availability. */
+
+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_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_seek, "seek", 3, 0, 0,
(SCM fd_port, SCM offset, SCM whence),
"Sets the current position of @var{fd/port} to the integer\n"
@@ -1941,7 +2442,7 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
if (SCM_OPPORTP (fd_port))
{
- scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (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;
@@ -2036,12 +2537,12 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
{
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);
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (object);
if (!ptob->truncate)
SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (object);
+ scm_end_input_unlocked (object);
else if (pt->rw_active == SCM_PORT_WRITE)
ptob->flush (object);
@@ -2152,349 +2653,116 @@ SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
}
#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");
-
-static int scm_port_encoding_init = 0;
-
-/* Use ENCODING as the default encoding for future ports. */
-void
-scm_i_set_default_port_encoding (const char *encoding)
-{
- 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);
-
- if (encoding == NULL
- || !strcmp (encoding, "ASCII")
- || !strcmp (encoding, "ANSI_X3.4-1968")
- || !strcmp (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_locale_string (encoding));
-}
-/* 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)
-{
- if (!scm_port_encoding_init)
- return NULL;
- else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
- return NULL;
- else
- {
- SCM encoding;
+
- 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);
- }
-}
+/* Implementation helpers for port printing functions. */
void
-scm_i_set_port_encoding_x (SCM port, const char *encoding)
+scm_print_port_mode (SCM exp, SCM port)
{
- scm_t_port *pt;
- iconv_t new_input_cd, new_output_cd;
-
- new_input_cd = (iconv_t) -1;
- new_output_cd = (iconv_t) -1;
-
- /* Set the character encoding for this port. */
- pt = SCM_PTAB_ENTRY (port);
-
- if (encoding == NULL)
- encoding = "ISO-8859-1";
-
- if (pt->encoding != encoding)
- pt->encoding = scm_gc_strdup (encoding, "port");
-
- /* If ENCODING is UTF-8, then no conversion descriptor is opened
- because we do I/O ourselves. This saves 100+ KiB for each
- descriptor. */
- if (strcmp (encoding, "UTF-8"))
- {
- if (SCM_CELL_WORD_0 (port) & SCM_RDNG)
- {
- /* Open an input iconv conversion descriptor, from ENCODING
- to UTF-8. We choose UTF-8, not UTF-32, because iconv
- implementations can typically convert from anything to
- UTF-8, but not to UTF-32 (see
- <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
- new_input_cd = iconv_open ("UTF-8", encoding);
- if (new_input_cd == (iconv_t) -1)
- goto invalid_encoding;
- }
-
- if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- {
- new_output_cd = iconv_open (encoding, "UTF-8");
- if (new_output_cd == (iconv_t) -1)
- {
- if (new_input_cd != (iconv_t) -1)
- iconv_close (new_input_cd);
- goto invalid_encoding;
- }
- }
- }
-
- if (pt->input_cd != (iconv_t) -1)
- iconv_close (pt->input_cd);
- if (pt->output_cd != (iconv_t) -1)
- iconv_close (pt->output_cd);
-
- pt->input_cd = new_input_cd;
- pt->output_cd = new_output_cd;
-
- return;
-
- invalid_encoding:
- {
- SCM err;
- err = scm_from_locale_string (encoding);
- scm_misc_error ("scm_i_set_port_encoding_x",
- "invalid or unknown character encoding ~s",
- scm_list_1 (err));
- }
+ scm_puts_unlocked (SCM_CLOSEDP (exp)
+ ? "closed: "
+ : (SCM_RDNG & SCM_CELL_WORD_0 (exp)
+ ? (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
+ ? "input-output: "
+ : "input: ")
+ : (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
+ ? "output: "
+ : "bogus: ")),
+ port);
}
-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
+int
+scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_t_port *pt;
- const char *enc;
-
- SCM_VALIDATE_PORT (1, port);
-
- pt = SCM_PTAB_ENTRY (port);
- enc = pt->encoding;
- if (enc)
- return scm_from_locale_string (pt->encoding);
- else
- return SCM_BOOL_F;
+ char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp));
+ if (!type)
+ type = "port";
+ scm_puts_unlocked ("#<", port);
+ scm_print_port_mode (exp, port);
+ scm_puts_unlocked (type, port);
+ scm_putc_unlocked (' ', port);
+ scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
+ scm_putc_unlocked ('>', port);
+ return 1;
}
-#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
-{
- char *enc_str;
- SCM_VALIDATE_PORT (1, port);
- SCM_VALIDATE_STRING (2, enc);
- enc_str = scm_to_locale_string (enc);
- scm_i_set_port_encoding_x (port, enc_str);
- free (enc_str);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
+
+/* Iterating over all ports. */
-/* This determines how conversions handle unconvertible characters. */
-SCM_GLOBAL_VARIABLE (scm_conversion_strategy, "%port-conversion-strategy");
-static int scm_conversion_strategy_init = 0;
+struct for_each_data
+{
+ void (*proc) (void *data, SCM p);
+ void *data;
+};
-scm_t_string_failed_conversion_handler
-scm_i_get_conversion_strategy (SCM port)
+static SCM
+for_each_trampoline (void *data, SCM port, SCM result)
{
- SCM encoding;
+ struct for_each_data *d = data;
- if (scm_is_false (port))
- {
- if (!scm_conversion_strategy_init
- || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
- return SCM_FAILED_CONVERSION_QUESTION_MARK;
- else
- {
- encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy));
- if (scm_is_false (encoding))
- return SCM_FAILED_CONVERSION_QUESTION_MARK;
- else
- return (scm_t_string_failed_conversion_handler) scm_to_int (encoding);
- }
- }
- else
- {
- scm_t_port *pt;
- pt = SCM_PTAB_ENTRY (port);
- return pt->ilseq_handler;
- }
-
+ d->proc (d->data, port);
+
+ return result;
}
void
-scm_i_set_conversion_strategy_x (SCM port,
- scm_t_string_failed_conversion_handler handler)
+scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
{
- SCM strategy;
- scm_t_port *pt;
-
- strategy = scm_from_int ((int) handler);
+ struct for_each_data d;
- if (scm_is_false (port))
- {
- /* Set the default encoding for future ports. */
- if (!scm_conversion_strategy_init
- || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
- scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
- SCM_EOL);
- scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), strategy);
- }
- else
- {
- /* Set the character encoding for this port. */
- pt = SCM_PTAB_ENTRY (port);
- pt->ilseq_handler = handler;
- }
+ d.proc = proc;
+ d.data = data;
+
+ scm_c_weak_set_fold (for_each_trampoline, &d, SCM_EOL,
+ scm_i_port_weak_set);
}
-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
+static void
+scm_for_each_trampoline (void *data, SCM port)
{
- scm_t_string_failed_conversion_handler h;
-
- SCM_VALIDATE_OPPORT (1, port);
-
- if (!scm_is_false (port))
- {
- SCM_VALIDATE_OPPORT (1, port);
- }
-
- h = scm_i_get_conversion_strategy (port);
- 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;
+ scm_call_1 (SCM_PACK_POINTER (data), port);
}
-#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_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 @var{port-for-each} is invoked.\n"
+ "Changes to the port table while @var{port-for-each} is running\n"
+ "have no effect as far as @var{port-for-each} is concerned.")
+#define FUNC_NAME s_scm_port_for_each
{
- SCM err;
- SCM qm;
- SCM esc;
-
- if (!scm_is_false (port))
- {
- SCM_VALIDATE_OPPORT (1, port);
- }
-
- err = scm_from_latin1_symbol ("error");
- if (scm_is_true (scm_eqv_p (sym, err)))
- {
- scm_i_set_conversion_strategy_x (port, SCM_FAILED_CONVERSION_ERROR);
- return SCM_UNSPECIFIED;
- }
-
- qm = scm_from_latin1_symbol ("substitute");
- if (scm_is_true (scm_eqv_p (sym, qm)))
- {
- scm_i_set_conversion_strategy_x (port,
- SCM_FAILED_CONVERSION_QUESTION_MARK);
- return SCM_UNSPECIFIED;
- }
-
- esc = scm_from_latin1_symbol ("escape");
- if (scm_is_true (scm_eqv_p (sym, esc)))
- {
- scm_i_set_conversion_strategy_x (port,
- SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
- return SCM_UNSPECIFIED;
- }
-
- SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym));
+ SCM_VALIDATE_PROC (1, proc);
+ scm_c_port_for_each (scm_for_each_trampoline, SCM_UNPACK_POINTER (proc));
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-
-
-void
-scm_print_port_mode (SCM exp, SCM port)
+static void
+flush_output_port (void *closure, SCM port)
{
- scm_puts (SCM_CLOSEDP (exp)
- ? "closed: "
- : (SCM_RDNG & SCM_CELL_WORD_0 (exp)
- ? (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
- ? "input-output: "
- : "input: ")
- : (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
- ? "output: "
- : "bogus: ")),
- port);
+ if (SCM_OPOUTPORTP (port))
+ scm_flush_unlocked (port);
}
-int
-scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+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
{
- char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp));
- if (!type)
- type = "port";
- scm_puts ("#<", port);
- scm_print_port_mode (exp, port);
- scm_puts (type, port);
- scm_putc (' ', port);
- scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
- scm_putc ('>', port);
- return 1;
+ scm_c_port_for_each (&flush_output_port, NULL);
+ return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
+
@@ -2517,18 +2785,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;
+
+ ret = scm_c_make_port (scm_tc16_void_port, mode_bits, 0);
- scm_port_non_buffer (pt);
+ 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
@@ -2549,7 +2812,9 @@ SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0,
}
#undef FUNC_NAME
+
+
/* Initialization. */
void
@@ -2568,7 +2833,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 fcf1424cc..f4a1908e0 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -26,7 +26,12 @@
#include "libguile/__scm.h"
+#include <stdio.h>
+#include <string.h>
#include <unistd.h>
+#include "libguile/gc.h"
+#include "libguile/tags.h"
+#include "libguile/error.h"
#include "libguile/print.h"
#include "libguile/struct.h"
#include "libguile/threads.h"
@@ -48,6 +53,8 @@ typedef enum scm_t_port_rw_active {
typedef struct
{
SCM port; /* Link back to the port object. */
+ scm_i_pthread_mutex_t *lock; /* A recursive lock for this port. */
+
int revealed; /* 0 not revealed, > 1 revealed.
* Revealed ports do not get GC'd.
*/
@@ -118,8 +125,7 @@ typedef struct
} 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)
@@ -139,22 +145,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))
@@ -201,19 +204,12 @@ typedef struct 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,
@@ -228,11 +224,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,
@@ -241,9 +236,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);
-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);
@@ -256,44 +250,108 @@ 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 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_get_conversion_strategy (SCM port);
+SCM_INTERNAL void scm_i_set_conversion_strategy_x (SCM port,
+ scm_t_string_failed_conversion_handler h);
+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);
+
+/* 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);
+
+/* 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_peek_byte_or_eof (SCM port);
+SCM_INLINE int scm_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_INTERNAL void scm_unget_byte (int c, SCM port);
+SCM_INTERNAL 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);
@@ -302,36 +360,116 @@ 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);
-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_get_conversion_strategy (SCM port);
-SCM_INTERNAL void scm_i_set_conversion_strategy_x (SCM port,
- scm_t_string_failed_conversion_handler h);
-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)
+{
+ int c;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ /* may be marginally faster than calling scm_flush. */
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ if (pt->read_pos >= pt->read_end)
+ {
+ if (SCM_UNLIKELY (scm_fill_input_unlocked (port) == EOF))
+ return EOF;
+ }
+
+ c = *(pt->read_pos++);
+
+ return c;
+}
+
+/* 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)
+{
+ int c;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ /* may be marginally faster than calling scm_flush. */
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ if (pt->read_pos >= pt->read_end)
+ {
+ if (SCM_UNLIKELY (scm_fill_input_unlocked (port) == EOF))
+ return EOF;
+ }
+
+ c = *pt->read_pos;
+
+ return c;
+}
+
+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/print.c b/libguile/print.c
index 2eda4bbd4..b800362c1 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -40,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"
@@ -158,7 +157,7 @@ do \
{ \
if (pstate->top - pstate->list_offset >= pstate->level) \
{ \
- scm_putc ('#', port); \
+ scm_putc_unlocked ('#', port); \
return; \
} \
} \
@@ -302,9 +301,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. */
@@ -395,7 +394,7 @@ print_extended_symbol (SCM sym, SCM port)
len = scm_i_symbol_length (sym);
strategy = scm_i_get_conversion_strategy (port);
- scm_lfwrite ("#{", 2, port);
+ scm_lfwrite_unlocked ("#{", 2, port);
for (pos = 0; pos < len; pos++)
{
@@ -418,7 +417,7 @@ print_extended_symbol (SCM sym, SCM port)
}
}
- scm_lfwrite ("}#", 2, port);
+ scm_lfwrite_unlocked ("}#", 2, port);
}
/* FIXME: allow R6RS hex escapes instead of #{...}#. */
@@ -434,7 +433,7 @@ 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 symbol = scm_from_utf8_symboln (str, len);
scm_i_print_symbol_name (symbol, port);
}
@@ -454,7 +453,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); \
} \
} \
@@ -509,7 +508,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
{
@@ -530,7 +529,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
{
@@ -603,11 +602,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
}
else
{
- scm_puts ("#<uninterned-symbol ", port);
+ scm_puts_unlocked ("#<uninterned-symbol ", port);
scm_i_print_symbol_name (exp, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
break;
case scm_tc7_variable:
@@ -622,6 +621,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;
@@ -659,14 +664,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;
@@ -678,43 +680,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;
}
@@ -859,7 +844,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;
}
@@ -920,7 +905,7 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len,
iconv (pt->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. */
@@ -955,7 +940,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;
}
@@ -1035,7 +1020,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)
{
@@ -1045,7 +1030,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)
{
@@ -1055,7 +1040,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)
{
@@ -1067,7 +1052,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
@@ -1090,7 +1075,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
@@ -1100,7 +1085,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);
}
@@ -1171,14 +1156,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.
@@ -1187,19 +1172,19 @@ scm_uintprint (scm_t_uintmax n, int radix, SCM port)
void
scm_ipruk (char *hdr, SCM ptr, SCM port)
{
- scm_puts ("#<unknown-", port);
- scm_puts (hdr, port);
+ scm_puts_unlocked ("#<unknown-", port);
+ scm_puts_unlocked (hdr, port);
if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
{
- scm_puts (" (0x", port);
+ scm_puts_unlocked (" (0x", port);
scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
- scm_puts (" . 0x", port);
+ scm_puts_unlocked (" . 0x", port);
scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
- scm_puts (") @", port);
+ scm_puts_unlocked (") @", port);
}
- scm_puts (" 0x", port);
+ scm_puts_unlocked (" 0x", port);
scm_uintprint (SCM_UNPACK (ptr), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
@@ -1210,7 +1195,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;
@@ -1240,18 +1225,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;
@@ -1272,7 +1257,7 @@ fancy_printing:
{
if (n == 0)
{
- scm_puts (" ...", port);
+ scm_puts_unlocked (" ...", port);
goto skip_tail;
}
else
@@ -1280,14 +1265,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:
@@ -1298,7 +1283,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;
}
@@ -1323,7 +1308,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;
}
@@ -1338,7 +1327,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;
}
@@ -1451,7 +1444,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
@@ -1496,7 +1489,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
@@ -1541,14 +1534,10 @@ SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0,
void
scm_init_print ()
{
- SCM vtable, layout, type;
-
- scm_gc_register_root (&print_state_pool);
- scm_gc_register_root (&scm_print_state_vtable);
- vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
- layout =
- scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT));
- type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout));
+ SCM type;
+
+ type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT),
+ SCM_BOOL_F);
scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
scm_print_state_vtable = type;
diff --git a/libguile/private-gc.h b/libguile/private-gc.h
index 42514c1e2..4c691dd0b 100644
--- a/libguile/private-gc.h
+++ b/libguile/private-gc.h
@@ -1,7 +1,7 @@
/*
* private-gc.h - private declarations for garbage collection.
*
- * Copyright (C) 2002, 03, 04, 05, 06, 07, 08, 09 Free Software Foundation, Inc.
+ * Copyright (C) 2002, 03, 04, 05, 06, 07, 08, 09, 11 Free Software Foundation, 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,18 +49,6 @@ 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 428d63f91..93ee7f033 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 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/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,20 +22,16 @@
# include <config.h>
#endif
-#define SCM_BUILDING_DEPRECATED_CODE
-
#include "libguile/_scm.h"
#include "libguile/alist.h"
-#include "libguile/deprecation.h"
-#include "libguile/deprecated.h"
#include "libguile/eval.h"
#include "libguile/procs.h"
#include "libguile/gsubr.h"
#include "libguile/smob.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
-#include "libguile/hashtab.h"
+#include "libguile/weak-table.h"
#include "libguile/programs.h"
#include "libguile/validate.h"
@@ -44,13 +39,9 @@
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 +50,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,23 +62,20 @@ 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))
{
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- return 0;
- proc = scm_i_smob_apply_trampoline (proc);
- break;
- case scm_tcs_struct:
if (!SCM_STRUCT_APPLICABLE_P (proc))
return 0;
proc = SCM_STRUCT_PROCEDURE (proc);
- break;
- default:
- return 0;
}
+ else if (SCM_HAS_TYP7 (proc, scm_tc7_smob))
+ {
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ return 0;
+ proc = scm_i_smob_apply_trampoline (proc);
+ }
+ else
+ return 0;
}
return scm_i_program_arity (proc, req, opt, rest);
@@ -107,9 +93,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
@@ -148,9 +132,7 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
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);
+ ret = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
if (scm_is_false (ret))
{
@@ -160,10 +142,6 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
ret = SCM_EOL;
}
-#if (SCM_ENABLE_DEPRECATED == 1)
- ret = scm_acons (scm_sym_arity, scm_procedure_minimum_arity (proc), ret);
-#endif
-
return ret;
}
#undef FUNC_NAME
@@ -175,14 +153,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, alist);
return SCM_UNSPECIFIED;
}
@@ -195,13 +166,6 @@ SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
{
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
-
return scm_assq_ref (scm_procedure_properties (proc), key);
}
#undef FUNC_NAME
@@ -216,13 +180,8 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
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);
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
if (scm_is_false (props))
{
if (SCM_PROGRAM_P (proc))
@@ -230,8 +189,8 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
else
props = SCM_EOL;
}
- 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_assq_set_x (props, key, val));
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
return SCM_UNSPECIFIED;
}
@@ -243,8 +202,8 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
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"
}
diff --git a/libguile/procprop.h b/libguile/procprop.h
index 919fa4d3a..88e44ec30 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 Free Software Foundation, 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,9 +28,6 @@
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;
diff --git a/libguile/procs.c b/libguile/procs.c
index a096591df..7a2f491d9 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -46,21 +46,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
@@ -146,14 +135,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/programs.c b/libguile/programs.c
index b84f84bd3..128e0312a 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -82,22 +82,22 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
if (SCM_PROGRAM_IS_CONTINUATION (program))
{
/* twingliness */
- scm_puts ("#<continuation ", port);
+ scm_puts_unlocked ("#<continuation ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
{
/* twingliness */
- scm_puts ("#<partial-continuation ", port);
+ scm_puts_unlocked ("#<partial-continuation ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
else if (scm_is_false (write_program) || print_error)
{
- scm_puts ("#<program ", port);
+ scm_puts_unlocked ("#<program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
else
{
diff --git a/libguile/programs.h b/libguile/programs.h
index d0e788e51..d53fd8f84 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+/* 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
@@ -32,7 +32,7 @@
#define SCM_F_PROGRAM_IS_CONTINUATION 0x800
#define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x1000
-#define SCM_PROGRAM_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
+#define SCM_PROGRAM_P(x) (SCM_HAS_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))
diff --git a/libguile/promises.c b/libguile/promises.c
index 4aff15092..57a208104 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 ("#<promise ", port);
+ scm_puts_unlocked ("#<promise ", port);
SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return !0;
}
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 <pthread.h>
#include <sched.h>
-/* `libgc' defines wrapper procedures for pthread calls. */
-#include "libguile/bdw-gc.h"
-
/* Threads
*/
#define scm_i_pthread_t pthread_t
#define scm_i_pthread_self pthread_self
-#define scm_i_pthread_create GC_pthread_create
-#define scm_i_pthread_detach GC_pthread_detach
+#define scm_i_pthread_create pthread_create
+#define scm_i_pthread_detach pthread_detach
-#if SCM_HAVE_GC_PTHREAD_EXIT
-#define scm_i_pthread_exit GC_pthread_exit
-#else
#define scm_i_pthread_exit pthread_exit
-#endif
-
-#if SCM_HAVE_GC_PTHREAD_CANCEL
-#define scm_i_pthread_cancel GC_pthread_cancel
-#else
#define scm_i_pthread_cancel pthread_cancel
-#endif
#define scm_i_pthread_cleanup_push pthread_cleanup_push
#define scm_i_pthread_cleanup_pop pthread_cleanup_pop
@@ -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 e8674299d..60ba38caa 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;
@@ -538,7 +522,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;
@@ -593,7 +577,7 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
}
/* We can't use `scm_c_read ()' since it blocks. */
- c_chr = scm_getc (port);
+ c_chr = scm_getc_unlocked (port);
if (c_chr != EOF)
{
c_bv[c_total] = (char) c_chr;
@@ -618,7 +602,8 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 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;
@@ -657,7 +642,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 (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
@@ -677,7 +662,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;
@@ -702,7 +688,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;
}
@@ -745,7 +731,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;
}
@@ -827,26 +813,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;
-
- SCM_SET_BOP_BUFFER (port, buf);
+ port = scm_c_make_port_with_encoding (bytevector_output_port_type,
+ mode_bits,
+ NULL, /* encoding */
+ SCM_FAILED_CONVERSION_ERROR,
+ (scm_t_bits)buf);
- /* Mark PORT as open and writable. */
- SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
+ c_port = SCM_PTAB_ENTRY (port);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = 0;
/* Make the bop procedure. */
SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf);
@@ -919,7 +898,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)
@@ -930,7 +909,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;
@@ -986,26 +965,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;
}
@@ -1103,13 +1074,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))
{
@@ -1122,15 +1088,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
@@ -1148,7 +1112,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)
@@ -1185,7 +1149,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;
@@ -1267,7 +1231,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/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 616672418..7db03417c 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -216,13 +216,13 @@ read_token (SCM port, char *buf, const size_t buf_size, size_t *read)
{
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
@@ -288,7 +288,7 @@ flush_ws (SCM port, const char *eoferr)
{
register scm_t_wchar c;
while (1)
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goteof:
@@ -303,7 +303,7 @@ flush_ws (SCM port, const char *eoferr)
case ';':
lp:
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goto goteof;
@@ -315,7 +315,7 @@ flush_ws (SCM port, const char *eoferr)
break;
case '#':
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
eoferr = "read_sharp";
@@ -334,7 +334,7 @@ flush_ws (SCM port, const char *eoferr)
}
/* fall through */
default:
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return '#';
}
break;
@@ -375,7 +375,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
if (terminating_char == c)
return SCM_EOL;
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
tmp = scm_read_expression (port);
/* Note that it is possible for scm_read_expression to return
@@ -402,7 +402,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
"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);
/* See above note about scm_sym_dot. */
@@ -442,7 +442,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
c = 0; \
while (i < ndigits) \
{ \
- a = scm_getc (port); \
+ a = scm_getc_unlocked (port); \
if (a == EOF) \
goto str_eof; \
if (terminator \
@@ -472,13 +472,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
@@ -493,7 +493,7 @@ scm_read_string (int chr, SCM port)
scm_t_wchar c;
str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0);
- while ('"' != (c = scm_getc (port)))
+ while ('"' != (c = scm_getc_unlocked (port)))
{
if (c == EOF)
{
@@ -511,7 +511,7 @@ scm_read_string (int chr, SCM port)
if (c == '\\')
{
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goto str_eof;
@@ -596,7 +596,7 @@ scm_read_number (scm_t_wchar chr, SCM port)
int overflow;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
overflow = read_complete_token (port, buffer, sizeof (buffer),
&overflow_buffer, &bytes_read);
@@ -633,7 +633,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port)
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM str;
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
overflow = read_complete_token (port, buffer, READER_BUFFER_SIZE,
&overflow_buffer, &bytes_read);
if (bytes_read > 0)
@@ -710,8 +710,8 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port)
break;
default:
- scm_ungetc (chr, port);
- scm_ungetc ('#', port);
+ scm_ungetc_unlocked (chr, port);
+ scm_ungetc_unlocked ('#', port);
radix = 10;
}
@@ -762,12 +762,12 @@ scm_read_quote (int chr, SCM port)
{
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;
@@ -812,12 +812,12 @@ scm_read_syntax (int chr, SCM port)
{
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;
@@ -857,9 +857,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;
}
@@ -901,7 +901,7 @@ scm_read_character (scm_t_wchar chr, SCM port)
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);
@@ -1028,15 +1028,15 @@ scm_read_srfi4_vector (int chr, SCM port)
static SCM
scm_read_bytevector (scm_t_wchar chr, SCM port)
{
- 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;
@@ -1056,15 +1056,15 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port)
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 scm_bitvector (scm_reverse_x (s_bits, SCM_EOL));
}
@@ -1076,7 +1076,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,
@@ -1097,30 +1097,30 @@ static SCM
scm_read_shebang (scm_t_wchar chr, SCM port)
{
int c = 0;
- if ((c = scm_get_byte_or_eof (port)) != 'r')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != 'r')
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return scm_read_scsh_block_comment (chr, port);
}
- if ((c = scm_get_byte_or_eof (port)) != '6')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != '6')
{
- scm_ungetc (c, port);
- scm_ungetc ('r', port);
+ scm_ungetc_unlocked (c, port);
+ scm_ungetc_unlocked ('r', port);
return scm_read_scsh_block_comment (chr, port);
}
- if ((c = scm_get_byte_or_eof (port)) != 'r')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != 'r')
{
- scm_ungetc (c, port);
- scm_ungetc ('6', port);
- scm_ungetc ('r', port);
+ scm_ungetc_unlocked (c, port);
+ scm_ungetc_unlocked ('6', port);
+ scm_ungetc_unlocked ('r', port);
return scm_read_scsh_block_comment (chr, port);
}
- if ((c = scm_get_byte_or_eof (port)) != 's')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != 's')
{
- scm_ungetc (c, port);
- scm_ungetc ('r', port);
- scm_ungetc ('6', port);
- scm_ungetc ('r', port);
+ scm_ungetc_unlocked (c, port);
+ scm_ungetc_unlocked ('r', port);
+ scm_ungetc_unlocked ('6', port);
+ scm_ungetc_unlocked ('r', port);
return scm_read_scsh_block_comment (chr, port);
}
@@ -1134,7 +1134,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,
@@ -1142,7 +1142,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,
@@ -1174,7 +1174,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);
return SCM_UNSPECIFIED;
}
@@ -1193,7 +1193,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)
{
@@ -1220,7 +1220,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;
@@ -1307,7 +1307,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port)
{
SCM result;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
result = scm_read_sharp_extension (chr, port);
if (!scm_is_eq (result, SCM_UNSPECIFIED))
@@ -1339,29 +1339,10 @@ scm_read_sharp (scm_t_wchar chr, SCM port)
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_i_read_array (port, chr));
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_i_read_array (port, chr);
- /* Fall through. */
- }
-#endif
case 'b':
case 'B':
case 'o':
@@ -1417,7 +1398,7 @@ scm_read_expression (SCM port)
{
register scm_t_wchar chr;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
switch (chr)
{
@@ -1495,7 +1476,7 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0,
c = flush_ws (port, (char *) NULL);
if (EOF == c)
return SCM_EOF_VAL;
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return (scm_read_expression (port));
}
@@ -1607,7 +1588,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;
@@ -1615,7 +1596,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;
@@ -1640,7 +1621,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));
}
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 723d6a8c5..86fce0fe7 100644
--- a/libguile/scmsigs.c
+++ b/libguile/scmsigs.c
@@ -150,6 +150,28 @@ struct signal_pipe_data
int err;
};
+#ifndef HAVE_GC_GET_SUSPEND_SIGNAL
+static int
+GC_get_suspend_signal (void)
+{
+#if defined SIG_SUSPEND
+ return SIG_SUSPEND;
+#elif defined SIGPWR
+ return SIGPWR;
+#elif defined SIGLOST
+ return SIGLOST;
+#elif defined _SIGRTMIN
+ return _SIGRTMIN + 6;
+#elif defined SIGRTMIN
+ return SIGRTMIN + 6;
+#elif defined __GLIBC__
+ return 32+6;
+#else
+ return SIGUSR1;
+#endif
+}
+#endif /* HAVE_GC_GET_SUSPEND_SIGNAL */
+
static void*
read_signal_pipe_data (void * data)
{
@@ -168,6 +190,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/smob.c b/libguile/smob.c
index 8b038f5de..e966da8e1 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -105,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;
}
@@ -415,16 +415,13 @@ scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
}
static SCM tramp_weak_map = SCM_BOOL_F;
-static scm_i_pthread_mutex_t tramp_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
SCM
scm_i_smob_apply_trampoline (SCM smob)
{
SCM tramp;
- scm_i_pthread_mutex_lock (&tramp_lock);
- tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
- scm_i_pthread_mutex_unlock (&tramp_lock);
+ tramp = scm_weak_table_refq (tramp_weak_map, smob, SCM_BOOL_F);
if (scm_is_true (tramp))
return tramp;
@@ -438,15 +435,13 @@ scm_i_smob_apply_trampoline (SCM smob)
name = "smob-apply";
objtable = scm_c_make_vector (2, SCM_UNDEFINED);
SCM_SIMPLE_VECTOR_SET (objtable, 0, smob);
- SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name));
+ SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_utf8_symbol (name));
tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode,
objtable, SCM_BOOL_F);
/* Race conditions (between the ref and this set!) cannot cause
any harm here. */
- scm_i_pthread_mutex_lock (&tramp_lock);
- scm_hashq_set_x (tramp_weak_map, smob, tramp);
- scm_i_pthread_mutex_unlock (&tramp_lock);
+ scm_weak_table_putq_x (tramp_weak_map, smob, tramp);
return tramp;
}
}
@@ -472,8 +467,8 @@ scm_make_smob (scm_t_bits tc)
static int smob_gc_kind;
-/* The generic SMOB mark procedure that gets called for SMOBs allocated with
- `scm_i_new_smob_with_mark_proc ()'. */
+/* The generic SMOB mark procedure that gets called for SMOBs allocated
+ with smob_gc_kind. */
static struct GC_ms_entry *
smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
struct GC_ms_entry *mark_stack_limit, GC_word env)
@@ -481,7 +476,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
@@ -518,7 +513,7 @@ smob_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
- 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,
@@ -543,7 +538,7 @@ scm_gc_mark (SCM o)
#define CURRENT_MARK_LIMIT \
((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
- if (SCM_NIMP (o))
+ if (SCM_HEAP_OBJECT_P (o))
{
/* At this point, the `current_mark_*' fields of the current thread
must be defined (they are set in `smob_mark ()'). */
@@ -562,33 +557,15 @@ scm_gc_mark (SCM o)
#undef CURRENT_MARK_LIMIT
}
-/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
- provide a custom mark procedure and it will be honored. */
-SCM
-scm_i_new_smob_with_mark_proc (scm_t_bits tc, scm_t_bits data1,
- scm_t_bits data2, scm_t_bits data3)
-{
- /* Return a double cell. */
- SCM cell = SCM_PACK (GC_generic_malloc (2 * sizeof (scm_t_cell),
- smob_gc_kind));
-
- SCM_SET_CELL_WORD_3 (cell, data3);
- SCM_SET_CELL_WORD_2 (cell, data2);
- SCM_SET_CELL_WORD_1 (cell, data1);
- SCM_SET_CELL_WORD_0 (cell, tc);
-
- return cell;
-}
-
/* Finalize SMOB by calling its SMOB type's free function, if any. */
-void
-scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
+static void
+finalize_smob (GC_PTR ptr, GC_PTR 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));
@@ -599,6 +576,73 @@ scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
free_smob (smob);
}
+/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
+ provide a custom mark procedure and it will be honored. */
+SCM
+scm_i_new_smob (scm_t_bits tc, scm_t_bits data)
+{
+ scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
+ SCM ret;
+
+ /* Use the smob_gc_kind if needed to allow the mark procedure to
+ run. Since the marker only deals with double cells, that case
+ allocates a double cell. We leave words 2 and 3 to there initial
+ values, which is 0. */
+ if (scm_smobs [smobnum].mark)
+ ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
+ else
+ ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell)));
+
+ SCM_SET_CELL_WORD_1 (ret, data);
+ SCM_SET_CELL_WORD_0 (ret, tc);
+
+ if (scm_smobs[smobnum].free)
+ {
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalizer_data;
+
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret),
+ finalize_smob, NULL,
+ &prev_finalizer, &prev_finalizer_data);
+ }
+
+ return ret;
+}
+
+/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
+ provide a custom mark procedure and it will be honored. */
+SCM
+scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1,
+ scm_t_bits data2, scm_t_bits data3)
+{
+ scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
+ SCM ret;
+
+ /* Use the smob_gc_kind if needed to allow the mark procedure to
+ run. */
+ if (scm_smobs [smobnum].mark)
+ ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
+ else
+ 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);
+ SCM_SET_CELL_WORD_1 (ret, data1);
+ SCM_SET_CELL_WORD_0 (ret, tc);
+
+ if (scm_smobs[smobnum].free)
+ {
+ GC_finalization_proc prev_finalizer;
+ GC_PTR prev_finalizer_data;
+
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret),
+ finalize_smob, NULL,
+ &prev_finalizer, &prev_finalizer_data);
+ }
+
+ return ret;
+}
+
void
scm_smob_prehistory ()
@@ -625,7 +669,7 @@ scm_smob_prehistory ()
scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
}
- tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ tramp_weak_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
}
/*
diff --git a/libguile/smob.h b/libguile/smob.h
index 6a7ceeae6..be404a8f7 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -27,8 +27,6 @@
#include "libguile/__scm.h"
#include "libguile/print.h"
-#include "libguile/bdw-gc.h"
-
/* This is the internal representation of a smob type */
@@ -46,78 +44,79 @@ typedef struct scm_smob_descriptor
} scm_smob_descriptor;
+#define SCM_SMOB_TYPE_MASK 0xffff
+#define SCM_SMOB_TYPE_BITS(tc) (tc)
+#define SCM_TC2SMOBNUM(x) (0x0ff & ((x) >> 8))
+#define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CELL_TYPE (x)))
+/* SCM_SMOBNAME can be 0 if name is missing */
+#define SCM_SMOBNAME(smobnum) (scm_smobs[smobnum].name)
+#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)
+
+/* Maximum number of SMOB types. */
+#define SCM_I_MAX_SMOB_TYPE_COUNT 256
+
+SCM_API long scm_numsmob;
+SCM_API scm_smob_descriptor scm_smobs[];
+
+
-SCM_API SCM scm_i_new_smob_with_mark_proc (scm_t_bits tc,
- scm_t_bits, scm_t_bits, scm_t_bits);
-
-
-
-#define SCM_NEWSMOB(z, tc, data) \
-do \
- { \
- register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc); \
- z = (scm_smobs[_smobnum].mark \
- ? scm_i_new_smob_with_mark_proc ((tc), (scm_t_bits)(data), \
- 0, 0) \
- : scm_cell (tc, (scm_t_bits)(data))); \
- if (scm_smobs[_smobnum].free) \
- { \
- GC_finalization_proc _prev_finalizer; \
- GC_PTR _prev_finalizer_data; \
- \
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \
- NULL, \
- &_prev_finalizer, \
- &_prev_finalizer_data); \
- } \
- } \
-while (0)
-
-#define SCM_RETURN_NEWSMOB(tc, data) \
- do { SCM __SCM_smob_answer; \
- SCM_NEWSMOB (__SCM_smob_answer, (tc), (data)); \
- return __SCM_smob_answer; \
- } while (0)
-
-#define SCM_NEWSMOB2(z, tc, data1, data2) \
- SCM_NEWSMOB3 (z, tc, data1, data2, 0)
-
-#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \
- do { SCM __SCM_smob_answer; \
- SCM_NEWSMOB2 (__SCM_smob_answer, (tc), (data1), (data2)); \
- return __SCM_smob_answer; \
- } while (0)
-
-#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \
-do \
- { \
- register scm_t_bits _smobnum = SCM_TC2SMOBNUM (tc); \
- z = (scm_smobs[_smobnum].mark \
- ? scm_i_new_smob_with_mark_proc (tc, (scm_t_bits)(data1), \
- (scm_t_bits)(data2), \
- (scm_t_bits)(data3)) \
- : scm_double_cell ((tc), (scm_t_bits)(data1), \
- (scm_t_bits)(data2), \
- (scm_t_bits)(data3))); \
- if (scm_smobs[_smobnum].free) \
- { \
- GC_finalization_proc _prev_finalizer; \
- GC_PTR _prev_finalizer_data; \
- \
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (z), scm_i_finalize_smob, \
- NULL, \
- &_prev_finalizer, \
- &_prev_finalizer_data); \
- } \
- } \
-while (0)
-
-#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \
- do { SCM __SCM_smob_answer; \
- SCM_NEWSMOB3 (__SCM_smob_answer, (tc), (data1), (data2), (data3)); \
- return __SCM_smob_answer; \
- } while (0)
+SCM_API SCM scm_i_new_smob (scm_t_bits tc, scm_t_bits);
+SCM_API SCM scm_i_new_double_smob (scm_t_bits tc, scm_t_bits,
+ scm_t_bits, scm_t_bits);
+
+
+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);
+
+#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)
+{
+ scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
+
+ if (SCM_UNLIKELY (scm_smobs[smobnum].mark || scm_smobs[smobnum].free))
+ return scm_i_new_smob (tc, data);
+ else
+ return scm_cell (tc, data);
+}
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_new_double_smob (scm_t_bits tc, scm_t_bits data1,
+ scm_t_bits data2, scm_t_bits data3)
+{
+ scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
+
+ if (SCM_UNLIKELY (scm_smobs[smobnum].mark || scm_smobs[smobnum].free))
+ return scm_i_new_double_smob (tc, data1, data2, data3);
+ else
+ return scm_double_cell (tc, data1, data2, data3);
+}
+#endif
+
+#define SCM_NEWSMOB(z, tc, data) \
+ z = scm_new_smob ((tc), (scm_t_bits)(data))
+#define SCM_RETURN_NEWSMOB(tc, data) \
+ return scm_new_smob ((tc), (scm_t_bits)(data))
+
+#define SCM_NEWSMOB2(z, tc, data1, data2) \
+ z = scm_new_double_smob ((tc), (scm_t_bits)(data1), \
+ (scm_t_bits)(data2), 0)
+#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \
+ return scm_new_double_smob ((tc), (scm_t_bits)(data1), \
+ (scm_t_bits)(data2), 0)
+
+#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \
+ z = scm_new_double_smob ((tc), (scm_t_bits)(data1), \
+ (scm_t_bits)(data2), (scm_t_bits)(data3))
+#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \
+ return scm_new_double_smob ((tc), (scm_t_bits)(data1), \
+ (scm_t_bits)(data2), (scm_t_bits)(data3))
+
+
#define SCM_SMOB_DATA_N(x, n) (SCM_CELL_WORD ((x), (n)))
#define SCM_SET_SMOB_DATA_N(x, n, data) (SCM_SET_CELL_WORD ((x), (n), (data)))
@@ -158,28 +157,11 @@ while (0)
#define SCM_SMOB_OBJECT_LOC(x) (SCM_SMOB_OBJECT_1_LOC (x)))
-#define SCM_SMOB_TYPE_MASK 0xffff
-#define SCM_SMOB_TYPE_BITS(tc) (tc)
-#define SCM_TC2SMOBNUM(x) (0x0ff & ((x) >> 8))
-#define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CELL_TYPE (x)))
-/* SCM_SMOBNAME can be 0 if name is missing */
-#define SCM_SMOBNAME(smobnum) (scm_smobs[smobnum].name)
-#define SCM_SMOB_PREDICATE(tag, obj) SCM_TYP16_PREDICATE (tag, obj)
-#define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)])
-#define SCM_SMOB_APPLICABLE_P(x) (SCM_SMOB_DESCRIPTOR (x).apply)
#define SCM_SMOB_APPLY_0(x) (scm_call_0 (x))
#define SCM_SMOB_APPLY_1(x, a1) (scm_call_1 (x, a1))
#define SCM_SMOB_APPLY_2(x, a1, a2) (scm_call_2 (x, a1, a2))
#define SCM_SMOB_APPLY_3(x, a1, a2, rst) (scm_call_3 (x, a1, a2, a3))
-/* Maximum number of SMOB types. */
-#define SCM_I_MAX_SMOB_TYPE_COUNT 256
-
-SCM_API long scm_numsmob;
-SCM_API scm_smob_descriptor scm_smobs[];
-
-SCM_API void scm_i_finalize_smob (GC_PTR obj, GC_PTR data);
-
SCM_API SCM scm_mark0 (SCM ptr);
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 1c072babb..3931570f4 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -119,9 +119,9 @@ SCM_SNARF_HERE( \
) \
SCM_SNARF_INIT( \
/* Initialize the foreign. */ \
- scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __subr_foreign); \
+ scm_i_paste (FNAME, __raw_objtable)[1] = 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); \
+ scm_i_paste (FNAME, __raw_objtable)[2] = 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)); \
@@ -209,11 +209,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 */
@@ -366,12 +366,11 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
/* 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] = \
+ static SCM_ALIGNED (8) SCM c_name[3] = \
{ \
SCM_PACK (scm_tc7_vector | (2 << 8)), \
- SCM_PACK (0), \
foreign, \
- SCM_BOOL_F, /* the name */ \
+ SCM_BOOL_F /* the name */ \
}
#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
diff --git a/libguile/socket.c b/libguile/socket.c
index 7d0049b1c..d085d330e 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -39,10 +39,6 @@
#include "libguile/validate.h"
#include "libguile/socket.h"
-#if SCM_ENABLE_DEPRECATED == 1
-# include "libguile/deprecation.h"
-#endif
-
#ifdef __MINGW32__
#include "win32-socket.h"
#include <netdb.h>
@@ -1414,33 +1410,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;
@@ -1480,35 +1455,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;
@@ -1566,52 +1518,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;
@@ -1681,35 +1609,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 dc333d46c..f63f1bc61 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -33,7 +33,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"
@@ -61,7 +60,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;
/*
@@ -97,11 +95,11 @@ static int
srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<srcprops ", port);
+ scm_puts_unlocked ("#<srcprops ", port);
SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (scm_srcprops_to_alist (obj), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
@@ -167,9 +165,7 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 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_unlock (&source_lock);
+ p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);
if (SRCPROPSP (p))
return scm_srcprops_to_alist (p);
@@ -189,9 +185,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;
}
@@ -205,9 +199,7 @@ scm_i_has_source_properties (SCM obj)
SCM_VALIDATE_NIM (1, obj);
- 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);
+ ret = scm_is_true (scm_weak_table_refq (scm_source_whash, obj, SCM_BOOL_F));
return ret;
}
@@ -220,14 +212,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
@@ -240,9 +230,7 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 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_unlock (&source_lock);
+ p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);
if (!SRCPROPSP (p))
goto alist;
@@ -257,7 +245,7 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
p = SRCPROPALIST (p);
alist:
p = scm_assoc (key, p);
- return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
+ return (scm_is_pair (p) ? SCM_CDR (p) : SCM_BOOL_F);
}
return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
}
@@ -272,44 +260,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;
}
@@ -325,12 +313,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
@@ -342,7 +328,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 (2047, 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-14.c b/libguile/srfi-14.c
index e2f66681a..09323704d 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 ("#<charset {", port);
+ scm_puts_unlocked ("#<charset {", port);
for (i = 0; i < p->len; i++)
{
if (first)
first = 0;
else
- scm_puts (" ", port);
+ scm_puts_unlocked (" ", port);
scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port);
if (p->ranges[i].lo != p->ranges[i].hi)
{
- scm_puts ("..", port);
+ scm_puts_unlocked ("..", port);
scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port);
}
if (i >= max_ranges_to_print)
{
/* Too many to print here. Quit early. */
- scm_puts (" ...", port);
+ scm_puts_unlocked (" ...", port);
break;
}
}
- scm_puts ("}>", port);
+ scm_puts_unlocked ("}>", port);
return 1;
}
@@ -630,16 +630,16 @@ charset_cursor_print (SCM cursor, SCM port,
cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
- scm_puts ("#<charset-cursor ", port);
+ scm_puts_unlocked ("#<charset-cursor ", port);
if (cur->range == (size_t) (-1))
- scm_puts ("(empty)", port);
+ scm_puts_unlocked ("(empty)", port);
else
{
scm_write (scm_from_size_t (cur->range), port);
- scm_puts (":", port);
+ scm_puts_unlocked (":", port);
scm_write (scm_from_int32 (cur->n), port);
}
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
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/strings.c b/libguile/strings.c
index 8491b1ea2..cdd43e1b2 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -126,7 +126,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 +153,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 +240,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.
*/
@@ -1487,6 +1487,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)
@@ -1520,19 +1537,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)
@@ -1606,7 +1611,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 (nbytes < 0)
+ /* 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; i++, 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; i++, j++)
+ {
+ i += u8_mbtouc_unsafe (&c, ustr + i, len - i);
+ dst[j] = c;
+ }
+ }
+
+ return res;
}
SCM
@@ -2170,66 +2249,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..04a976211 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -235,21 +235,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 b7fec4703..fc52a86e1 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -207,7 +207,7 @@ st_seek (SCM port, scm_t_off offset, int whence)
st_flush (port);
if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ scm_end_input_unlocked (port);
switch (whence)
{
@@ -277,17 +277,14 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
{
SCM z, buf;
scm_t_port *pt;
- size_t str_len, c_pos;
+ const char *encoding;
+ size_t read_buf_size, str_len, c_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);
- pt = SCM_PTAB_ENTRY(z);
+ encoding = scm_i_default_port_encoding ();
if (scm_is_false (str))
{
@@ -297,8 +294,8 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
/* Reset `read_buf_size'. It will contain the actual number of
- bytes written to PT. */
- pt->read_buf_size = 0;
+ bytes written to the port. */
+ read_buf_size = 0;
c_pos = 0;
}
else
@@ -308,8 +305,8 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
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,
+ /* Create a copy of STR in ENCODING. */
+ copy = scm_to_stringn (str, &str_len, encoding,
SCM_FAILED_CONVERSION_ERROR);
buf = scm_c_make_bytevector (str_len);
c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
@@ -317,26 +314,26 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
free (copy);
c_pos = scm_to_unsigned_integer (pos, 0, str_len);
- pt->read_buf_size = str_len;
+ read_buf_size = str_len;
}
- 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,
+ encoding,
+ SCM_FAILED_CONVERSION_ERROR,
+ (scm_t_bits)buf);
+ 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->read_buf_size = read_buf_size;
pt->write_buf_size = str_len;
pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
-
pt->rw_random = 1;
- scm_dynwind_end ();
-
/* Ensure WRITE_POS is writable. */
if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
st_flush (z);
- scm_i_set_conversion_strategy_x (z, SCM_FAILED_CONVERSION_ERROR);
return z;
}
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 4a2a9d750..d022cce78 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -24,12 +24,13 @@
#include <alloca.h>
#include <assert.h>
+#define SCM_BUILDING_DEPRECATED_CODE
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#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"
@@ -447,7 +448,7 @@ scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
/* Register a finalizer for the newly created instance. */
GC_finalization_proc prev_finalizer;
GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (ret),
struct_finalizer_trampoline,
NULL,
&prev_finalizer,
@@ -570,6 +571,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
+#if SCM_ENABLE_DEPRECATED == 1
SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
(SCM user_fields, SCM tail_array_size, SCM init),
"Return a new, self-describing vtable structure.\n\n"
@@ -664,7 +666,38 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
return obj;
}
#undef FUNC_NAME
+#endif
+
+SCM
+scm_i_make_vtable_vtable (SCM user_fields)
+#define FUNC_NAME s_scm_make_vtable_vtable
+{
+ SCM fields, layout, obj;
+ size_t basic_size;
+ scm_t_bits v;
+
+ SCM_VALIDATE_STRING (1, user_fields);
+ 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;
+
+ obj = scm_i_alloc_struct (NULL, basic_size);
+ /* 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);
+
+ v = SCM_UNPACK (layout);
+ scm_struct_init (obj, layout, 0, 1, &v);
+ SCM_SET_VTABLE_FLAGS (obj,
+ SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED);
+
+ return obj;
+}
+#undef FUNC_NAME
SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
(SCM fields, SCM printer),
@@ -982,22 +1015,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 */
@@ -1005,19 +1038,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);
}
}
@@ -1035,11 +1068,12 @@ scm_init_struct ()
GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
+ scm_c_define ("standard-vtable-fields", required_vtable_fields);
required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT);
required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
- scm_standard_vtable_vtable =
- scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
+ scm_standard_vtable_vtable = scm_i_make_vtable_vtable (scm_nullstr);
+ scm_c_define ("<standard-vtable>", scm_standard_vtable_vtable);
scm_applicable_struct_vtable_vtable =
scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
diff --git a/libguile/struct.h b/libguile/struct.h
index c3c7d8f12..3e2bc5353 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -180,7 +180,10 @@ SCM_API SCM scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_inits,
SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits,
scm_t_bits init[]);
SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
-SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
+SCM_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);
diff --git a/libguile/symbols.c b/libguile/symbols.c
index 59aca002e..9cb300ab0 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -23,6 +23,8 @@
# include <config.h>
#endif
+#include <unistr.h>
+
#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 (nbytes < 0)
+ /* 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);
}
}
@@ -490,14 +528,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 a3032bfa9..fb550479d 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
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -113,6 +113,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?'.
@@ -123,51 +128,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
@@ -201,69 +212,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)
@@ -274,7 +272,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.
*
@@ -283,13 +281,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.)
@@ -298,8 +296,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.
*
@@ -321,19 +319,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
@@ -352,11 +350,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,
@@ -364,7 +363,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.
*/
@@ -392,11 +391,26 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
#define scm_tc3_tc7_2 7
+/* As we have seen, heap objects have a tag in their three lowest bits.
+ If you have a heap object and want the pointer to the start of the
+ object, perhaps for GC purposes, you need to mask off the low bits,
+ which is what SCM_HEAP_OBJECT_BASE does.
+
+ Note that you can avoid this macro if you know the specific type of
+ the object (pair, struct, or other).
+ */
+#define SCM_HEAP_OBJECT_BASE(x) ((scm_t_bits*)((SCM_UNPACK (x)) & ~7))
+
+
/* Definitions for tc7: */
#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))
#define scm_tc7_symbol 5
#define scm_tc7_variable 7
@@ -424,10 +438,10 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
#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_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
@@ -447,7 +461,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))
@@ -621,7 +636,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:\
@@ -663,13 +678,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 5a13e5ccf..463414f4a 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -63,7 +63,6 @@
#include "libguile/init.h"
#include "libguile/scmsigs.h"
#include "libguile/strings.h"
-#include "libguile/weaks.h"
#include <full-read.h>
@@ -398,11 +397,11 @@ thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
else
id = u.um;
- scm_puts ("#<thread ", port);
+ scm_puts_unlocked ("#<thread ", port);
scm_uintprint (id, 10, port);
- scm_puts (" (", port);
+ scm_puts_unlocked (" (", port);
scm_uintprint ((scm_t_bits)t, 16, port);
- scm_puts (")>", port);
+ scm_puts_unlocked (")>", port);
return 1;
}
@@ -661,10 +660,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;
@@ -685,9 +680,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);
@@ -701,7 +696,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);
@@ -1308,9 +1303,9 @@ static int
fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED)
{
fat_mutex *m = SCM_MUTEX_DATA (mx);
- scm_puts ("#<mutex ", port);
+ scm_puts_unlocked ("#<mutex ", port);
scm_uintprint ((scm_t_bits)m, 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
@@ -1413,7 +1408,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);
}
@@ -1557,6 +1553,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)
@@ -1601,7 +1616,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);
}
@@ -1635,7 +1650,7 @@ fat_mutex_unlock (SCM mutex, SCM cond,
}
t->block_asyncs--;
- scm_async_click ();
+ scm_async_tick ();
scm_remember_upto_here_2 (cond, mutex);
@@ -1649,7 +1664,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);
}
@@ -1745,9 +1760,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 ("#<condition-variable ", port);
+ scm_puts_unlocked ("#<condition-variable ", port);
scm_uintprint ((scm_t_bits)c, 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
diff --git a/libguile/threads.h b/libguile/threads.h
index ec129bc72..54d64141b 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -143,9 +143,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);
diff --git a/libguile/throw.c b/libguile/throw.c
index 9c293516d..29ccc8aba 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -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);
diff --git a/libguile/validate.h b/libguile/validate.h
index b0e502a1c..6dea795e5 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -3,7 +3,7 @@
#ifndef SCM_VALIDATE_H
#define SCM_VALIDATE_H
-/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 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
@@ -354,7 +354,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 9c9e5ff6d..fdd93599a 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 ("#<values ", port);
+ scm_puts_unlocked ("#<values ", port);
scm_iprin1 (values, port, ps);
- 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 ("#<variable ", port);
+ scm_puts_unlocked ("#<variable ", port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_puts (" value: ", port);
+ scm_puts_unlocked (" value: ", port);
scm_iprin1 (SCM_VARIABLE_REF (exp), port, pstate);
- scm_putc('>', port);
+ scm_putc_unlocked('>', port);
}
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 2805278f0..1640725e5 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -67,9 +67,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)
@@ -86,9 +84,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)
@@ -123,7 +119,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
@@ -205,43 +201,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);
@@ -269,46 +255,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. */
- GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]);
- SCM_I_REGISTER_DISAPPEARING_LINK (link,
- (GC_PTR) 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. */
- GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]);
- SCM_I_REGISTER_DISAPPEARING_LINK (link,
- (GC_PTR) 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");
}
@@ -336,28 +313,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
@@ -386,72 +352,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-i-scheme.c b/libguile/vm-i-scheme.c
index 80328cde8..ad16c46cc 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -444,10 +444,57 @@ VM_DEFINE_FUNCTION (162, logxor, "logxor", 2)
/*
+ * Strings
+ */
+
+VM_DEFINE_FUNCTION (163, string_length, "string-length", 1)
+{
+ ARGS1 (str);
+ if (SCM_LIKELY (scm_is_string (str)))
+ RETURN (SCM_I_MAKINUM (scm_i_string_length (str)));
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_string_length (str));
+ }
+}
+
+VM_DEFINE_FUNCTION (164, string_ref, "string-ref", 2)
+{
+ 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_REGISTER ();
+ RETURN (scm_string_ref (str, idx));
+ }
+}
+
+/* No string-set! instruction, as there is no good fast path there. */
+
+
+/*
* Vectors and arrays
*/
-VM_DEFINE_FUNCTION (163, vector_ref, "vector-ref", 2)
+VM_DEFINE_FUNCTION (165, vector_length, "vector-length", 1)
+{
+ ARGS1 (vect);
+ if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
+ RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_vector_length (vect));
+ }
+}
+
+VM_DEFINE_FUNCTION (166, vector_ref, "vector-ref", 2)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
@@ -463,7 +510,7 @@ VM_DEFINE_FUNCTION (163, vector_ref, "vector-ref", 2)
}
}
-VM_DEFINE_INSTRUCTION (164, vector_set, "vector-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (167, vector_set, "vector-set", 0, 3, 0)
{
scm_t_signed_bits i = 0;
SCM vect, idx, val;
@@ -481,7 +528,7 @@ VM_DEFINE_INSTRUCTION (164, vector_set, "vector-set", 0, 3, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (165, make_array, "make-array", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (168, make_array, "make-array", 3, -1, 1)
{
scm_t_uint32 len;
SCM shape, ret;
@@ -510,20 +557,20 @@ VM_DEFINE_INSTRUCTION (165, make_array, "make-array", 3, -1, 1)
goto vm_error_not_a_struct; \
}
-VM_DEFINE_FUNCTION (166, struct_p, "struct?", 1)
+VM_DEFINE_FUNCTION (169, struct_p, "struct?", 1)
{
ARGS1 (obj);
RETURN (scm_from_bool (SCM_STRUCTP (obj)));
}
-VM_DEFINE_FUNCTION (167, struct_vtable, "struct-vtable", 1)
+VM_DEFINE_FUNCTION (170, 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)
+VM_DEFINE_INSTRUCTION (171, make_struct, "make-struct", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
@@ -556,7 +603,7 @@ VM_DEFINE_INSTRUCTION (168, make_struct, "make-struct", 2, -1, 1)
NEXT;
}
-VM_DEFINE_FUNCTION (169, struct_ref, "struct-ref", 2)
+VM_DEFINE_FUNCTION (172, struct_ref, "struct-ref", 2)
{
ARGS2 (obj, pos);
@@ -586,7 +633,7 @@ VM_DEFINE_FUNCTION (169, struct_ref, "struct-ref", 2)
RETURN (scm_struct_ref (obj, pos));
}
-VM_DEFINE_FUNCTION (170, struct_set, "struct-set", 3)
+VM_DEFINE_FUNCTION (173, struct_set, "struct-set", 3)
{
ARGS3 (obj, pos, val);
@@ -620,7 +667,7 @@ VM_DEFINE_FUNCTION (170, struct_set, "struct-set", 3)
/*
* GOOPS support
*/
-VM_DEFINE_FUNCTION (171, class_of, "class-of", 1)
+VM_DEFINE_FUNCTION (174, class_of, "class-of", 1)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
@@ -630,7 +677,7 @@ VM_DEFINE_FUNCTION (171, class_of, "class-of", 1)
}
/* FIXME: No checking whatsoever. */
-VM_DEFINE_FUNCTION (172, slot_ref, "slot-ref", 2)
+VM_DEFINE_FUNCTION (175, slot_ref, "slot-ref", 2)
{
size_t slot;
ARGS2 (instance, idx);
@@ -639,7 +686,7 @@ VM_DEFINE_FUNCTION (172, slot_ref, "slot-ref", 2)
}
/* FIXME: No checking whatsoever. */
-VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (176, slot_set, "slot-set", 0, 3, 0)
{
SCM instance, idx, val;
size_t slot;
@@ -682,21 +729,21 @@ VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
#define ALIGNED_P(ptr, type) \
((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
-VM_DEFINE_FUNCTION (174, bv_u16_ref, "bv-u16-ref", 3)
+VM_DEFINE_FUNCTION (177, bv_u16_ref, "bv-u16-ref", 3)
BV_REF_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_FUNCTION (175, bv_s16_ref, "bv-s16-ref", 3)
+VM_DEFINE_FUNCTION (178, bv_s16_ref, "bv-s16-ref", 3)
BV_REF_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_FUNCTION (176, bv_u32_ref, "bv-u32-ref", 3)
+VM_DEFINE_FUNCTION (179, bv_u32_ref, "bv-u32-ref", 3)
BV_REF_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_FUNCTION (177, bv_s32_ref, "bv-s32-ref", 3)
+VM_DEFINE_FUNCTION (180, bv_s32_ref, "bv-s32-ref", 3)
BV_REF_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_FUNCTION (178, bv_u64_ref, "bv-u64-ref", 3)
+VM_DEFINE_FUNCTION (181, bv_u64_ref, "bv-u64-ref", 3)
BV_REF_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_FUNCTION (179, bv_s64_ref, "bv-s64-ref", 3)
+VM_DEFINE_FUNCTION (182, bv_s64_ref, "bv-s64-ref", 3)
BV_REF_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_FUNCTION (180, bv_f32_ref, "bv-f32-ref", 3)
+VM_DEFINE_FUNCTION (183, 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)
+VM_DEFINE_FUNCTION (184, bv_f64_ref, "bv-f64-ref", 3)
BV_REF_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_REF_WITH_ENDIANNESS
@@ -774,33 +821,33 @@ BV_REF_WITH_ENDIANNESS (f64, ieee_double)
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
}
-VM_DEFINE_FUNCTION (182, bv_u8_ref, "bv-u8-ref", 2)
+VM_DEFINE_FUNCTION (185, 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)
+VM_DEFINE_FUNCTION (186, 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)
+VM_DEFINE_FUNCTION (187, 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)
+VM_DEFINE_FUNCTION (188, 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)
+VM_DEFINE_FUNCTION (189, 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)
+VM_DEFINE_FUNCTION (190, 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)
+VM_DEFINE_FUNCTION (191, 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)
+VM_DEFINE_FUNCTION (192, 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)
+VM_DEFINE_FUNCTION (193, 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)
+VM_DEFINE_FUNCTION (194, bv_f64_native_ref, "bv-f64-native-ref", 2)
BV_FLOAT_REF (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_REF
@@ -823,21 +870,21 @@ BV_FLOAT_REF (f64, ieee_double, double, 8)
} \
}
-VM_DEFINE_INSTRUCTION (192, bv_u16_set, "bv-u16-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (195, 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)
+VM_DEFINE_INSTRUCTION (196, 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)
+VM_DEFINE_INSTRUCTION (197, 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)
+VM_DEFINE_INSTRUCTION (198, 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)
+VM_DEFINE_INSTRUCTION (199, 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)
+VM_DEFINE_INSTRUCTION (200, 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)
+VM_DEFINE_INSTRUCTION (201, 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)
+VM_DEFINE_INSTRUCTION (202, bv_f64_set, "bv-f64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_SET_WITH_ENDIANNESS
@@ -917,33 +964,33 @@ BV_SET_WITH_ENDIANNESS (f64, ieee_double)
NEXT; \
}
-VM_DEFINE_INSTRUCTION (200, bv_u8_set, "bv-u8-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (203, 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)
+VM_DEFINE_INSTRUCTION (204, 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)
+VM_DEFINE_INSTRUCTION (205, 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)
+VM_DEFINE_INSTRUCTION (206, 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)
+VM_DEFINE_INSTRUCTION (207, 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)
+VM_DEFINE_INSTRUCTION (208, 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)
+VM_DEFINE_INSTRUCTION (209, 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)
+VM_DEFINE_INSTRUCTION (210, 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)
+VM_DEFINE_INSTRUCTION (211, 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)
+VM_DEFINE_INSTRUCTION (212, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
BV_FLOAT_SET (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_SET
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 474fe7883..8981042f8 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -787,7 +787,7 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
goto vm_call;
}
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+ else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
SYNC_REGISTER ();
@@ -835,7 +835,7 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1)
sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
goto vm_tail_call;
}
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+ else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
SYNC_REGISTER ();
@@ -1096,7 +1096,7 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
goto vm_mv_call;
}
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+ else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
SYNC_REGISTER ();
diff --git a/libguile/vm.c b/libguile/vm.c
index 49df5cbee..859658816 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -83,9 +83,9 @@ static SCM sym_debug;
void
scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<vm-continuation ", port);
+ scm_puts_unlocked ("#<vm-continuation ", port);
scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
/* In theory, a number of vm instances can be active in the call trace, and we
@@ -228,8 +228,8 @@ vm_dispatch_hook (SCM vm, int hook_num)
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_1 = SCM_PACK_POINTER (&c_frame);
+ args[0] = SCM_PACK_POINTER (frame);
scm_c_run_hookn (hook, args, 1);
@@ -351,22 +351,22 @@ scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
vm = SCM_VM_DATA (x);
- scm_puts ("#<vm ", port);
+ scm_puts_unlocked ("#<vm ", port);
switch (vm->engine)
{
case SCM_VM_REGULAR_ENGINE:
- scm_puts ("regular-engine ", port);
+ scm_puts_unlocked ("regular-engine ", port);
break;
case SCM_VM_DEBUG_ENGINE:
- scm_puts ("debug-engine ", port);
+ scm_puts_unlocked ("debug-engine ", port);
break;
default:
- scm_puts ("unknown-engine ", port);
+ scm_puts_unlocked ("unknown-engine ", port);
}
scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
static SCM
@@ -391,7 +391,8 @@ really_make_boot_program (long nargs)
bp->metalen = 0;
u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
- sizeof (struct scm_objcode) + sizeof (text));
+ sizeof (struct scm_objcode) + sizeof (text),
+ SCM_BOOL_F);
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);
@@ -503,7 +504,7 @@ make_vm (void)
/* 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 = SCM_PACK_POINTER (vp);
vp->stack_base++;
vp->stack_size--;
#else
diff --git a/libguile/vm.h b/libguile/vm.h
index d354a53c0..2479ee4a4 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -55,7 +55,7 @@ struct scm_vm {
SCM_API SCM scm_the_vm_fluid;
-#define SCM_VM_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_vm)
+#define SCM_VM_P(x) (SCM_HAS_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)
@@ -96,7 +96,7 @@ struct scm_vm_cont {
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)
diff --git a/libguile/vports.c b/libguile/vports.c
index 5178d79c7..62f552ad7 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 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -114,7 +114,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);
}
@@ -198,7 +198,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);
@@ -206,14 +205,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..57e9e5001
--- /dev/null
+++ b/libguile/weak-set.c
@@ -0,0 +1,891 @@
+/* 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
+ */
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/hash.h"
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+#include "libguile/bdw-gc.h"
+
+#include "libguile/validate.h"
+#include "libguile/weak-set.h"
+
+
+/* Weak Sets
+
+ This file implements weak sets. One example of a weak set is the
+ symbol table, where you want all instances of the `foo' symbol to map
+ to one object. So when you load a file and it wants a symbol with
+ the characters "foo", you one up in the table, using custom hash and
+ equality predicates. Only if one is not found will you bother to
+ cons one up and intern it.
+
+ Another use case for weak sets is the set of open ports. Guile needs
+ to be able to flush them all when the process exits, but the set
+ shouldn't prevent the GC from collecting the port (and thus closing
+ it).
+
+ Weak sets are implemented using an open-addressed hash table.
+ Basically this means that there is an array of entries, and the item
+ is expected to be found the slot corresponding to its hash code,
+ modulo the length of the array.
+
+ Collisions are handled using linear probing with the Robin Hood
+ technique. See Pedro Celis' paper, "Robin Hood Hashing":
+
+ http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf
+
+ The vector of entries is allocated as an "atomic" piece of memory, so
+ that the GC doesn't trace it. When an item is added to the set, a
+ disappearing link is registered to its location. If the item is
+ collected, then that link will be zeroed out.
+
+ An entry is not just an item, though; the hash code is also stored in
+ the entry. We munge hash codes so that they are never 0. In this
+ way we can detect removed entries (key of zero but nonzero hash
+ code), and can then reshuffle elements as needed to maintain the
+ robin hood ordering.
+
+ Compared to buckets-and-chains hash tables, open addressing has the
+ advantage that it is very cache-friendly. It also uses less memory.
+
+ Implementation-wise, there are two things to note.
+
+ 1. We assume that hash codes are evenly distributed across the
+ range of unsigned longs. The actual hash code stored in the
+ entry is left-shifted by 1 bit (losing 1 bit of hash precision),
+ and then or'd with 1. In this way we ensure that the hash field
+ of an occupied entry is nonzero. To map to an index, we
+ right-shift the hash by one, divide by the size, and take the
+ remainder.
+
+ 2. Since the "keys" (the objects in the set) are stored in an
+ atomic region with disappearing links, they need to be accessed
+ with the GC alloc lock. `copy_weak_entry' will do that for
+ you. The hash code itself can be read outside the lock,
+ though.
+*/
+
+
+typedef struct {
+ unsigned long hash;
+ scm_t_bits key;
+} scm_t_weak_entry;
+
+
+struct weak_entry_data {
+ scm_t_weak_entry *in;
+ scm_t_weak_entry *out;
+};
+
+static void*
+do_copy_weak_entry (void *data)
+{
+ struct weak_entry_data *e = data;
+
+ e->out->hash = e->in->hash;
+ e->out->key = e->in->key;
+
+ return NULL;
+}
+
+static void
+copy_weak_entry (scm_t_weak_entry *src, scm_t_weak_entry *dst)
+{
+ struct weak_entry_data data;
+
+ data.in = src;
+ data.out = dst;
+
+ GC_call_with_alloc_lock (do_copy_weak_entry, &data);
+}
+
+
+typedef struct {
+ scm_t_weak_entry *entries; /* the data */
+ scm_i_pthread_mutex_t lock; /* the lock */
+ unsigned long size; /* total number of slots. */
+ unsigned long n_items; /* number of items in set */
+ unsigned long lower; /* when to shrink */
+ unsigned long upper; /* when to grow */
+ int size_index; /* index into hashset_size */
+ int min_size_index; /* minimum size_index */
+} scm_t_weak_set;
+
+
+#define SCM_WEAK_SET_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_set))
+#define SCM_VALIDATE_WEAK_SET(pos, arg) \
+ SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_SET_P, "weak-set")
+#define SCM_WEAK_SET(x) ((scm_t_weak_set *) SCM_CELL_WORD_1 (x))
+
+
+static unsigned long
+hash_to_index (unsigned long hash, unsigned long size)
+{
+ return (hash >> 1) % size;
+}
+
+static unsigned long
+entry_distance (unsigned long hash, unsigned long k, unsigned long size)
+{
+ unsigned long origin = hash_to_index (hash, size);
+
+ if (k >= origin)
+ return k - origin;
+ else
+ /* The other key was displaced and wrapped around. */
+ return size - origin + k;
+}
+
+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, &copy);
+ to->hash = copy.hash;
+ to->key = copy.key;
+
+ if (copy.key && SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
+ {
+#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
+ GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
+#else
+ GC_unregister_disappearing_link ((GC_PTR) &from->key);
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &to->key,
+ (GC_PTR) to->key);
+#endif
+ }
+ }
+ 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], &copy);
+
+ 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 void
+resize_set (scm_t_weak_set *set)
+{
+ scm_t_weak_entry *old_entries, *new_entries;
+ int i;
+ unsigned long old_size, new_size, old_k;
+
+ old_entries = set->entries;
+ old_size = set->size;
+
+ if (set->n_items < set->lower)
+ {
+ /* rehashing is not triggered when i <= min_size */
+ i = set->size_index;
+ do
+ --i;
+ while (i > set->min_size_index
+ && set->n_items < hashset_size[i] / 4);
+ }
+ else
+ {
+ i = set->size_index + 1;
+ 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 ();
+ }
+
+ new_size = hashset_size[i];
+ new_entries = scm_gc_malloc_pointerless (new_size * sizeof(scm_t_weak_entry),
+ "weak set");
+ memset (new_entries, 0, new_size * sizeof(scm_t_weak_entry));
+
+ set->size_index = i;
+ set->size = new_size;
+ if (i <= 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], &copy);
+
+ 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 ((GC_PTR) &new_entries[new_k].key,
+ (GC_PTR) new_entries[new_k].key);
+ }
+}
+
+/* Run after GC 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], &copy);
+
+ 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], &copy);
+
+ 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], &copy);
+
+ 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 ((GC_PTR) &entries[k].key,
+ (GC_PTR) SCM_HEAP_OBJECT_BASE (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], &copy);
+
+ 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 ((GC_PTR) &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);
+
+ if (scm_i_pthread_mutex_trylock (&s->lock) == 0)
+ {
+ vacuum_weak_set (s);
+ scm_i_pthread_mutex_unlock (&s->lock);
+ }
+
+ return;
+}
+
+/* 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 (SCM_PACK_POINTER (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] = SCM_UNPACK_POINTER (obj);
+ weak[1] = (void*)callback;
+ GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM_HEAP_OBJECT_BASE (obj));
+
+#ifdef HAVE_GC_SET_START_CALLBACK
+ scm_c_hook_add (&scm_after_gc_c_hook, weak_gc_hook, weak, 0);
+#else
+ GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_finalizer, NULL, NULL, NULL);
+#endif
+}
+
+SCM
+scm_c_make_weak_set (unsigned long k)
+{
+ SCM ret;
+
+ ret = make_weak_set (k);
+
+ scm_c_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], &copy);
+
+ 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..47d65e69c
--- /dev/null
+++ b/libguile/weak-table.c
@@ -0,0 +1,1160 @@
+/* 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
+ */
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <assert.h>
+
+#include "libguile/bdw-gc.h"
+#include <gc/gc_mark.h>
+
+#include "libguile/_scm.h"
+#include "libguile/hash.h"
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+
+#include "libguile/validate.h"
+#include "libguile/weak-table.h"
+
+
+/* Weak Tables
+
+ This file implements weak hash tables. Weak hash tables are
+ generally used when you want to augment some object with additional
+ data, but when you don't have space to store the data in the object.
+ For example, procedure properties are implemented with weak tables.
+
+ Weak tables are implemented using an open-addressed hash table.
+ Basically this means that there is an array of entries, and the item
+ is expected to be found the slot corresponding to its hash code,
+ modulo the length of the array.
+
+ Collisions are handled using linear probing with the Robin Hood
+ technique. See Pedro Celis' paper, "Robin Hood Hashing":
+
+ http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf
+
+ The vector of entries is allocated in such a way that the GC doesn't
+ trace the weak values. For doubly-weak tables, this means that the
+ entries are allocated as an "atomic" piece of memory. Key-weak and
+ value-weak tables use a special GC kind with a custom mark procedure.
+ When items are added weakly into table, a disappearing link is
+ registered to their locations. If the referent is collected, then
+ that link will be zeroed out.
+
+ An entry in the table consists of the key and the value, together
+ with the hash code of the key. We munge hash codes so that they are
+ never 0. In this way we can detect removed entries (key of zero but
+ nonzero hash code), and can then reshuffle elements as needed to
+ maintain the robin hood ordering.
+
+ Compared to buckets-and-chains hash tables, open addressing has the
+ advantage that it is very cache-friendly. It also uses less memory.
+
+ Implementation-wise, there are two things to note.
+
+ 1. We assume that hash codes are evenly distributed across the
+ range of unsigned longs. The actual hash code stored in the
+ entry is left-shifted by 1 bit (losing 1 bit of hash precision),
+ and then or'd with 1. In this way we ensure that the hash field
+ of an occupied entry is nonzero. To map to an index, we
+ right-shift the hash by one, divide by the size, and take the
+ remainder.
+
+ 2. Since the weak references are stored in an atomic region with
+ disappearing links, they need to be accessed with the GC alloc
+ lock. `copy_weak_entry' will do that for you. The hash code
+ itself can be read outside the lock, though.
+ */
+
+
+typedef struct {
+ unsigned long hash;
+ scm_t_bits key;
+ scm_t_bits value;
+} scm_t_weak_entry;
+
+
+struct weak_entry_data {
+ scm_t_weak_entry *in;
+ scm_t_weak_entry *out;
+};
+
+static void*
+do_copy_weak_entry (void *data)
+{
+ struct weak_entry_data *e = data;
+
+ e->out->hash = e->in->hash;
+ e->out->key = e->in->key;
+ e->out->value = e->in->value;
+
+ return NULL;
+}
+
+static void
+copy_weak_entry (scm_t_weak_entry *src, scm_t_weak_entry *dst)
+{
+ struct weak_entry_data data;
+
+ data.in = src;
+ data.out = dst;
+
+ GC_call_with_alloc_lock (do_copy_weak_entry, &data);
+}
+
+static void
+register_disappearing_links (scm_t_weak_entry *entry,
+ SCM k, SCM v,
+ scm_t_weak_table_kind kind)
+{
+ if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k)
+ && (kind == SCM_WEAK_TABLE_KIND_KEY
+ || kind == SCM_WEAK_TABLE_KIND_BOTH))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->key,
+ (GC_PTR) SCM_HEAP_OBJECT_BASE (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 ((GC_PTR) &entry->value,
+ (GC_PTR) SCM_HEAP_OBJECT_BASE (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 ((GC_PTR) &entry->key);
+
+ if (kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ GC_unregister_disappearing_link ((GC_PTR) &entry->value);
+}
+
+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))
+ {
+#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
+ GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
+#else
+ GC_unregister_disappearing_link (&from->key);
+ SCM_I_REGISTER_DISAPPEARING_LINK (&to->key, SCM_HEAP_OBJECT_BASE (key));
+#endif
+ }
+
+ if ((kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ && SCM_HEAP_OBJECT_P (value))
+ {
+#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
+ GC_move_disappearing_link ((GC_PTR) &from->value, (GC_PTR) &to->value);
+#else
+ GC_unregister_disappearing_link (&from->value);
+ SCM_I_REGISTER_DISAPPEARING_LINK (&to->value, SCM_HEAP_OBJECT_BASE (value));
+#endif
+ }
+}
+
+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, &copy);
+ 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], &copy);
+
+ 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*) SCM_HEAP_OBJECT_BASE (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*) SCM_HEAP_OBJECT_BASE (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 void
+resize_table (scm_t_weak_table *table)
+{
+ scm_t_weak_entry *old_entries, *new_entries;
+ int i;
+ unsigned long old_size, new_size, old_k;
+
+ old_entries = table->entries;
+ old_size = table->size;
+
+ if (table->n_items < table->lower)
+ {
+ /* rehashing is not triggered when i <= min_size */
+ i = table->size_index;
+ do
+ --i;
+ while (i > table->min_size_index
+ && table->n_items < hashtable_size[i] / 4);
+ }
+ else
+ {
+ i = table->size_index + 1;
+ 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 ();
+ }
+
+ new_size = hashtable_size[i];
+ new_entries = allocate_entries (new_size, table->kind);
+
+ table->size_index = i;
+ table->size = new_size;
+ if (i <= 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], &copy);
+
+ 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], &copy);
+
+ 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], &copy);
+
+ 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], &copy);
+
+ 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], &copy);
+
+ 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);
+
+ if (scm_i_pthread_mutex_trylock (&t->lock) == 0)
+ {
+ vacuum_weak_table (t);
+ scm_i_pthread_mutex_unlock (&t->lock);
+ }
+
+ return;
+}
+
+/* The before-gc C hook only runs if GC_table_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 (SCM_PACK_POINTER (val));
+
+ return 1;
+}
+
+#ifdef HAVE_GC_TABLE_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] = SCM_UNPACK_POINTER (obj);
+ weak[1] = (void*)callback;
+ GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM_HEAP_OBJECT_BASE (obj));
+
+#ifdef HAVE_GC_TABLE_START_CALLBACK
+ scm_c_hook_add (&scm_after_gc_c_hook, weak_gc_hook, weak, 0);
+#else
+ GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_finalizer, NULL, NULL, NULL);
+#endif
+}
+
+SCM
+scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
+{
+ SCM ret;
+
+ ret = make_weak_table (k, kind);
+
+ scm_c_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);
+}
+
+SCM
+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);
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+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));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+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);
+
+ return SCM_UNSPECIFIED;
+}
+#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], &copy);
+
+ 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;
+}
+
+SCM
+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);
+
+ return SCM_UNSPECIFIED;
+}
+#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..cb2831c3a
--- /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 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * 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 SCM scm_weak_table_putq_x (SCM table, SCM key, SCM value);
+SCM_INTERNAL SCM scm_weak_table_remq_x (SCM table, SCM key);
+
+SCM_INTERNAL SCM 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 SCM 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..f829d3617
--- /dev/null
+++ b/libguile/weak-vector.c
@@ -0,0 +1,207 @@
+/* Copyright (C) 1995,1996,1998,2000,2001, 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
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+
+#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 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 ((GC_PTR) &elts[k]);
+
+ elts[k] = x;
+
+ if (SCM_HEAP_OBJECT_P (x))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &elts[k],
+ (GC_PTR) SCM_HEAP_OBJECT_BASE (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 92d351e51..000000000
--- a/libguile/weaks.c
+++ /dev/null
@@ -1,294 +0,0 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 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
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <stdio.h>
-
-#include "libguile/_scm.h"
-#include "libguile/vectors.h"
-#include "libguile/hashtab.h"
-
-#include "libguile/validate.h"
-#include "libguile/weaks.h"
-
-#include "libguile/bdw-gc.h"
-#include <gc/gc_typed.h>
-
-
-
-/* Weak pairs for use in weak alist vectors and weak hash tables.
-
- We have weal-car pairs, weak-cdr pairs, and doubly weak pairs. In weak
- pairs, the weak component(s) are not scanned for pointers and are
- registered as disapperaring links; therefore, the weak component may be
- set to NULL by the garbage collector when no other reference to that word
- exist. Thus, users should only access weak pairs via the
- `SCM_WEAK_PAIR_C[AD]R ()' macros. See also `scm_fixup_weak_alist ()' in
- `hashtab.c'. */
-
-/* Type descriptors for weak-c[ad]r pairs. */
-static GC_descr wcar_pair_descr, wcdr_pair_descr;
-
-
-SCM
-scm_weak_car_pair (SCM car, SCM cdr)
-{
- scm_t_cell *cell;
-
- cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
- wcar_pair_descr);
-
- cell->word_0 = car;
- cell->word_1 = cdr;
-
- if (SCM_NIMP (car))
- /* Weak car cells make sense iff the car is non-immediate. */
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
- (GC_PTR) 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 ((GC_PTR) &cell->word_1,
- (GC_PTR) 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 ((GC_PTR) &cell->word_0,
- (GC_PTR) SCM2PTR (car));
- if (SCM_NIMP (cdr))
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
- (GC_PTR) 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 bea3e0824..ea7feade6 100644
--- a/m4/gnulib-cache.m4
+++ b/m4/gnulib-cache.m4
@@ -69,6 +69,7 @@ gl_MODULES([
inet_pton
isinf
isnan
+ largefile
ldexp
lib-symbol-versions
lib-symbol-visibility
diff --git a/meta/Makefile.am b/meta/Makefile.am
index f26fc4436..5b811c06f 100644
--- a/meta/Makefile.am
+++ b/meta/Makefile.am
@@ -23,7 +23,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'.
@@ -32,7 +32,7 @@ install-data-hook:
$(LN_S) guild$(EXEEXT) guile-tools$(EXEEXT)
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
index 6d8c36b18..6d8c36b18 100644
--- a/meta/guile-2.0-uninstalled.pc.in
+++ b/meta/guile-2.2-uninstalled.pc.in
diff --git a/meta/guile-2.0.pc.in b/meta/guile-2.2.pc.in
index ecca778e1..ecca778e1 100644
--- a/meta/guile-2.0.pc.in
+++ b/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 <jim@red-bean.com> --- September 1997
;;;;
-;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -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/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index d006d4700..0de5eed60 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -867,15 +867,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)))))
@@ -954,16 +950,13 @@ VALUE."
;; 0: type-name, 1: fields, 2: constructor
(define record-type-vtable
- ;; FIXME: This should just call make-vtable, not make-vtable-vtable; but for
- ;; that we need to expose the bare vtable-vtable to Scheme.
- (make-vtable-vtable "prprpw" 0
- (lambda (s p)
- (cond ((eq? s record-type-vtable)
- (display "#<record-type-vtable>" p))
- (else
- (display "#<record-type " p)
- (display (record-type-name s) p)
- (display ">" p))))))
+ (let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
+ (lambda (s p)
+ (display "#<record-type " p)
+ (display (record-type-name s) p)
+ (display ">" p)))))
+ (set-struct-vtable-name! s 'record-type)
+ s))
(define (record-type? obj)
(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
@@ -1574,7 +1567,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)))
@@ -2051,33 +2044,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}
@@ -3270,13 +3236,6 @@ module '(ice-9 q) '(make-q q-length))}."
(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)
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index ef2bc2422..6b39e7a7c 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2005, 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
@@ -16,866 +16,4 @@
;;;;
(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))
-
-
-;;;; 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 ...)))))
+ #:export ())
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index c0fa64c90..5b2937147 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
+;;;; Copyright (C) 2009, 2010, 2011
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -399,14 +399,11 @@
0 #f '() #f)
(apply make-general-closure (capture-env env) body nreq tail))))
- (('begin (first . rest))
- (let lp ((first first) (rest rest))
- (if (null? rest)
- (eval first env)
- (begin
- (eval first env)
- (lp (car rest) (cdr rest))))))
-
+ (('seq (head . tail))
+ (begin
+ (eval head env)
+ (eval tail env)))
+
(('lexical-set! (n . x))
(let ((val (eval x env)))
(list-set! env n val)))
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 3e17e62b4..43a2cf567 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -1,10614 +1,11177 @@
(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
(if #f #f)
-(let ((#{transformer-environment 4436}# (if #f #f)))
- (letrec*
- ((#{top-level-eval-hook 4375}#
- (lambda (#{x 26114}# #{mod 26115}#)
- (primitive-eval #{x 26114}#)))
- (#{get-global-definition-hook 4378}#
- (lambda (#{symbol 15434}# #{module 15435}#)
- (begin
- (if (if (not #{module 15435}#) (current-module) #f)
- (warn "module system is booted, we should have a module"
- #{symbol 15434}#))
- (let ((#{v 15436}#
- (module-variable
- (if #{module 15435}#
- (resolve-module (cdr #{module 15435}#))
- (current-module))
- #{symbol 15434}#)))
- (if #{v 15436}#
- (if (variable-bound? #{v 15436}#)
- (let ((#{val 15438}# (variable-ref #{v 15436}#)))
- (if (macro? #{val 15438}#)
- (if (macro-type #{val 15438}#)
- (cons (macro-type #{val 15438}#)
- (macro-binding #{val 15438}#))
- #f)
- #f))
- #f)
- #f)))))
- (#{maybe-name-value! 4380}#
- (lambda (#{name 15715}# #{val 15716}#)
- (if (if (struct? #{val 15716}#)
- (eq? (struct-vtable #{val 15716}#)
- (vector-ref %expanded-vtables 13))
+(letrec*
+ ((#{top-level-eval-hook 28198}#
+ (lambda (#{x 58998}# #{mod 58999}#)
+ (primitive-eval #{x 58998}#)))
+ (#{maybe-name-value! 28203}#
+ (lambda (#{name 42551}# #{val 42552}#)
+ (if (if (struct? #{val 42552}#)
+ (eq? (struct-vtable #{val 42552}#)
+ (vector-ref %expanded-vtables 14))
+ #f)
+ (let ((#{meta 42559}# (struct-ref #{val 42552}# 1)))
+ (if (not (assq 'name #{meta 42559}#))
+ (let ((#{v 42564}#
+ (cons (cons 'name #{name 42551}#) #{meta 42559}#)))
+ (struct-set! #{val 42552}# 1 #{v 42564}#)))))))
+ (#{build-call 28205}#
+ (lambda (#{source 42296}#
+ #{fun-exp 42297}#
+ #{arg-exps 42298}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 11)
+ #{source 42296}#
+ #{fun-exp 42297}#
+ #{arg-exps 42298}#)))
+ (#{build-conditional 28206}#
+ (lambda (#{source 42304}#
+ #{test-exp 42305}#
+ #{then-exp 42306}#
+ #{else-exp 42307}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 10)
+ #{source 42304}#
+ #{test-exp 42305}#
+ #{then-exp 42306}#
+ #{else-exp 42307}#)))
+ (#{build-dynlet 28207}#
+ (lambda (#{source 42314}#
+ #{fluids 42315}#
+ #{vals 42316}#
+ #{body 42317}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 18)
+ #{source 42314}#
+ #{fluids 42315}#
+ #{vals 42316}#
+ #{body 42317}#)))
+ (#{build-lexical-reference 28208}#
+ (lambda (#{type 59000}#
+ #{source 59001}#
+ #{name 59002}#
+ #{var 59003}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 3)
+ #{source 59001}#
+ #{name 59002}#
+ #{var 59003}#)))
+ (#{build-lexical-assignment 28209}#
+ (lambda (#{source 42324}#
+ #{name 42325}#
+ #{var 42326}#
+ #{exp 42327}#)
+ (begin
+ (if (if (struct? #{exp 42327}#)
+ (eq? (struct-vtable #{exp 42327}#)
+ (vector-ref %expanded-vtables 14))
#f)
- (let ((#{meta 15723}# (struct-ref #{val 15716}# 1)))
- (if (not (assq 'name #{meta 15723}#))
- (let ((#{v 15728}#
- (cons (cons 'name #{name 15715}#) #{meta 15723}#)))
- (struct-set! #{val 15716}# 1 #{v 15728}#)))))))
- (#{build-application 4382}#
- (lambda (#{source 15440}#
- #{fun-exp 15441}#
- #{arg-exps 15442}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #{source 15440}#
- #{fun-exp 15441}#
- #{arg-exps 15442}#)))
- (#{build-conditional 4383}#
- (lambda (#{source 15448}#
- #{test-exp 15449}#
- #{then-exp 15450}#
- #{else-exp 15451}#)
+ (let ((#{meta 42343}# (struct-ref #{exp 42327}# 1)))
+ (if (not (assq 'name #{meta 42343}#))
+ (let ((#{v 42350}#
+ (cons (cons 'name #{name 42325}#) #{meta 42343}#)))
+ (struct-set! #{exp 42327}# 1 #{v 42350}#)))))
(make-struct/no-tail
- (vector-ref %expanded-vtables 10)
- #{source 15448}#
- #{test-exp 15449}#
- #{then-exp 15450}#
- #{else-exp 15451}#)))
- (#{build-dynlet 4384}#
- (lambda (#{source 15458}#
- #{fluids 15459}#
- #{vals 15460}#
- #{body 15461}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 17)
- #{source 15458}#
- #{fluids 15459}#
- #{vals 15460}#
- #{body 15461}#)))
- (#{build-lexical-reference 4385}#
- (lambda (#{type 26116}#
- #{source 26117}#
- #{name 26118}#
- #{var 26119}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- #{source 26117}#
- #{name 26118}#
- #{var 26119}#)))
- (#{build-lexical-assignment 4386}#
- (lambda (#{source 15468}#
- #{name 15469}#
- #{var 15470}#
- #{exp 15471}#)
- (begin
- (if (if (struct? #{exp 15471}#)
- (eq? (struct-vtable #{exp 15471}#)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((#{meta 15487}# (struct-ref #{exp 15471}# 1)))
- (if (not (assq 'name #{meta 15487}#))
- (let ((#{v 15494}#
- (cons (cons 'name #{name 15469}#) #{meta 15487}#)))
- (struct-set! #{exp 15471}# 1 #{v 15494}#)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 4)
- #{source 15468}#
- #{name 15469}#
- #{var 15470}#
- #{exp 15471}#))))
- (#{analyze-variable 4387}#
- (lambda (#{mod 26125}#
- #{var 26126}#
- #{modref-cont 26127}#
- #{bare-cont 26128}#)
- (if (not #{mod 26125}#)
- (#{bare-cont 26128}# #{var 26126}#)
- (let ((#{kind 26129}# (car #{mod 26125}#))
- (#{mod 26130}# (cdr #{mod 26125}#)))
- (if (eqv? #{kind 26129}# 'public)
- (#{modref-cont 26127}#
- #{mod 26130}#
- #{var 26126}#
- #t)
- (if (eqv? #{kind 26129}# 'private)
- (if (not (equal?
- #{mod 26130}#
- (module-name (current-module))))
- (#{modref-cont 26127}#
- #{mod 26130}#
- #{var 26126}#
- #f)
- (#{bare-cont 26128}# #{var 26126}#))
- (if (eqv? #{kind 26129}# 'bare)
- (#{bare-cont 26128}# #{var 26126}#)
- (if (eqv? #{kind 26129}# 'hygiene)
- (if (if (not (equal?
- #{mod 26130}#
- (module-name (current-module))))
- (module-variable
- (resolve-module #{mod 26130}#)
- #{var 26126}#)
- #f)
- (#{modref-cont 26127}#
- #{mod 26130}#
- #{var 26126}#
+ (vector-ref %expanded-vtables 4)
+ #{source 42324}#
+ #{name 42325}#
+ #{var 42326}#
+ #{exp 42327}#))))
+ (#{analyze-variable 28210}#
+ (lambda (#{mod 59009}#
+ #{var 59010}#
+ #{modref-cont 59011}#
+ #{bare-cont 59012}#)
+ (if (not #{mod 59009}#)
+ (#{bare-cont 59012}# #{var 59010}#)
+ (let ((#{kind 59013}# (car #{mod 59009}#))
+ (#{mod 59014}# (cdr #{mod 59009}#)))
+ (if (eqv? #{kind 59013}# 'public)
+ (#{modref-cont 59011}#
+ #{mod 59014}#
+ #{var 59010}#
+ #t)
+ (if (eqv? #{kind 59013}# 'private)
+ (if (not (equal?
+ #{mod 59014}#
+ (module-name (current-module))))
+ (#{modref-cont 59011}#
+ #{mod 59014}#
+ #{var 59010}#
+ #f)
+ (#{bare-cont 59012}# #{var 59010}#))
+ (if (eqv? #{kind 59013}# 'bare)
+ (#{bare-cont 59012}# #{var 59010}#)
+ (if (eqv? #{kind 59013}# 'hygiene)
+ (if (if (not (equal?
+ #{mod 59014}#
+ (module-name (current-module))))
+ (module-variable
+ (resolve-module #{mod 59014}#)
+ #{var 59010}#)
#f)
- (#{bare-cont 26128}# #{var 26126}#))
- (syntax-violation
- #f
- "bad module kind"
- #{var 26126}#
- #{mod 26130}#)))))))))
- (#{build-global-reference 4388}#
- (lambda (#{source 26145}# #{var 26146}# #{mod 26147}#)
- (#{analyze-variable 4387}#
- #{mod 26147}#
- #{var 26146}#
- (lambda (#{mod 26150}# #{var 26151}# #{public? 26152}#)
+ (#{modref-cont 59011}#
+ #{mod 59014}#
+ #{var 59010}#
+ #f)
+ (#{bare-cont 59012}# #{var 59010}#))
+ (syntax-violation
+ #f
+ "bad module kind"
+ #{var 59010}#
+ #{mod 59014}#)))))))))
+ (#{build-global-reference 28211}#
+ (lambda (#{source 59029}# #{var 59030}# #{mod 59031}#)
+ (#{analyze-variable 28210}#
+ #{mod 59031}#
+ #{var 59030}#
+ (lambda (#{mod 59034}# #{var 59035}# #{public? 59036}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 5)
+ #{source 59029}#
+ #{mod 59034}#
+ #{var 59035}#
+ #{public? 59036}#))
+ (lambda (#{var 59043}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 7)
+ #{source 59029}#
+ #{var 59043}#)))))
+ (#{build-global-assignment 28212}#
+ (lambda (#{source 42359}#
+ #{var 42360}#
+ #{exp 42361}#
+ #{mod 42362}#)
+ (begin
+ (if (if (struct? #{exp 42361}#)
+ (eq? (struct-vtable #{exp 42361}#)
+ (vector-ref %expanded-vtables 14))
+ #f)
+ (let ((#{meta 42378}# (struct-ref #{exp 42361}# 1)))
+ (if (not (assq 'name #{meta 42378}#))
+ (let ((#{v 42385}#
+ (cons (cons 'name #{var 42360}#) #{meta 42378}#)))
+ (struct-set! #{exp 42361}# 1 #{v 42385}#)))))
+ (#{analyze-variable 28210}#
+ #{mod 42362}#
+ #{var 42360}#
+ (lambda (#{mod 42390}# #{var 42391}# #{public? 42392}#)
(make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #{source 26145}#
- #{mod 26150}#
- #{var 26151}#
- #{public? 26152}#))
- (lambda (#{var 26160}#)
+ (vector-ref %expanded-vtables 6)
+ #{source 42359}#
+ #{mod 42390}#
+ #{var 42391}#
+ #{public? 42392}#
+ #{exp 42361}#))
+ (lambda (#{var 42400}#)
(make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #{source 26145}#
- #{var 26160}#)))))
- (#{build-global-assignment 4389}#
- (lambda (#{source 15503}#
- #{var 15504}#
- #{exp 15505}#
- #{mod 15506}#)
- (begin
- (if (if (struct? #{exp 15505}#)
- (eq? (struct-vtable #{exp 15505}#)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((#{meta 15522}# (struct-ref #{exp 15505}# 1)))
- (if (not (assq 'name #{meta 15522}#))
- (let ((#{v 15529}#
- (cons (cons 'name #{var 15504}#) #{meta 15522}#)))
- (struct-set! #{exp 15505}# 1 #{v 15529}#)))))
- (#{analyze-variable 4387}#
- #{mod 15506}#
- #{var 15504}#
- (lambda (#{mod 15534}# #{var 15535}# #{public? 15536}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 6)
- #{source 15503}#
- #{mod 15534}#
- #{var 15535}#
- #{public? 15536}#
- #{exp 15505}#))
- (lambda (#{var 15544}#)
+ (vector-ref %expanded-vtables 8)
+ #{source 42359}#
+ #{var 42400}#
+ #{exp 42361}#))))))
+ (#{build-global-definition 28213}#
+ (lambda (#{source 59048}# #{var 59049}# #{exp 59050}#)
+ (begin
+ (if (if (struct? #{exp 59050}#)
+ (eq? (struct-vtable #{exp 59050}#)
+ (vector-ref %expanded-vtables 14))
+ #f)
+ (let ((#{meta 59066}# (struct-ref #{exp 59050}# 1)))
+ (if (not (assq 'name #{meta 59066}#))
+ (let ((#{v 59073}#
+ (cons (cons 'name #{var 59049}#) #{meta 59066}#)))
+ (struct-set! #{exp 59050}# 1 #{v 59073}#)))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 9)
+ #{source 59048}#
+ #{var 59049}#
+ #{exp 59050}#))))
+ (#{build-simple-lambda 28214}#
+ (lambda (#{src 42406}#
+ #{req 42407}#
+ #{rest 42408}#
+ #{vars 42409}#
+ #{meta 42410}#
+ #{exp 42411}#)
+ (let ((#{body 42417}#
(make-struct/no-tail
- (vector-ref %expanded-vtables 8)
- #{source 15503}#
- #{var 15544}#
- #{exp 15505}#))))))
- (#{build-global-definition 4390}#
- (lambda (#{source 26166}# #{var 26167}# #{exp 26168}#)
- (begin
- (if (if (struct? #{exp 26168}#)
- (eq? (struct-vtable #{exp 26168}#)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((#{meta 26184}# (struct-ref #{exp 26168}# 1)))
- (if (not (assq 'name #{meta 26184}#))
- (let ((#{v 26191}#
- (cons (cons 'name #{var 26167}#) #{meta 26184}#)))
- (struct-set! #{exp 26168}# 1 #{v 26191}#)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 9)
- #{source 26166}#
- #{var 26167}#
- #{exp 26168}#))))
- (#{build-simple-lambda 4391}#
- (lambda (#{src 15550}#
- #{req 15551}#
- #{rest 15552}#
- #{vars 15553}#
- #{meta 15554}#
- #{exp 15555}#)
- (let ((#{body 15561}#
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #{src 15550}#
- #{req 15551}#
- #f
- #{rest 15552}#
+ (vector-ref %expanded-vtables 15)
+ #{src 42406}#
+ #{req 42407}#
+ #f
+ #{rest 42408}#
+ #f
+ '()
+ #{vars 42409}#
+ #{exp 42411}#
+ #f)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 14)
+ #{src 42406}#
+ #{meta 42410}#
+ #{body 42417}#))))
+ (#{build-primcall 28217}#
+ (lambda (#{src 42429}# #{name 42430}# #{args 42431}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 12)
+ #{src 42429}#
+ #{name 42430}#
+ #{args 42431}#)))
+ (#{build-sequence 28220}#
+ (lambda (#{src 59081}# #{exps 59082}#)
+ (if (null? (cdr #{exps 59082}#))
+ (car #{exps 59082}#)
+ (let ((#{head 59086}# (car #{exps 59082}#))
+ (#{tail 59087}#
+ (#{build-sequence 28220}#
#f
- '()
- #{vars 15553}#
- #{exp 15555}#
- #f)))
+ (cdr #{exps 59082}#))))
(make-struct/no-tail
(vector-ref %expanded-vtables 13)
- #{src 15550}#
- #{meta 15554}#
- #{body 15561}#))))
- (#{build-sequence 4396}#
- (lambda (#{src 26199}# #{exps 26200}#)
- (if (null? (cdr #{exps 26200}#))
- (car #{exps 26200}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 12)
- #{src 26199}#
- #{exps 26200}#))))
- (#{build-let 4397}#
- (lambda (#{src 15573}#
- #{ids 15574}#
- #{vars 15575}#
- #{val-exps 15576}#
- #{body-exp 15577}#)
- (begin
- (for-each
- #{maybe-name-value! 4380}#
- #{ids 15574}#
- #{val-exps 15576}#)
- (if (null? #{vars 15575}#)
- #{body-exp 15577}#
- (make-struct/no-tail
- (vector-ref %expanded-vtables 15)
- #{src 15573}#
- #{ids 15574}#
- #{vars 15575}#
- #{val-exps 15576}#
- #{body-exp 15577}#)))))
- (#{build-named-let 4398}#
- (lambda (#{src 15601}#
- #{ids 15602}#
- #{vars 15603}#
- #{val-exps 15604}#
- #{body-exp 15605}#)
- (let ((#{f 15606}# (car #{vars 15603}#))
- (#{f-name 15607}# (car #{ids 15602}#))
- (#{vars 15608}# (cdr #{vars 15603}#))
- (#{ids 15609}# (cdr #{ids 15602}#)))
- (let ((#{proc 15610}#
- (let ((#{body 15630}#
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #{src 15601}#
- #{ids 15609}#
- #f
- #f
- #f
- '()
- #{vars 15608}#
- #{body-exp 15605}#
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- #{src 15601}#
- '()
- #{body 15630}#))))
- (begin
- (if (if (struct? #{proc 15610}#)
- (eq? (struct-vtable #{proc 15610}#)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((#{meta 15654}# (struct-ref #{proc 15610}# 1)))
- (if (not (assq 'name #{meta 15654}#))
- (let ((#{v 15661}#
- (cons (cons 'name #{f-name 15607}#)
- #{meta 15654}#)))
- (struct-set! #{proc 15610}# 1 #{v 15661}#)))))
- (for-each
- #{maybe-name-value! 4380}#
- #{ids 15609}#
- #{val-exps 15604}#)
- (let ((#{names 15685}# (list #{f-name 15607}#))
- (#{gensyms 15686}# (list #{f 15606}#))
- (#{vals 15687}# (list #{proc 15610}#))
- (#{body 15688}#
- (let ((#{fun-exp 15692}#
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- #{src 15601}#
- #{f-name 15607}#
- #{f 15606}#)))
+ #{src 59081}#
+ #{head 59086}#
+ #{tail 59087}#)))))
+ (#{build-named-let 28222}#
+ (lambda (#{src 42437}#
+ #{ids 42438}#
+ #{vars 42439}#
+ #{val-exps 42440}#
+ #{body-exp 42441}#)
+ (let ((#{f 42442}# (car #{vars 42439}#))
+ (#{f-name 42443}# (car #{ids 42438}#))
+ (#{vars 42444}# (cdr #{vars 42439}#))
+ (#{ids 42445}# (cdr #{ids 42438}#)))
+ (let ((#{proc 42446}#
+ (let ((#{body 42466}#
(make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #{src 15601}#
- #{fun-exp 15692}#
- #{val-exps 15604}#))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 16)
- #{src 15601}#
- #f
- #{names 15685}#
- #{gensyms 15686}#
- #{vals 15687}#
- #{body 15688}#)))))))
- (#{build-letrec 4399}#
- (lambda (#{src 15708}#
- #{in-order? 15709}#
- #{ids 15710}#
- #{vars 15711}#
- #{val-exps 15712}#
- #{body-exp 15713}#)
- (if (null? #{vars 15711}#)
- #{body-exp 15713}#
+ (vector-ref %expanded-vtables 15)
+ #{src 42437}#
+ #{ids 42445}#
+ #f
+ #f
+ #f
+ '()
+ #{vars 42444}#
+ #{body-exp 42441}#
+ #f)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 14)
+ #{src 42437}#
+ '()
+ #{body 42466}#))))
(begin
+ (if (if (struct? #{proc 42446}#)
+ (eq? (struct-vtable #{proc 42446}#)
+ (vector-ref %expanded-vtables 14))
+ #f)
+ (let ((#{meta 42490}# (struct-ref #{proc 42446}# 1)))
+ (if (not (assq 'name #{meta 42490}#))
+ (let ((#{v 42497}#
+ (cons (cons 'name #{f-name 42443}#)
+ #{meta 42490}#)))
+ (struct-set! #{proc 42446}# 1 #{v 42497}#)))))
(for-each
- #{maybe-name-value! 4380}#
- #{ids 15710}#
- #{val-exps 15712}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 16)
- #{src 15708}#
- #{in-order? 15709}#
- #{ids 15710}#
- #{vars 15711}#
- #{val-exps 15712}#
- #{body-exp 15713}#)))))
- (#{source-annotation 4408}#
- (lambda (#{x 15739}#)
- (if (if (vector? #{x 15739}#)
- (if (= (vector-length #{x 15739}#) 4)
- (eq? (vector-ref #{x 15739}# 0) 'syntax-object)
+ #{maybe-name-value! 28203}#
+ #{ids 42445}#
+ #{val-exps 42440}#)
+ (let ((#{names 42521}# (list #{f-name 42443}#))
+ (#{gensyms 42522}# (list #{f 42442}#))
+ (#{vals 42523}# (list #{proc 42446}#))
+ (#{body 42524}#
+ (let ((#{fun-exp 42528}#
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 3)
+ #{src 42437}#
+ #{f-name 42443}#
+ #{f 42442}#)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 11)
+ #{src 42437}#
+ #{fun-exp 42528}#
+ #{val-exps 42440}#))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 17)
+ #{src 42437}#
+ #f
+ #{names 42521}#
+ #{gensyms 42522}#
+ #{vals 42523}#
+ #{body 42524}#)))))))
+ (#{build-letrec 28223}#
+ (lambda (#{src 42544}#
+ #{in-order? 42545}#
+ #{ids 42546}#
+ #{vars 42547}#
+ #{val-exps 42548}#
+ #{body-exp 42549}#)
+ (if (null? #{vars 42547}#)
+ #{body-exp 42549}#
+ (begin
+ (for-each
+ #{maybe-name-value! 28203}#
+ #{ids 42546}#
+ #{val-exps 42548}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 17)
+ #{src 42544}#
+ #{in-order? 42545}#
+ #{ids 42546}#
+ #{vars 42547}#
+ #{val-exps 42548}#
+ #{body-exp 42549}#)))))
+ (#{source-annotation 28232}#
+ (lambda (#{x 42575}#)
+ (if (if (vector? #{x 42575}#)
+ (if (= (vector-length #{x 42575}#) 4)
+ (eq? (vector-ref #{x 42575}# 0) 'syntax-object)
+ #f)
+ #f)
+ (#{source-annotation 28232}#
+ (vector-ref #{x 42575}# 1))
+ (if (pair? #{x 42575}#)
+ (let ((#{props 42590}# (source-properties #{x 42575}#)))
+ (if (pair? #{props 42590}#) #{props 42590}# #f))
+ #f))))
+ (#{extend-env 28233}#
+ (lambda (#{labels 42592}# #{bindings 42593}# #{r 42594}#)
+ (if (null? #{labels 42592}#)
+ #{r 42594}#
+ (#{extend-env 28233}#
+ (cdr #{labels 42592}#)
+ (cdr #{bindings 42593}#)
+ (cons (cons (car #{labels 42592}#)
+ (car #{bindings 42593}#))
+ #{r 42594}#)))))
+ (#{extend-var-env 28234}#
+ (lambda (#{labels 42595}# #{vars 42596}# #{r 42597}#)
+ (if (null? #{labels 42595}#)
+ #{r 42597}#
+ (#{extend-var-env 28234}#
+ (cdr #{labels 42595}#)
+ (cdr #{vars 42596}#)
+ (cons (cons (car #{labels 42595}#)
+ (cons 'lexical (car #{vars 42596}#)))
+ #{r 42597}#)))))
+ (#{macros-only-env 28235}#
+ (lambda (#{r 42598}#)
+ (if (null? #{r 42598}#)
+ '()
+ (let ((#{a 42599}# (car #{r 42598}#)))
+ (if (let ((#{t 42602}# (car (cdr #{a 42599}#))))
+ (if (eq? #{t 42602}# 'macro)
+ #t
+ (eq? #{t 42602}# 'syntax-parameter)))
+ (cons #{a 42599}#
+ (#{macros-only-env 28235}# (cdr #{r 42598}#)))
+ (#{macros-only-env 28235}# (cdr #{r 42598}#)))))))
+ (#{global-extend 28236}#
+ (lambda (#{type 42604}# #{sym 42605}# #{val 42606}#)
+ (module-define!
+ (current-module)
+ #{sym 42605}#
+ (make-syntax-transformer
+ #{sym 42605}#
+ #{type 42604}#
+ #{val 42606}#))))
+ (#{id? 28238}#
+ (lambda (#{x 35679}#)
+ (if (symbol? #{x 35679}#)
+ #t
+ (if (if (vector? #{x 35679}#)
+ (if (= (vector-length #{x 35679}#) 4)
+ (eq? (vector-ref #{x 35679}# 0) 'syntax-object)
#f)
#f)
- (#{source-annotation 4408}#
- (vector-ref #{x 15739}# 1))
- (if (pair? #{x 15739}#)
- (let ((#{props 15754}# (source-properties #{x 15739}#)))
- (if (pair? #{props 15754}#) #{props 15754}# #f))
- #f))))
- (#{extend-env 4409}#
- (lambda (#{labels 15756}# #{bindings 15757}# #{r 15758}#)
- (if (null? #{labels 15756}#)
- #{r 15758}#
- (#{extend-env 4409}#
- (cdr #{labels 15756}#)
- (cdr #{bindings 15757}#)
- (cons (cons (car #{labels 15756}#)
- (car #{bindings 15757}#))
- #{r 15758}#)))))
- (#{extend-var-env 4410}#
- (lambda (#{labels 15759}# #{vars 15760}# #{r 15761}#)
- (if (null? #{labels 15759}#)
- #{r 15761}#
- (#{extend-var-env 4410}#
- (cdr #{labels 15759}#)
- (cdr #{vars 15760}#)
- (cons (cons (car #{labels 15759}#)
- (cons 'lexical (car #{vars 15760}#)))
- #{r 15761}#)))))
- (#{macros-only-env 4411}#
- (lambda (#{r 15762}#)
- (if (null? #{r 15762}#)
- '()
- (let ((#{a 15763}# (car #{r 15762}#)))
- (if (eq? (car (cdr #{a 15763}#)) 'macro)
- (cons #{a 15763}#
- (#{macros-only-env 4411}# (cdr #{r 15762}#)))
- (#{macros-only-env 4411}# (cdr #{r 15762}#)))))))
- (#{global-extend 4413}#
- (lambda (#{type 15765}# #{sym 15766}# #{val 15767}#)
- (module-define!
- (current-module)
- #{sym 15766}#
- (make-syntax-transformer
- #{sym 15766}#
- #{type 15765}#
- #{val 15767}#))))
- (#{id? 4415}#
- (lambda (#{x 9800}#)
- (if (symbol? #{x 9800}#)
- #t
- (if (if (vector? #{x 9800}#)
- (if (= (vector-length #{x 9800}#) 4)
- (eq? (vector-ref #{x 9800}# 0) 'syntax-object)
+ (symbol? (vector-ref #{x 35679}# 1))
+ #f))))
+ (#{gen-labels 28241}#
+ (lambda (#{ls 42616}#)
+ (if (null? #{ls 42616}#)
+ '()
+ (cons (symbol->string (gensym "i"))
+ (#{gen-labels 28241}# (cdr #{ls 42616}#))))))
+ (#{make-binding-wrap 28252}#
+ (lambda (#{ids 42620}# #{labels 42621}# #{w 42622}#)
+ (if (null? #{ids 42620}#)
+ #{w 42622}#
+ (cons (car #{w 42622}#)
+ (cons (let ((#{labelvec 42623}#
+ (list->vector #{labels 42621}#)))
+ (let ((#{n 42624}# (vector-length #{labelvec 42623}#)))
+ (let ((#{symnamevec 42625}# (make-vector #{n 42624}#))
+ (#{marksvec 42626}# (make-vector #{n 42624}#)))
+ (begin
+ (letrec*
+ ((#{f 42627}#
+ (lambda (#{ids 42824}# #{i 42825}#)
+ (if (not (null? #{ids 42824}#))
+ (call-with-values
+ (lambda ()
+ (let ((#{x 42828}#
+ (car #{ids 42824}#)))
+ (if (if (vector? #{x 42828}#)
+ (if (= (vector-length
+ #{x 42828}#)
+ 4)
+ (eq? (vector-ref
+ #{x 42828}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (values
+ (vector-ref #{x 42828}# 1)
+ (let ((#{m1 42844}#
+ (car #{w 42622}#))
+ (#{m2 42845}#
+ (car (vector-ref
+ #{x 42828}#
+ 2))))
+ (if (null? #{m2 42845}#)
+ #{m1 42844}#
+ (append
+ #{m1 42844}#
+ #{m2 42845}#))))
+ (values
+ #{x 42828}#
+ (car #{w 42622}#)))))
+ (lambda (#{symname 42865}#
+ #{marks 42866}#)
+ (begin
+ (vector-set!
+ #{symnamevec 42625}#
+ #{i 42825}#
+ #{symname 42865}#)
+ (vector-set!
+ #{marksvec 42626}#
+ #{i 42825}#
+ #{marks 42866}#)
+ (#{f 42627}#
+ (cdr #{ids 42824}#)
+ (#{1+}# #{i 42825}#)))))))))
+ (#{f 42627}# #{ids 42620}# 0))
+ (vector
+ 'ribcage
+ #{symnamevec 42625}#
+ #{marksvec 42626}#
+ #{labelvec 42623}#)))))
+ (cdr #{w 42622}#))))))
+ (#{same-marks? 28256}#
+ (lambda (#{x 59088}# #{y 59089}#)
+ (if (eq? #{x 59088}# #{y 59089}#)
+ (eq? #{x 59088}# #{y 59089}#)
+ (if (not (null? #{x 59088}#))
+ (if (not (null? #{y 59089}#))
+ (if (eq? (car #{x 59088}#) (car #{y 59089}#))
+ (#{same-marks? 28256}#
+ (cdr #{x 59088}#)
+ (cdr #{y 59089}#))
+ #f)
+ #f)
+ #f))))
+ (#{id-var-name 28257}#
+ (lambda (#{id 59097}# #{w 59098}# #{mod 59099}#)
+ (letrec*
+ ((#{search 59100}#
+ (lambda (#{sym 59166}#
+ #{subst 59167}#
+ #{marks 59168}#
+ #{mod 59169}#)
+ (if (null? #{subst 59167}#)
+ (values #f #{marks 59168}#)
+ (let ((#{fst 59170}# (car #{subst 59167}#)))
+ (if (eq? #{fst 59170}# 'shift)
+ (#{search 59100}#
+ #{sym 59166}#
+ (cdr #{subst 59167}#)
+ (cdr #{marks 59168}#)
+ #{mod 59169}#)
+ (let ((#{symnames 59172}# (vector-ref #{fst 59170}# 1)))
+ (if (vector? #{symnames 59172}#)
+ (#{search-vector-rib 59102}#
+ #{sym 59166}#
+ #{subst 59167}#
+ #{marks 59168}#
+ #{symnames 59172}#
+ #{fst 59170}#
+ #{mod 59169}#)
+ (#{search-list-rib 59101}#
+ #{sym 59166}#
+ #{subst 59167}#
+ #{marks 59168}#
+ #{symnames 59172}#
+ #{fst 59170}#
+ #{mod 59169}#))))))))
+ (#{search-list-rib 59101}#
+ (lambda (#{sym 59347}#
+ #{subst 59348}#
+ #{marks 59349}#
+ #{symnames 59350}#
+ #{ribcage 59351}#
+ #{mod 59352}#)
+ (letrec*
+ ((#{f 59353}#
+ (lambda (#{symnames 59356}# #{i 59357}#)
+ (if (null? #{symnames 59356}#)
+ (#{search 59100}#
+ #{sym 59347}#
+ (cdr #{subst 59348}#)
+ #{marks 59349}#
+ #{mod 59352}#)
+ (if (if (eq? (car #{symnames 59356}#) #{sym 59347}#)
+ (#{same-marks? 28256}#
+ #{marks 59349}#
+ (list-ref
+ (vector-ref #{ribcage 59351}# 2)
+ #{i 59357}#))
+ #f)
+ (let ((#{n 59503}#
+ (list-ref
+ (vector-ref #{ribcage 59351}# 3)
+ #{i 59357}#)))
+ (if (pair? #{n 59503}#)
+ (if (equal? #{mod 59352}# (car #{n 59503}#))
+ (values (cdr #{n 59503}#) #{marks 59349}#)
+ (#{f 59353}#
+ (cdr #{symnames 59356}#)
+ (#{1+}# #{i 59357}#)))
+ (values #{n 59503}# #{marks 59349}#)))
+ (#{f 59353}#
+ (cdr #{symnames 59356}#)
+ (#{1+}# #{i 59357}#)))))))
+ (#{f 59353}# #{symnames 59350}# 0))))
+ (#{search-vector-rib 59102}#
+ (lambda (#{sym 59508}#
+ #{subst 59509}#
+ #{marks 59510}#
+ #{symnames 59511}#
+ #{ribcage 59512}#
+ #{mod 59513}#)
+ (let ((#{n 59514}# (vector-length #{symnames 59511}#)))
+ (letrec*
+ ((#{f 59515}#
+ (lambda (#{i 59518}#)
+ (if (= #{i 59518}# #{n 59514}#)
+ (#{search 59100}#
+ #{sym 59508}#
+ (cdr #{subst 59509}#)
+ #{marks 59510}#
+ #{mod 59513}#)
+ (if (if (eq? (vector-ref
+ #{symnames 59511}#
+ #{i 59518}#)
+ #{sym 59508}#)
+ (#{same-marks? 28256}#
+ #{marks 59510}#
+ (vector-ref
+ (vector-ref #{ribcage 59512}# 2)
+ #{i 59518}#))
+ #f)
+ (let ((#{n 59665}#
+ (vector-ref
+ (vector-ref #{ribcage 59512}# 3)
+ #{i 59518}#)))
+ (if (pair? #{n 59665}#)
+ (if (equal? #{mod 59513}# (car #{n 59665}#))
+ (values (cdr #{n 59665}#) #{marks 59510}#)
+ (#{f 59515}# (#{1+}# #{i 59518}#)))
+ (values #{n 59665}# #{marks 59510}#)))
+ (#{f 59515}# (#{1+}# #{i 59518}#)))))))
+ (#{f 59515}# 0))))))
+ (if (symbol? #{id 59097}#)
+ (let ((#{t 59103}#
+ (#{search 59100}#
+ #{id 59097}#
+ (cdr #{w 59098}#)
+ (car #{w 59098}#)
+ #{mod 59099}#)))
+ (if #{t 59103}# #{t 59103}# #{id 59097}#))
+ (if (if (vector? #{id 59097}#)
+ (if (= (vector-length #{id 59097}#) 4)
+ (eq? (vector-ref #{id 59097}# 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref #{x 9800}# 1))
- #f))))
- (#{gen-labels 4418}#
- (lambda (#{ls 15777}#)
- (if (null? #{ls 15777}#)
- '()
- (cons (symbol->string (gensym "i"))
- (#{gen-labels 4418}# (cdr #{ls 15777}#))))))
- (#{make-binding-wrap 4429}#
- (lambda (#{ids 15781}# #{labels 15782}# #{w 15783}#)
- (if (null? #{ids 15781}#)
- #{w 15783}#
- (cons (car #{w 15783}#)
- (cons (let ((#{labelvec 15784}#
- (list->vector #{labels 15782}#)))
- (let ((#{n 15785}#
- (vector-length #{labelvec 15784}#)))
- (let ((#{symnamevec 15786}#
- (make-vector #{n 15785}#))
- (#{marksvec 15787}#
- (make-vector #{n 15785}#)))
- (begin
- (letrec*
- ((#{f 15788}#
- (lambda (#{ids 15791}# #{i 15792}#)
- (if (not (null? #{ids 15791}#))
- (call-with-values
- (lambda ()
- (let ((#{x 15795}#
- (car #{ids 15791}#)))
- (if (if (vector? #{x 15795}#)
- (if (= (vector-length
- #{x 15795}#)
- 4)
- (eq? (vector-ref
- #{x 15795}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (values
- (vector-ref #{x 15795}# 1)
- (let ((#{m1 15811}#
- (car #{w 15783}#))
- (#{m2 15812}#
- (car (vector-ref
- #{x 15795}#
- 2))))
- (if (null? #{m2 15812}#)
- #{m1 15811}#
- (append
- #{m1 15811}#
- #{m2 15812}#))))
- (values
- #{x 15795}#
- (car #{w 15783}#)))))
- (lambda (#{symname 15832}#
- #{marks 15833}#)
- (begin
- (vector-set!
- #{symnamevec 15786}#
- #{i 15792}#
- #{symname 15832}#)
- (vector-set!
- #{marksvec 15787}#
- #{i 15792}#
- #{marks 15833}#)
- (#{f 15788}#
- (cdr #{ids 15791}#)
- (#{1+}# #{i 15792}#)))))))))
- (#{f 15788}# #{ids 15781}# 0))
- (vector
- 'ribcage
- #{symnamevec 15786}#
- #{marksvec 15787}#
- #{labelvec 15784}#)))))
- (cdr #{w 15783}#))))))
- (#{join-wraps 4431}#
- (lambda (#{w1 15842}# #{w2 15843}#)
- (let ((#{m1 15844}# (car #{w1 15842}#))
- (#{s1 15845}# (cdr #{w1 15842}#)))
- (if (null? #{m1 15844}#)
- (if (null? #{s1 15845}#)
- #{w2 15843}#
- (cons (car #{w2 15843}#)
- (let ((#{m2 15852}# (cdr #{w2 15843}#)))
- (if (null? #{m2 15852}#)
- #{s1 15845}#
- (append #{s1 15845}# #{m2 15852}#)))))
- (cons (let ((#{m2 15861}# (car #{w2 15843}#)))
- (if (null? #{m2 15861}#)
- #{m1 15844}#
- (append #{m1 15844}# #{m2 15861}#)))
- (let ((#{m2 15870}# (cdr #{w2 15843}#)))
- (if (null? #{m2 15870}#)
- #{s1 15845}#
- (append #{s1 15845}# #{m2 15870}#))))))))
- (#{same-marks? 4433}#
- (lambda (#{x 15875}# #{y 15876}#)
- (if (eq? #{x 15875}# #{y 15876}#)
- (eq? #{x 15875}# #{y 15876}#)
- (if (not (null? #{x 15875}#))
- (if (not (null? #{y 15876}#))
- (if (eq? (car #{x 15875}#) (car #{y 15876}#))
- (#{same-marks? 4433}#
- (cdr #{x 15875}#)
- (cdr #{y 15876}#))
+ (let ((#{id 59118}# (vector-ref #{id 59097}# 1))
+ (#{w1 59119}# (vector-ref #{id 59097}# 2))
+ (#{mod 59120}# (vector-ref #{id 59097}# 3)))
+ (let ((#{marks 59121}#
+ (let ((#{m1 59131}# (car #{w 59098}#))
+ (#{m2 59132}# (car #{w1 59119}#)))
+ (if (null? #{m2 59132}#)
+ #{m1 59131}#
+ (append #{m1 59131}# #{m2 59132}#)))))
+ (call-with-values
+ (lambda ()
+ (#{search 59100}#
+ #{id 59118}#
+ (cdr #{w 59098}#)
+ #{marks 59121}#
+ #{mod 59120}#))
+ (lambda (#{new-id 59152}# #{marks 59153}#)
+ (if #{new-id 59152}#
+ #{new-id 59152}#
+ (let ((#{t 59161}#
+ (#{search 59100}#
+ #{id 59118}#
+ (cdr #{w1 59119}#)
+ #{marks 59153}#
+ #{mod 59120}#)))
+ (if #{t 59161}# #{t 59161}# #{id 59118}#)))))))
+ (syntax-violation
+ 'id-var-name
+ "invalid id"
+ #{id 59097}#))))))
+ (#{resolve-identifier 28258}#
+ (lambda (#{id 42873}#
+ #{w 42874}#
+ #{r 42875}#
+ #{mod 42876}#
+ #{resolve-syntax-parameters? 42877}#)
+ (let ((#{n 42881}#
+ (#{id-var-name 28257}#
+ #{id 42873}#
+ #{w 42874}#
+ #{mod 42876}#)))
+ (if (if (vector? #{n 42881}#)
+ (if (= (vector-length #{n 42881}#) 4)
+ (eq? (vector-ref #{n 42881}# 0) 'syntax-object)
#f)
#f)
- #f))))
- (#{id-var-name 4434}#
- (lambda (#{id 15884}# #{w 15885}#)
- (letrec*
- ((#{search 15886}#
- (lambda (#{sym 15947}# #{subst 15948}# #{marks 15949}#)
- (if (null? #{subst 15948}#)
- (values #f #{marks 15949}#)
- (let ((#{fst 15950}# (car #{subst 15948}#)))
- (if (eq? #{fst 15950}# 'shift)
- (#{search 15886}#
- #{sym 15947}#
- (cdr #{subst 15948}#)
- (cdr #{marks 15949}#))
- (let ((#{symnames 15952}# (vector-ref #{fst 15950}# 1)))
- (if (vector? #{symnames 15952}#)
- (let ((#{n 15964}#
- (vector-length #{symnames 15952}#)))
- (letrec*
- ((#{f 15965}#
- (lambda (#{i 15967}#)
- (if (= #{i 15967}# #{n 15964}#)
- (#{search 15886}#
- #{sym 15947}#
- (cdr #{subst 15948}#)
- #{marks 15949}#)
- (if (if (eq? (vector-ref
- #{symnames 15952}#
- #{i 15967}#)
- #{sym 15947}#)
- (#{same-marks? 4433}#
- #{marks 15949}#
- (vector-ref
- (vector-ref #{fst 15950}# 2)
- #{i 15967}#))
- #f)
- (values
- (vector-ref
- (vector-ref #{fst 15950}# 3)
- #{i 15967}#)
- #{marks 15949}#)
- (#{f 15965}# (#{1+}# #{i 15967}#)))))))
- (#{f 15965}# 0)))
- (letrec*
- ((#{f 16000}#
- (lambda (#{symnames 16002}# #{i 16003}#)
- (if (null? #{symnames 16002}#)
- (#{search 15886}#
- #{sym 15947}#
- (cdr #{subst 15948}#)
- #{marks 15949}#)
- (if (if (eq? (car #{symnames 16002}#)
- #{sym 15947}#)
- (#{same-marks? 4433}#
- #{marks 15949}#
- (list-ref
- (vector-ref #{fst 15950}# 2)
- #{i 16003}#))
- #f)
- (values
- (list-ref
- (vector-ref #{fst 15950}# 3)
- #{i 16003}#)
- #{marks 15949}#)
- (#{f 16000}#
- (cdr #{symnames 16002}#)
- (#{1+}# #{i 16003}#)))))))
- (#{f 16000}# #{symnames 15952}# 0))))))))))
- (if (symbol? #{id 15884}#)
- (let ((#{t 15889}#
- (#{search 15886}#
- #{id 15884}#
- (cdr #{w 15885}#)
- (car #{w 15885}#))))
- (if #{t 15889}# #{t 15889}# #{id 15884}#))
- (if (if (vector? #{id 15884}#)
- (if (= (vector-length #{id 15884}#) 4)
- (eq? (vector-ref #{id 15884}# 0) 'syntax-object)
+ (#{resolve-identifier 28258}#
+ #{n 42881}#
+ #{w 42874}#
+ #{r 42875}#
+ #{mod 42876}#
+ #{resolve-syntax-parameters? 42877}#)
+ (if (symbol? #{n 42881}#)
+ (let ((#{mod 42896}#
+ (if (if (vector? #{id 42873}#)
+ (if (= (vector-length #{id 42873}#) 4)
+ (eq? (vector-ref #{id 42873}# 0) 'syntax-object)
+ #f)
+ #f)
+ (vector-ref #{id 42873}# 3)
+ #{mod 42876}#)))
+ (let ((#{b 42897}#
+ (let ((#{b 42900}#
+ (let ((#{t 42901}#
+ (begin
+ (if (if (not #{mod 42896}#)
+ (current-module)
+ #f)
+ (warn "module system is booted, we should have a module"
+ #{n 42881}#))
+ (let ((#{v 42950}#
+ (module-variable
+ (if #{mod 42896}#
+ (resolve-module
+ (cdr #{mod 42896}#))
+ (current-module))
+ #{n 42881}#)))
+ (if #{v 42950}#
+ (if (variable-bound? #{v 42950}#)
+ (let ((#{val 42959}#
+ (variable-ref
+ #{v 42950}#)))
+ (if (macro? #{val 42959}#)
+ (if (macro-type
+ #{val 42959}#)
+ (cons (macro-type
+ #{val 42959}#)
+ (macro-binding
+ #{val 42959}#))
+ #f)
+ #f))
+ #f)
+ #f)))))
+ (if #{t 42901}# #{t 42901}# '(global)))))
+ (if (if #{resolve-syntax-parameters? 42877}#
+ (eq? (car #{b 42900}#) 'syntax-parameter)
+ #f)
+ (let ((#{t 42968}#
+ (assq-ref #{r 42875}# (cdr #{b 42900}#))))
+ (if #{t 42968}#
+ #{t 42968}#
+ (cons 'macro (car (cdr #{b 42900}#)))))
+ #{b 42900}#))))
+ (if (eq? (car #{b 42897}#) 'global)
+ (values 'global #{n 42881}# #{mod 42896}#)
+ (values
+ (car #{b 42897}#)
+ (cdr #{b 42897}#)
+ #{mod 42896}#))))
+ (if (string? #{n 42881}#)
+ (let ((#{mod 42974}#
+ (if (if (vector? #{id 42873}#)
+ (if (= (vector-length #{id 42873}#) 4)
+ (eq? (vector-ref #{id 42873}# 0) 'syntax-object)
+ #f)
+ #f)
+ (vector-ref #{id 42873}# 3)
+ #{mod 42876}#)))
+ (let ((#{b 42975}#
+ (let ((#{b 42978}#
+ (let ((#{t 42979}#
+ (assq-ref #{r 42875}# #{n 42881}#)))
+ (if #{t 42979}#
+ #{t 42979}#
+ '(displaced-lexical)))))
+ (if (if #{resolve-syntax-parameters? 42877}#
+ (eq? (car #{b 42978}#) 'syntax-parameter)
+ #f)
+ (let ((#{t 42980}#
+ (assq-ref #{r 42875}# (cdr #{b 42978}#))))
+ (if #{t 42980}#
+ #{t 42980}#
+ (cons 'macro (car (cdr #{b 42978}#)))))
+ #{b 42978}#))))
+ (values
+ (car #{b 42975}#)
+ (cdr #{b 42975}#)
+ #{mod 42974}#)))
+ (error "unexpected id-var-name"
+ #{id 42873}#
+ #{w 42874}#
+ #{n 42881}#)))))))
+ (#{free-id=? 28259}#
+ (lambda (#{i 42993}# #{j 42994}#)
+ (let ((#{mi 42995}#
+ (if (if (vector? #{i 42993}#)
+ (if (= (vector-length #{i 42993}#) 4)
+ (eq? (vector-ref #{i 42993}# 0) 'syntax-object)
+ #f)
#f)
- #f)
- (let ((#{id 15904}# (vector-ref #{id 15884}# 1))
- (#{w1 15905}# (vector-ref #{id 15884}# 2)))
- (let ((#{marks 15906}#
- (let ((#{m1 15916}# (car #{w 15885}#))
- (#{m2 15917}# (car #{w1 15905}#)))
- (if (null? #{m2 15917}#)
- #{m1 15916}#
- (append #{m1 15916}# #{m2 15917}#)))))
- (call-with-values
- (lambda ()
- (#{search 15886}#
- #{id 15904}#
- (cdr #{w 15885}#)
- #{marks 15906}#))
- (lambda (#{new-id 15933}# #{marks 15934}#)
- (if #{new-id 15933}#
- #{new-id 15933}#
- (let ((#{t 15942}#
- (#{search 15886}#
- #{id 15904}#
- (cdr #{w1 15905}#)
- #{marks 15934}#)))
- (if #{t 15942}# #{t 15942}# #{id 15904}#)))))))
- (syntax-violation
- 'id-var-name
- "invalid id"
- #{id 15884}#))))))
- (#{valid-bound-ids? 4440}#
- (lambda (#{ids 16025}#)
- (if (letrec*
- ((#{all-ids? 16026}#
- (lambda (#{ids 16188}#)
- (if (null? #{ids 16188}#)
- (null? #{ids 16188}#)
- (if (let ((#{x 16199}# (car #{ids 16188}#)))
- (if (symbol? #{x 16199}#)
- #t
- (if (if (vector? #{x 16199}#)
- (if (= (vector-length #{x 16199}#) 4)
- (eq? (vector-ref #{x 16199}# 0)
+ (vector-ref #{i 42993}# 3)
+ #f)))
+ (let ((#{mj 42996}#
+ (if (if (vector? #{j 42994}#)
+ (if (= (vector-length #{j 42994}#) 4)
+ (eq? (vector-ref #{j 42994}# 0) 'syntax-object)
+ #f)
+ #f)
+ (vector-ref #{j 42994}# 3)
+ #f)))
+ (let ((#{ni 42997}#
+ (#{id-var-name 28257}#
+ #{i 42993}#
+ '(())
+ #{mi 42995}#)))
+ (let ((#{nj 42998}#
+ (#{id-var-name 28257}#
+ #{j 42994}#
+ '(())
+ #{mj 42996}#)))
+ (if (if (vector? #{ni 42997}#)
+ (if (= (vector-length #{ni 42997}#) 4)
+ (eq? (vector-ref #{ni 42997}# 0) 'syntax-object)
+ #f)
+ #f)
+ (#{free-id=? 28259}# #{ni 42997}# #{j 42994}#)
+ (if (if (vector? #{nj 42998}#)
+ (if (= (vector-length #{nj 42998}#) 4)
+ (eq? (vector-ref #{nj 42998}# 0) 'syntax-object)
+ #f)
+ #f)
+ (#{free-id=? 28259}# #{i 42993}# #{nj 42998}#)
+ (if (symbol? #{ni 42997}#)
+ (if (eq? #{nj 42998}#
+ (if (if (vector? #{j 42994}#)
+ (if (= (vector-length #{j 42994}#) 4)
+ (eq? (vector-ref #{j 42994}# 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref #{x 16199}# 1))
- #f)))
- (#{all-ids? 16026}# (cdr #{ids 16188}#))
- #f)))))
- (#{all-ids? 16026}# #{ids 16025}#))
- (#{distinct-bound-ids? 4441}# #{ids 16025}#)
- #f)))
- (#{distinct-bound-ids? 4441}#
- (lambda (#{ids 16327}#)
- (letrec*
- ((#{distinct? 16328}#
- (lambda (#{ids 16440}#)
- (if (null? #{ids 16440}#)
- (null? #{ids 16440}#)
- (if (not (#{bound-id-member? 4442}#
- (car #{ids 16440}#)
- (cdr #{ids 16440}#)))
- (#{distinct? 16328}# (cdr #{ids 16440}#))
- #f)))))
- (#{distinct? 16328}# #{ids 16327}#))))
- (#{bound-id-member? 4442}#
- (lambda (#{x 16650}# #{list 16651}#)
- (if (not (null? #{list 16651}#))
- (let ((#{t 16652}#
- (let ((#{j 16733}# (car #{list 16651}#)))
- (if (if (if (vector? #{x 16650}#)
- (if (= (vector-length #{x 16650}#) 4)
- (eq? (vector-ref #{x 16650}# 0)
- 'syntax-object)
- #f)
- #f)
- (if (vector? #{j 16733}#)
- (if (= (vector-length #{j 16733}#) 4)
- (eq? (vector-ref #{j 16733}# 0) 'syntax-object)
- #f)
- #f)
- #f)
- (if (eq? (vector-ref #{x 16650}# 1)
- (vector-ref #{j 16733}# 1))
- (#{same-marks? 4433}#
- (car (vector-ref #{x 16650}# 2))
- (car (vector-ref #{j 16733}# 2)))
+ (vector-ref #{j 42994}# 1)
+ #{j 42994}#))
+ (if (let ((#{bi 43070}#
+ (module-variable
+ (if #{mi 42995}#
+ (resolve-module (cdr #{mi 42995}#))
+ (current-module))
+ (if (if (vector? #{i 42993}#)
+ (if (= (vector-length #{i 42993}#)
+ 4)
+ (eq? (vector-ref #{i 42993}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref #{i 42993}# 1)
+ #{i 42993}#))))
+ (if #{bi 43070}#
+ (eq? #{bi 43070}#
+ (module-variable
+ (if #{mj 42996}#
+ (resolve-module (cdr #{mj 42996}#))
+ (current-module))
+ (if (if (vector? #{j 42994}#)
+ (if (= (vector-length #{j 42994}#)
+ 4)
+ (eq? (vector-ref #{j 42994}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref #{j 42994}# 1)
+ #{j 42994}#)))
+ (if (not (module-variable
+ (if #{mj 42996}#
+ (resolve-module (cdr #{mj 42996}#))
+ (current-module))
+ (if (if (vector? #{j 42994}#)
+ (if (= (vector-length
+ #{j 42994}#)
+ 4)
+ (eq? (vector-ref
+ #{j 42994}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref #{j 42994}# 1)
+ #{j 42994}#)))
+ (eq? #{ni 42997}# #{nj 42998}#)
+ #f)))
+ (eq? (module-variable
+ (if #{mi 42995}#
+ (resolve-module (cdr #{mi 42995}#))
+ (current-module))
+ (if (if (vector? #{i 42993}#)
+ (if (= (vector-length #{i 42993}#) 4)
+ (eq? (vector-ref #{i 42993}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref #{i 42993}# 1)
+ #{i 42993}#))
+ (module-variable
+ (if #{mj 42996}#
+ (resolve-module (cdr #{mj 42996}#))
+ (current-module))
+ (if (if (vector? #{j 42994}#)
+ (if (= (vector-length #{j 42994}#) 4)
+ (eq? (vector-ref #{j 42994}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref #{j 42994}# 1)
+ #{j 42994}#)))
#f)
- (eq? #{x 16650}# #{j 16733}#)))))
- (if #{t 16652}#
- #{t 16652}#
- (#{bound-id-member? 4442}#
- #{x 16650}#
- (cdr #{list 16651}#))))
- #f)))
- (#{wrap 4443}#
- (lambda (#{x 16777}# #{w 16778}# #{defmod 16779}#)
- (if (if (null? (car #{w 16778}#))
- (null? (cdr #{w 16778}#))
+ #f)
+ (equal? #{ni 42997}# #{nj 42998}#))))))))))
+ (#{bound-id=? 28260}#
+ (lambda (#{i 43263}# #{j 43264}#)
+ (if (if (if (vector? #{i 43263}#)
+ (if (= (vector-length #{i 43263}#) 4)
+ (eq? (vector-ref #{i 43263}# 0) 'syntax-object)
+ #f)
+ #f)
+ (if (vector? #{j 43264}#)
+ (if (= (vector-length #{j 43264}#) 4)
+ (eq? (vector-ref #{j 43264}# 0) 'syntax-object)
+ #f)
#f)
- #{x 16777}#
- (if (if (vector? #{x 16777}#)
- (if (= (vector-length #{x 16777}#) 4)
- (eq? (vector-ref #{x 16777}# 0) 'syntax-object)
+ #f)
+ (if (eq? (vector-ref #{i 43263}# 1)
+ (vector-ref #{j 43264}# 1))
+ (#{same-marks? 28256}#
+ (car (vector-ref #{i 43263}# 2))
+ (car (vector-ref #{j 43264}# 2)))
+ #f)
+ (eq? #{i 43263}# #{j 43264}#))))
+ (#{valid-bound-ids? 28261}#
+ (lambda (#{ids 43433}#)
+ (if (letrec*
+ ((#{all-ids? 43434}#
+ (lambda (#{ids 43631}#)
+ (if (null? #{ids 43631}#)
+ (null? #{ids 43631}#)
+ (if (let ((#{x 43642}# (car #{ids 43631}#)))
+ (if (symbol? #{x 43642}#)
+ #t
+ (if (if (vector? #{x 43642}#)
+ (if (= (vector-length #{x 43642}#) 4)
+ (eq? (vector-ref #{x 43642}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref #{x 43642}# 1))
+ #f)))
+ (#{all-ids? 43434}# (cdr #{ids 43631}#))
+ #f)))))
+ (#{all-ids? 43434}# #{ids 43433}#))
+ (#{distinct-bound-ids? 28262}# #{ids 43433}#)
+ #f)))
+ (#{distinct-bound-ids? 28262}#
+ (lambda (#{ids 43763}#)
+ (letrec*
+ ((#{distinct? 43764}#
+ (lambda (#{ids 43869}#)
+ (if (null? #{ids 43869}#)
+ (null? #{ids 43869}#)
+ (if (not (#{bound-id-member? 28263}#
+ (car #{ids 43869}#)
+ (cdr #{ids 43869}#)))
+ (#{distinct? 43764}# (cdr #{ids 43869}#))
+ #f)))))
+ (#{distinct? 43764}# #{ids 43763}#))))
+ (#{bound-id-member? 28263}#
+ (lambda (#{x 43965}# #{list 43966}#)
+ (if (not (null? #{list 43966}#))
+ (let ((#{t 43967}#
+ (#{bound-id=? 28260}#
+ #{x 43965}#
+ (car #{list 43966}#))))
+ (if #{t 43967}#
+ #{t 43967}#
+ (#{bound-id-member? 28263}#
+ #{x 43965}#
+ (cdr #{list 43966}#))))
+ #f)))
+ (#{source-wrap 28265}#
+ (lambda (#{x 44145}#
+ #{w 44146}#
+ #{s 44147}#
+ #{defmod 44148}#)
+ (let ((#{x 44152}#
+ (begin
+ (if (if (pair? #{x 44145}#) #{s 44147}# #f)
+ (set-source-properties! #{x 44145}# #{s 44147}#))
+ #{x 44145}#)))
+ (if (if (null? (car #{w 44146}#))
+ (null? (cdr #{w 44146}#))
+ #f)
+ #{x 44152}#
+ (if (if (vector? #{x 44152}#)
+ (if (= (vector-length #{x 44152}#) 4)
+ (eq? (vector-ref #{x 44152}# 0) 'syntax-object)
#f)
#f)
- (let ((#{expression 16793}# (vector-ref #{x 16777}# 1))
- (#{wrap 16794}#
- (#{join-wraps 4431}#
- #{w 16778}#
- (vector-ref #{x 16777}# 2)))
- (#{module 16795}# (vector-ref #{x 16777}# 3)))
+ (let ((#{expression 44184}# (vector-ref #{x 44152}# 1))
+ (#{wrap 44185}#
+ (let ((#{w2 44193}# (vector-ref #{x 44152}# 2)))
+ (let ((#{m1 44194}# (car #{w 44146}#))
+ (#{s1 44195}# (cdr #{w 44146}#)))
+ (if (null? #{m1 44194}#)
+ (if (null? #{s1 44195}#)
+ #{w2 44193}#
+ (cons (car #{w2 44193}#)
+ (let ((#{m2 44210}# (cdr #{w2 44193}#)))
+ (if (null? #{m2 44210}#)
+ #{s1 44195}#
+ (append #{s1 44195}# #{m2 44210}#)))))
+ (cons (let ((#{m2 44218}# (car #{w2 44193}#)))
+ (if (null? #{m2 44218}#)
+ #{m1 44194}#
+ (append #{m1 44194}# #{m2 44218}#)))
+ (let ((#{m2 44226}# (cdr #{w2 44193}#)))
+ (if (null? #{m2 44226}#)
+ #{s1 44195}#
+ (append #{s1 44195}# #{m2 44226}#))))))))
+ (#{module 44186}# (vector-ref #{x 44152}# 3)))
(vector
'syntax-object
- #{expression 16793}#
- #{wrap 16794}#
- #{module 16795}#))
- (if (null? #{x 16777}#)
- #{x 16777}#
+ #{expression 44184}#
+ #{wrap 44185}#
+ #{module 44186}#))
+ (if (null? #{x 44152}#)
+ #{x 44152}#
(vector
'syntax-object
- #{x 16777}#
- #{w 16778}#
- #{defmod 16779}#))))))
- (#{source-wrap 4444}#
- (lambda (#{x 16812}#
- #{w 16813}#
- #{s 16814}#
- #{defmod 16815}#)
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{x 16812}#) #{s 16814}# #f)
- (set-source-properties! #{x 16812}# #{s 16814}#))
- #{x 16812}#)
- #{w 16813}#
- #{defmod 16815}#)))
- (#{expand-sequence 4445}#
- (lambda (#{body 26205}#
- #{r 26206}#
- #{w 26207}#
- #{s 26208}#
- #{mod 26209}#)
- (#{build-sequence 4396}#
- #{s 26208}#
- (letrec*
- ((#{dobody 26289}#
- (lambda (#{body 26639}#
- #{r 26640}#
- #{w 26641}#
- #{mod 26642}#)
- (if (null? #{body 26639}#)
- '()
- (let ((#{first 26643}#
- (let ((#{e 26647}# (car #{body 26639}#)))
- (call-with-values
- (lambda ()
- (#{syntax-type 4449}#
- #{e 26647}#
- #{r 26640}#
- #{w 26641}#
- (#{source-annotation 4408}# #{e 26647}#)
- #f
- #{mod 26642}#
- #f))
- (lambda (#{type 26654}#
- #{value 26655}#
- #{e 26656}#
- #{w 26657}#
- #{s 26658}#
- #{mod 26659}#)
- (#{expand-expr 4451}#
- #{type 26654}#
- #{value 26655}#
- #{e 26656}#
- #{r 26640}#
- #{w 26657}#
- #{s 26658}#
- #{mod 26659}#))))))
- (cons #{first 26643}#
- (#{dobody 26289}#
- (cdr #{body 26639}#)
- #{r 26640}#
- #{w 26641}#
- #{mod 26642}#)))))))
- (#{dobody 26289}#
- #{body 26205}#
- #{r 26206}#
- #{w 26207}#
- #{mod 26209}#)))))
- (#{expand-top-sequence 4446}#
- (lambda (#{body 16833}#
- #{r 16834}#
- #{w 16835}#
- #{s 16836}#
- #{m 16837}#
- #{esew 16838}#
- #{mod 16839}#)
+ #{x 44152}#
+ #{w 44146}#
+ #{defmod 44148}#)))))))
+ (#{expand-sequence 28266}#
+ (lambda (#{body 59670}#
+ #{r 59671}#
+ #{w 59672}#
+ #{s 59673}#
+ #{mod 59674}#)
+ (#{build-sequence 28220}#
+ #{s 59673}#
(letrec*
- ((#{scan 16840}#
- (lambda (#{body 16971}#
- #{r 16972}#
- #{w 16973}#
- #{s 16974}#
- #{m 16975}#
- #{esew 16976}#
- #{mod 16977}#
- #{exps 16978}#)
- (if (null? #{body 16971}#)
- #{exps 16978}#
- (call-with-values
- (lambda ()
- (call-with-values
- (lambda ()
- (let ((#{e 16979}# (car #{body 16971}#)))
- (#{syntax-type 4449}#
- #{e 16979}#
- #{r 16972}#
- #{w 16973}#
- (let ((#{t 16983}#
- (#{source-annotation 4408}#
- #{e 16979}#)))
- (if #{t 16983}# #{t 16983}# #{s 16974}#))
- #f
- #{mod 16977}#
- #f)))
- (lambda (#{type 17218}#
- #{value 17219}#
- #{e 17220}#
- #{w 17221}#
- #{s 17222}#
- #{mod 17223}#)
- (if (eqv? #{type 17218}# 'begin-form)
- (let ((#{tmp 17228}#
- ($sc-dispatch #{e 17220}# '(_))))
- (if #{tmp 17228}#
- (@apply
- (lambda () #{exps 16978}#)
- #{tmp 17228}#)
- (let ((#{tmp 17232}#
- ($sc-dispatch
- #{e 17220}#
- '(_ any . each-any))))
- (if #{tmp 17232}#
- (@apply
- (lambda (#{e1 17236}# #{e2 17237}#)
- (#{scan 16840}#
- (cons #{e1 17236}# #{e2 17237}#)
- #{r 16972}#
- #{w 17221}#
- #{s 17222}#
- #{m 16975}#
- #{esew 16976}#
- #{mod 17223}#
- #{exps 16978}#))
- #{tmp 17232}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{e 17220}#)))))
- (if (eqv? #{type 17218}# 'local-syntax-form)
- (#{expand-local-syntax 4455}#
- #{value 17219}#
- #{e 17220}#
- #{r 16972}#
- #{w 17221}#
- #{s 17222}#
- #{mod 17223}#
- (lambda (#{body 17252}#
- #{r 17253}#
- #{w 17254}#
- #{s 17255}#
- #{mod 17256}#)
- (#{scan 16840}#
- #{body 17252}#
- #{r 17253}#
- #{w 17254}#
- #{s 17255}#
- #{m 16975}#
- #{esew 16976}#
- #{mod 17256}#
- #{exps 16978}#)))
- (if (eqv? #{type 17218}# 'eval-when-form)
- (let ((#{tmp 17261}#
- ($sc-dispatch
- #{e 17220}#
- '(_ each-any any . each-any))))
- (if #{tmp 17261}#
- (@apply
- (lambda (#{x 17265}#
- #{e1 17266}#
- #{e2 17267}#)
- (let ((#{when-list 17268}#
- (#{parse-when-list 4448}#
- #{e 17220}#
- #{x 17265}#))
- (#{body 17269}#
- (cons #{e1 17266}#
- #{e2 17267}#)))
- (if (eq? #{m 16975}# 'e)
- (if (memq 'eval
- #{when-list 17268}#)
- (#{scan 16840}#
- #{body 17269}#
- #{r 16972}#
- #{w 17221}#
- #{s 17222}#
- (if (memq 'expand
- #{when-list 17268}#)
- 'c&e
- 'e)
- '(eval)
- #{mod 17223}#
- #{exps 16978}#)
- (begin
- (if (memq 'expand
- #{when-list 17268}#)
- (let ((#{x 17346}#
- (#{expand-top-sequence 4446}#
- #{body 17269}#
- #{r 16972}#
- #{w 17221}#
- #{s 17222}#
- 'e
- '(eval)
- #{mod 17223}#)))
- (primitive-eval
- #{x 17346}#)))
- (values #{exps 16978}#)))
- (if (memq 'load
- #{when-list 17268}#)
- (if (let ((#{t 17372}#
- (memq 'compile
- #{when-list 17268}#)))
- (if #{t 17372}#
- #{t 17372}#
- (let ((#{t 17421}#
- (memq 'expand
- #{when-list 17268}#)))
- (if #{t 17421}#
- #{t 17421}#
- (if (eq? #{m 16975}#
- 'c&e)
- (memq 'eval
- #{when-list 17268}#)
- #f)))))
- (#{scan 16840}#
- #{body 17269}#
- #{r 16972}#
- #{w 17221}#
- #{s 17222}#
- 'c&e
- '(compile load)
- #{mod 17223}#
- #{exps 16978}#)
- (if (if (eq? #{m 16975}# 'c)
- #t
- (eq? #{m 16975}# 'c&e))
- (#{scan 16840}#
- #{body 17269}#
- #{r 16972}#
- #{w 17221}#
- #{s 17222}#
- 'c
- '(load)
- #{mod 17223}#
- #{exps 16978}#)
- (values #{exps 16978}#)))
- (if (let ((#{t 17550}#
- (memq 'compile
- #{when-list 17268}#)))
- (if #{t 17550}#
- #{t 17550}#
- (let ((#{t 17599}#
- (memq 'expand
- #{when-list 17268}#)))
- (if #{t 17599}#
- #{t 17599}#
- (if (eq? #{m 16975}#
- 'c&e)
- (memq 'eval
- #{when-list 17268}#)
- #f)))))
- (begin
- (let ((#{x 17723}#
- (#{expand-top-sequence 4446}#
- #{body 17269}#
- #{r 16972}#
- #{w 17221}#
- #{s 17222}#
- 'e
- '(eval)
- #{mod 17223}#)))
- (primitive-eval
- #{x 17723}#))
- (values #{exps 16978}#))
- (values #{exps 16978}#))))))
- #{tmp 17261}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{e 17220}#)))
- (if (if (eqv? #{type 17218}#
- 'define-syntax-form)
- #t
- (eqv? #{type 17218}#
- 'define-syntax-parameter-form))
- (let ((#{n 17769}#
- (#{id-var-name 4434}#
- #{value 17219}#
- #{w 17221}#))
- (#{r 17770}#
- (#{macros-only-env 4411}#
- #{r 16972}#)))
- (if (eqv? #{m 16975}# 'c)
- (if (memq 'compile #{esew 16976}#)
- (let ((#{e 17774}#
- (#{expand-install-global 4447}#
- #{n 17769}#
- (#{expand 4450}#
- #{e 17220}#
- #{r 17770}#
- #{w 17221}#
- #{mod 17223}#))))
+ ((#{dobody 59762}#
+ (lambda (#{body 59845}#
+ #{r 59846}#
+ #{w 59847}#
+ #{mod 59848}#)
+ (if (null? #{body 59845}#)
+ '()
+ (let ((#{first 59849}#
+ (#{expand 28271}#
+ (car #{body 59845}#)
+ #{r 59846}#
+ #{w 59847}#
+ #{mod 59848}#)))
+ (cons #{first 59849}#
+ (#{dobody 59762}#
+ (cdr #{body 59845}#)
+ #{r 59846}#
+ #{w 59847}#
+ #{mod 59848}#)))))))
+ (#{dobody 59762}#
+ #{body 59670}#
+ #{r 59671}#
+ #{w 59672}#
+ #{mod 59674}#)))))
+ (#{expand-top-sequence 28267}#
+ (lambda (#{body 44255}#
+ #{r 44256}#
+ #{w 44257}#
+ #{s 44258}#
+ #{m 44259}#
+ #{esew 44260}#
+ #{mod 44261}#)
+ (let ((#{r 44262}#
+ (cons '("placeholder" placeholder) #{r 44256}#)))
+ (let ((#{ribcage 44263}# (vector 'ribcage '() '() '())))
+ (let ((#{w 44264}#
+ (cons (car #{w 44257}#)
+ (cons #{ribcage 44263}# (cdr #{w 44257}#)))))
+ (letrec*
+ ((#{record-definition! 44265}#
+ (lambda (#{id 47641}# #{var 47642}#)
+ (let ((#{mod 47643}#
+ (cons 'hygiene (module-name (current-module)))))
+ (let ((#{label 47649}#
+ (cons (vector-ref #{id 47641}# 3)
+ (if (if (vector? #{var 47642}#)
+ (if (= (vector-length #{var 47642}#)
+ 4)
+ (eq? (vector-ref #{var 47642}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 47711}#
+ (vector-ref #{var 47642}# 1))
+ (#{wrap 47712}#
+ (let ((#{w2 47722}#
+ (vector-ref
+ #{var 47642}#
+ 2)))
+ (cons (let ((#{m2 47729}#
+ (car #{w2 47722}#)))
+ (if (null? #{m2 47729}#)
+ '(top)
+ (append
+ '(top)
+ #{m2 47729}#)))
+ (let ((#{m2 47738}#
+ (cdr #{w2 47722}#)))
+ (if (null? #{m2 47738}#)
+ '()
+ (append
+ '()
+ #{m2 47738}#))))))
+ (#{module 47713}#
+ (vector-ref #{var 47642}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 47711}#
+ #{wrap 47712}#
+ #{module 47713}#))
+ (if (null? #{var 47642}#)
+ #{var 47642}#
+ (vector
+ 'syntax-object
+ #{var 47642}#
+ '((top))
+ #{mod 47643}#))))))
+ (begin
+ (let ((#{update 47652}#
+ (cons (vector-ref #{id 47641}# 1)
+ (vector-ref #{ribcage 44263}# 1))))
+ (vector-set!
+ #{ribcage 44263}#
+ 1
+ #{update 47652}#))
+ (let ((#{update 47667}#
+ (cons (car (vector-ref #{id 47641}# 2))
+ (vector-ref #{ribcage 44263}# 2))))
+ (vector-set!
+ #{ribcage 44263}#
+ 2
+ #{update 47667}#))
+ (let ((#{update 47682}#
+ (cons #{label 47649}#
+ (vector-ref #{ribcage 44263}# 3))))
+ (vector-set!
+ #{ribcage 44263}#
+ 3
+ #{update 47682}#)))))))
+ (#{parse 44268}#
+ (lambda (#{body 44463}#
+ #{r 44464}#
+ #{w 44465}#
+ #{s 44466}#
+ #{m 44467}#
+ #{esew 44468}#
+ #{mod 44469}#)
+ (letrec*
+ ((#{lp 44470}#
+ (lambda (#{body 44553}# #{exps 44554}#)
+ (if (null? #{body 44553}#)
+ #{exps 44554}#
+ (#{lp 44470}#
+ (cdr #{body 44553}#)
+ (append
+ (#{parse1 44269}#
+ (car #{body 44553}#)
+ #{r 44464}#
+ #{w 44465}#
+ #{s 44466}#
+ #{m 44467}#
+ #{esew 44468}#
+ #{mod 44469}#)
+ #{exps 44554}#))))))
+ (#{lp 44470}# #{body 44463}# '()))))
+ (#{parse1 44269}#
+ (lambda (#{x 44624}#
+ #{r 44625}#
+ #{w 44626}#
+ #{s 44627}#
+ #{m 44628}#
+ #{esew 44629}#
+ #{mod 44630}#)
+ (call-with-values
+ (lambda ()
+ (#{syntax-type 28270}#
+ #{x 44624}#
+ #{r 44625}#
+ #{w 44626}#
+ (#{source-annotation 28232}# #{x 44624}#)
+ #{ribcage 44263}#
+ #{mod 44630}#
+ #f))
+ (lambda (#{type 44816}#
+ #{value 44817}#
+ #{e 44818}#
+ #{w 44819}#
+ #{s 44820}#
+ #{mod 44821}#)
+ (if (eqv? #{type 44816}# 'define-form)
+ (let ((#{id 44825}#
+ (if (if (null? (car #{w 44819}#))
+ (null? (cdr #{w 44819}#))
+ #f)
+ #{value 44817}#
+ (if (if (vector? #{value 44817}#)
+ (if (= (vector-length
+ #{value 44817}#)
+ 4)
+ (eq? (vector-ref #{value 44817}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 44875}#
+ (vector-ref #{value 44817}# 1))
+ (#{wrap 44876}#
+ (let ((#{w2 44886}#
+ (vector-ref
+ #{value 44817}#
+ 2)))
+ (let ((#{m1 44887}#
+ (car #{w 44819}#))
+ (#{s1 44888}#
+ (cdr #{w 44819}#)))
+ (if (null? #{m1 44887}#)
+ (if (null? #{s1 44888}#)
+ #{w2 44886}#
+ (cons (car #{w2 44886}#)
+ (let ((#{m2 44905}#
+ (cdr #{w2 44886}#)))
+ (if (null? #{m2 44905}#)
+ #{s1 44888}#
+ (append
+ #{s1 44888}#
+ #{m2 44905}#)))))
+ (cons (let ((#{m2 44913}#
+ (car #{w2 44886}#)))
+ (if (null? #{m2 44913}#)
+ #{m1 44887}#
+ (append
+ #{m1 44887}#
+ #{m2 44913}#)))
+ (let ((#{m2 44921}#
+ (cdr #{w2 44886}#)))
+ (if (null? #{m2 44921}#)
+ #{s1 44888}#
+ (append
+ #{s1 44888}#
+ #{m2 44921}#))))))))
+ (#{module 44877}#
+ (vector-ref #{value 44817}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 44875}#
+ #{wrap 44876}#
+ #{module 44877}#))
+ (if (null? #{value 44817}#)
+ #{value 44817}#
+ (vector
+ 'syntax-object
+ #{value 44817}#
+ #{w 44819}#
+ #{mod 44821}#))))))
+ (begin
+ (symbol->string (gensym "i"))
+ (let ((#{var 44827}#
+ (if (not (equal?
+ (car (vector-ref
+ #{id 44825}#
+ 2))
+ '(top)))
+ (symbol-append
+ (vector-ref #{id 44825}# 1)
+ '-
+ (string->symbol
+ (number->string
+ (hash (syntax->datum #{x 44624}#)
+ most-positive-fixnum)
+ 16)))
+ (vector-ref #{id 44825}# 1))))
+ (begin
+ (#{record-definition! 44265}#
+ #{id 44825}#
+ #{var 44827}#)
+ (list (if (eq? #{m 44628}# 'c&e)
+ (let ((#{x 45047}#
+ (#{build-global-definition 28213}#
+ #{s 44820}#
+ #{var 44827}#
+ (#{expand 28271}#
+ #{e 44818}#
+ #{r 44625}#
+ #{w 44819}#
+ #{mod 44821}#))))
+ (begin
+ (#{top-level-eval-hook 28198}#
+ #{x 45047}#
+ #{mod 44821}#)
+ (lambda () #{x 45047}#)))
+ (lambda ()
+ (#{build-global-definition 28213}#
+ #{s 44820}#
+ #{var 44827}#
+ (#{expand 28271}#
+ #{e 44818}#
+ #{r 44625}#
+ #{w 44819}#
+ #{mod 44821}#)))))))))
+ (if (if (eqv? #{type 44816}# 'define-syntax-form)
+ #t
+ (eqv? #{type 44816}#
+ 'define-syntax-parameter-form))
+ (let ((#{id 45541}#
+ (if (if (null? (car #{w 44819}#))
+ (null? (cdr #{w 44819}#))
+ #f)
+ #{value 44817}#
+ (if (if (vector? #{value 44817}#)
+ (if (= (vector-length
+ #{value 44817}#)
+ 4)
+ (eq? (vector-ref
+ #{value 44817}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 45591}#
+ (vector-ref #{value 44817}# 1))
+ (#{wrap 45592}#
+ (let ((#{w2 45602}#
+ (vector-ref
+ #{value 44817}#
+ 2)))
+ (let ((#{m1 45603}#
+ (car #{w 44819}#))
+ (#{s1 45604}#
+ (cdr #{w 44819}#)))
+ (if (null? #{m1 45603}#)
+ (if (null? #{s1 45604}#)
+ #{w2 45602}#
+ (cons (car #{w2 45602}#)
+ (let ((#{m2 45621}#
+ (cdr #{w2 45602}#)))
+ (if (null? #{m2 45621}#)
+ #{s1 45604}#
+ (append
+ #{s1 45604}#
+ #{m2 45621}#)))))
+ (cons (let ((#{m2 45629}#
+ (car #{w2 45602}#)))
+ (if (null? #{m2 45629}#)
+ #{m1 45603}#
+ (append
+ #{m1 45603}#
+ #{m2 45629}#)))
+ (let ((#{m2 45637}#
+ (cdr #{w2 45602}#)))
+ (if (null? #{m2 45637}#)
+ #{s1 45604}#
+ (append
+ #{s1 45604}#
+ #{m2 45637}#))))))))
+ (#{module 45593}#
+ (vector-ref
+ #{value 44817}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 45591}#
+ #{wrap 45592}#
+ #{module 45593}#))
+ (if (null? #{value 44817}#)
+ #{value 44817}#
+ (vector
+ 'syntax-object
+ #{value 44817}#
+ #{w 44819}#
+ #{mod 44821}#))))))
+ (begin
+ (symbol->string (gensym "i"))
+ (let ((#{var 45543}#
+ (if (not (equal?
+ (car (vector-ref
+ #{id 45541}#
+ 2))
+ '(top)))
+ (symbol-append
+ (vector-ref #{id 45541}# 1)
+ '-
+ (string->symbol
+ (number->string
+ (hash (syntax->datum
+ #{x 44624}#)
+ most-positive-fixnum)
+ 16)))
+ (vector-ref #{id 45541}# 1))))
+ (begin
+ (#{record-definition! 44265}#
+ #{id 45541}#
+ #{var 45543}#)
+ (if (eqv? #{m 44628}# 'c)
+ (if (memq 'compile #{esew 44629}#)
+ (let ((#{e 45766}#
+ (#{expand-install-global 28268}#
+ #{var 45543}#
+ #{type 44816}#
+ (#{expand 28271}#
+ #{e 44818}#
+ #{r 44625}#
+ #{w 44819}#
+ #{mod 44821}#))))
(begin
- (#{top-level-eval-hook 4375}#
- #{e 17774}#
- #{mod 17223}#)
- (if (memq 'load #{esew 16976}#)
- (values
- (cons #{e 17774}#
- #{exps 16978}#))
- (values #{exps 16978}#))))
- (if (memq 'load #{esew 16976}#)
- (values
- (cons (#{expand-install-global 4447}#
- #{n 17769}#
- (#{expand 4450}#
- #{e 17220}#
- #{r 17770}#
- #{w 17221}#
- #{mod 17223}#))
- #{exps 16978}#))
- (values #{exps 16978}#)))
- (if (eqv? #{m 16975}# 'c&e)
- (let ((#{e 18221}#
- (#{expand-install-global 4447}#
- #{n 17769}#
- (#{expand 4450}#
- #{e 17220}#
- #{r 17770}#
- #{w 17221}#
- #{mod 17223}#))))
+ (#{top-level-eval-hook 28198}#
+ #{e 45766}#
+ #{mod 44821}#)
+ (if (memq 'load #{esew 44629}#)
+ (list (lambda () #{e 45766}#))
+ '())))
+ (if (memq 'load #{esew 44629}#)
+ (list (lambda ()
+ (#{expand-install-global 28268}#
+ #{var 45543}#
+ #{type 44816}#
+ (#{expand 28271}#
+ #{e 44818}#
+ #{r 44625}#
+ #{w 44819}#
+ #{mod 44821}#))))
+ '()))
+ (if (eqv? #{m 44628}# 'c&e)
+ (let ((#{e 46269}#
+ (#{expand-install-global 28268}#
+ #{var 45543}#
+ #{type 44816}#
+ (#{expand 28271}#
+ #{e 44818}#
+ #{r 44625}#
+ #{w 44819}#
+ #{mod 44821}#))))
(begin
- (#{top-level-eval-hook 4375}#
- #{e 18221}#
- #{mod 17223}#)
- (values
- (cons #{e 18221}#
- #{exps 16978}#))))
+ (#{top-level-eval-hook 28198}#
+ #{e 46269}#
+ #{mod 44821}#)
+ (list (lambda () #{e 46269}#))))
(begin
- (if (memq 'eval #{esew 16976}#)
- (#{top-level-eval-hook 4375}#
- (#{expand-install-global 4447}#
- #{n 17769}#
- (#{expand 4450}#
- #{e 17220}#
- #{r 17770}#
- #{w 17221}#
- #{mod 17223}#))
- #{mod 17223}#))
- (values #{exps 16978}#)))))
- (if (eqv? #{type 17218}# 'define-form)
- (let ((#{n 18856}#
- (#{id-var-name 4434}#
- #{value 17219}#
- #{w 17221}#)))
- (let ((#{type 18857}#
- (car (let ((#{t 18864}#
- (assq #{n 18856}#
- #{r 16972}#)))
- (if #{t 18864}#
- (cdr #{t 18864}#)
- (if (symbol?
- #{n 18856}#)
- (let ((#{t 18870}#
- (#{get-global-definition-hook 4378}#
- #{n 18856}#
- #{mod 17223}#)))
- (if #{t 18870}#
- #{t 18870}#
- '(global)))
- '(displaced-lexical)))))))
- (if (if (eqv? #{type 18857}# 'global)
- #t
- (if (eqv? #{type 18857}# 'core)
- #t
- (if (eqv? #{type 18857}#
- 'macro)
- #t
- (eqv? #{type 18857}#
- 'module-ref))))
- (begin
- (if (if (if (eq? #{m 16975}# 'c)
- #t
- (eq? #{m 16975}# 'c&e))
- (if (not (module-local-variable
- (current-module)
- #{n 18856}#))
- (current-module)
- #f)
- #f)
- (let ((#{old 18901}#
- (module-variable
- (current-module)
- #{n 18856}#)))
- (if (if (variable?
- #{old 18901}#)
- (variable-bound?
- #{old 18901}#)
- #f)
- (module-define!
- (current-module)
- #{n 18856}#
- (variable-ref
- #{old 18901}#))
- (module-add!
- (current-module)
- #{n 18856}#
- (make-undefined-variable)))))
- (values
- (cons (if (eq? #{m 16975}# 'c&e)
- (let ((#{x 18903}#
- (#{build-global-definition 4390}#
- #{s 17222}#
- #{n 18856}#
- (#{expand 4450}#
- #{e 17220}#
- #{r 16972}#
- #{w 17221}#
- #{mod 17223}#))))
- (begin
- (#{top-level-eval-hook 4375}#
- #{x 18903}#
- #{mod 17223}#)
- #{x 18903}#))
- (lambda ()
- (#{build-global-definition 4390}#
- #{s 17222}#
- #{n 18856}#
- (#{expand 4450}#
- #{e 17220}#
- #{r 16972}#
- #{w 17221}#
- #{mod 17223}#))))
- #{exps 16978}#)))
- (if (eqv? #{type 18857}#
- 'displaced-lexical)
- (syntax-violation
- #f
- "identifier out of context"
- #{e 17220}#
- (#{wrap 4443}#
- #{value 17219}#
- #{w 17221}#
- #{mod 17223}#))
- (syntax-violation
- #f
- "cannot define keyword at top level"
- #{e 17220}#
- (#{wrap 4443}#
- #{value 17219}#
- #{w 17221}#
- #{mod 17223}#))))))
- (values
- (cons (if (eq? #{m 16975}# 'c&e)
- (let ((#{x 19349}#
- (#{expand-expr 4451}#
- #{type 17218}#
- #{value 17219}#
- #{e 17220}#
- #{r 16972}#
- #{w 17221}#
- #{s 17222}#
- #{mod 17223}#)))
- (begin
- (primitive-eval #{x 19349}#)
- #{x 19349}#))
- (lambda ()
- (#{expand-expr 4451}#
- #{type 17218}#
- #{value 17219}#
- #{e 17220}#
- #{r 16972}#
- #{w 17221}#
- #{s 17222}#
- #{mod 17223}#)))
- #{exps 16978}#))))))))))
- (lambda (#{exps 19358}#)
- (#{scan 16840}#
- (cdr #{body 16971}#)
- #{r 16972}#
- #{w 16973}#
- #{s 16974}#
- #{m 16975}#
- #{esew 16976}#
- #{mod 16977}#
- #{exps 19358}#)))))))
- (call-with-values
- (lambda ()
- (#{scan 16840}#
- #{body 16833}#
- #{r 16834}#
- #{w 16835}#
- #{s 16836}#
- #{m 16837}#
- #{esew 16838}#
- #{mod 16839}#
- '()))
- (lambda (#{exps 16843}#)
- (if (null? #{exps 16843}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- #{s 16836}#)
- (#{build-sequence 4396}#
- #{s 16836}#
- (letrec*
- ((#{lp 16883}#
- (lambda (#{in 16967}# #{out 16968}#)
- (if (null? #{in 16967}#)
- #{out 16968}#
- (let ((#{e 16969}# (car #{in 16967}#)))
- (#{lp 16883}#
- (cdr #{in 16967}#)
- (cons (if (procedure? #{e 16969}#)
- (#{e 16969}#)
- #{e 16969}#)
- #{out 16968}#)))))))
- (#{lp 16883}# #{exps 16843}# '())))))))))
- (#{expand-install-global 4447}#
- (lambda (#{name 19359}# #{e 19360}#)
- (let ((#{exp 19366}#
- (let ((#{fun-exp 19376}#
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- 'make-syntax-transformer)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- 'make-syntax-transformer
- #f)))
- (#{arg-exps 19377}#
+ (if (memq 'eval #{esew 44629}#)
+ (#{top-level-eval-hook 28198}#
+ (#{expand-install-global 28268}#
+ #{var 45543}#
+ #{type 44816}#
+ (#{expand 28271}#
+ #{e 44818}#
+ #{r 44625}#
+ #{w 44819}#
+ #{mod 44821}#))
+ #{mod 44821}#))
+ '())))))))
+ (if (eqv? #{type 44816}# 'begin-form)
+ (let ((#{tmp 46879}#
+ ($sc-dispatch
+ #{e 44818}#
+ '(_ . each-any))))
+ (if #{tmp 46879}#
+ (@apply
+ (lambda (#{e1 46883}#)
+ (#{parse 44268}#
+ #{e1 46883}#
+ #{r 44625}#
+ #{w 44819}#
+ #{s 44820}#
+ #{m 44628}#
+ #{esew 44629}#
+ #{mod 44821}#))
+ #{tmp 46879}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 44818}#)))
+ (if (eqv? #{type 44816}# 'local-syntax-form)
+ (#{expand-local-syntax 28276}#
+ #{value 44817}#
+ #{e 44818}#
+ #{r 44625}#
+ #{w 44819}#
+ #{s 44820}#
+ #{mod 44821}#
+ (lambda (#{forms 46926}#
+ #{r 46927}#
+ #{w 46928}#
+ #{s 46929}#
+ #{mod 46930}#)
+ (#{parse 44268}#
+ #{forms 46926}#
+ #{r 46927}#
+ #{w 46928}#
+ #{s 46929}#
+ #{m 44628}#
+ #{esew 44629}#
+ #{mod 46930}#)))
+ (if (eqv? #{type 44816}# 'eval-when-form)
+ (let ((#{tmp 46966}#
+ ($sc-dispatch
+ #{e 44818}#
+ '(_ each-any any . each-any))))
+ (if #{tmp 46966}#
+ (@apply
+ (lambda (#{x 46970}#
+ #{e1 46971}#
+ #{e2 46972}#)
+ (let ((#{when-list 46973}#
+ (#{parse-when-list 28269}#
+ #{e 44818}#
+ #{x 46970}#))
+ (#{body 46974}#
+ (cons #{e1 46971}#
+ #{e2 46972}#)))
+ (letrec*
+ ((#{recurse 46975}#
+ (lambda (#{m 47561}#
+ #{esew 47562}#)
+ (#{parse 44268}#
+ #{body 46974}#
+ #{r 44625}#
+ #{w 44819}#
+ #{s 44820}#
+ #{m 47561}#
+ #{esew 47562}#
+ #{mod 44821}#))))
+ (if (eq? #{m 44628}# 'e)
+ (if (memq 'eval
+ #{when-list 46973}#)
+ (#{recurse 46975}#
+ (if (memq 'expand
+ #{when-list 46973}#)
+ 'c&e
+ 'e)
+ '(eval))
+ (begin
+ (if (memq 'expand
+ #{when-list 46973}#)
+ (let ((#{x 47082}#
+ (#{expand-top-sequence 28267}#
+ #{body 46974}#
+ #{r 44625}#
+ #{w 44819}#
+ #{s 44820}#
+ 'e
+ '(eval)
+ #{mod 44821}#)))
+ (primitive-eval
+ #{x 47082}#)))
+ '()))
+ (if (memq 'load
+ #{when-list 46973}#)
+ (if (let ((#{t 47110}#
+ (memq 'compile
+ #{when-list 46973}#)))
+ (if #{t 47110}#
+ #{t 47110}#
+ (let ((#{t 47163}#
+ (memq 'expand
+ #{when-list 46973}#)))
+ (if #{t 47163}#
+ #{t 47163}#
+ (if (eq? #{m 44628}#
+ 'c&e)
+ (memq 'eval
+ #{when-list 46973}#)
+ #f)))))
+ (#{recurse 46975}#
+ 'c&e
+ '(compile load))
+ (if (if (eq? #{m 44628}#
+ 'c)
+ #t
+ (eq? #{m 44628}#
+ 'c&e))
+ (#{recurse 46975}#
+ 'c
+ '(load))
+ '()))
+ (if (let ((#{t 47372}#
+ (memq 'compile
+ #{when-list 46973}#)))
+ (if #{t 47372}#
+ #{t 47372}#
+ (let ((#{t 47425}#
+ (memq 'expand
+ #{when-list 46973}#)))
+ (if #{t 47425}#
+ #{t 47425}#
+ (if (eq? #{m 44628}#
+ 'c&e)
+ (memq 'eval
+ #{when-list 46973}#)
+ #f)))))
+ (begin
+ (let ((#{x 47559}#
+ (#{expand-top-sequence 28267}#
+ #{body 46974}#
+ #{r 44625}#
+ #{w 44819}#
+ #{s 44820}#
+ 'e
+ '(eval)
+ #{mod 44821}#)))
+ (primitive-eval
+ #{x 47559}#))
+ '())
+ '()))))))
+ #{tmp 46966}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 44818}#)))
+ (list (if (eq? #{m 44628}# 'c&e)
+ (let ((#{x 47632}#
+ (#{expand-expr 28272}#
+ #{type 44816}#
+ #{value 44817}#
+ #{e 44818}#
+ #{r 44625}#
+ #{w 44819}#
+ #{s 44820}#
+ #{mod 44821}#)))
+ (begin
+ (primitive-eval #{x 47632}#)
+ (lambda () #{x 47632}#)))
+ (lambda ()
+ (#{expand-expr 28272}#
+ #{type 44816}#
+ #{value 44817}#
+ #{e 44818}#
+ #{r 44625}#
+ #{w 44819}#
+ #{s 44820}#
+ #{mod 44821}#))))))))))))))
+ (let ((#{exps 44270}#
+ (map (lambda (#{x 44393}#) (#{x 44393}#))
+ (reverse
+ (#{parse 44268}#
+ #{body 44255}#
+ #{r 44262}#
+ #{w 44264}#
+ #{s 44258}#
+ #{m 44259}#
+ #{esew 44260}#
+ #{mod 44261}#)))))
+ (if (null? #{exps 44270}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 0)
+ #{s 44258}#)
+ (#{build-sequence 28220}#
+ #{s 44258}#
+ #{exps 44270}#)))))))))
+ (#{expand-install-global 28268}#
+ (lambda (#{name 47760}# #{type 47761}# #{e 47762}#)
+ (let ((#{exp 47768}#
+ (let ((#{args 47779}#
+ (if (eq? #{type 47761}#
+ 'define-syntax-parameter-form)
+ (list (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #f
+ #{name 47760}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #f
+ 'syntax-parameter)
+ (let ((#{args 47802}# (list #{e 47762}#)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 12)
+ #f
+ 'list
+ #{args 47802}#)))
(list (make-struct/no-tail
(vector-ref %expanded-vtables 1)
#f
- #{name 19359}#)
+ #{name 47760}#)
(make-struct/no-tail
(vector-ref %expanded-vtables 1)
#f
'macro)
- #{e 19360}#)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- #{fun-exp 19376}#
- #{arg-exps 19377}#))))
- (begin
- (if (if (struct? #{exp 19366}#)
- (eq? (struct-vtable #{exp 19366}#)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((#{meta 19418}# (struct-ref #{exp 19366}# 1)))
- (if (not (assq 'name #{meta 19418}#))
- (let ((#{v 19425}#
- (cons (cons 'name #{name 19359}#) #{meta 19418}#)))
- (struct-set! #{exp 19366}# 1 #{v 19425}#)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 9)
- #f
- #{name 19359}#
- #{exp 19366}#)))))
- (#{parse-when-list 4448}#
- (lambda (#{e 19436}# #{when-list 19437}#)
- (let ((#{result 19438}#
- (#{strip 4463}# #{when-list 19437}# '(()))))
- (letrec*
- ((#{lp 19439}#
- (lambda (#{l 19493}#)
- (if (null? #{l 19493}#)
- #{result 19438}#
- (if (let ((#{t 19495}# (car #{l 19493}#)))
- (if (eq? #{t 19495}# 'compile)
+ #{e 47762}#))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 12)
+ #f
+ 'make-syntax-transformer
+ #{args 47779}#))))
+ (begin
+ (if (if (struct? #{exp 47768}#)
+ (eq? (struct-vtable #{exp 47768}#)
+ (vector-ref %expanded-vtables 14))
+ #f)
+ (let ((#{meta 47829}# (struct-ref #{exp 47768}# 1)))
+ (if (not (assq 'name #{meta 47829}#))
+ (let ((#{v 47836}#
+ (cons (cons 'name #{name 47760}#) #{meta 47829}#)))
+ (struct-set! #{exp 47768}# 1 #{v 47836}#)))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 9)
+ #f
+ #{name 47760}#
+ #{exp 47768}#)))))
+ (#{parse-when-list 28269}#
+ (lambda (#{e 47847}# #{when-list 47848}#)
+ (let ((#{result 47849}#
+ (#{strip 28284}# #{when-list 47848}# '(()))))
+ (letrec*
+ ((#{lp 47850}#
+ (lambda (#{l 47916}#)
+ (if (null? #{l 47916}#)
+ #{result 47849}#
+ (if (let ((#{t 47918}# (car #{l 47916}#)))
+ (if (eq? #{t 47918}# 'compile)
+ #t
+ (if (eq? #{t 47918}# 'load)
#t
- (if (eq? #{t 19495}# 'load)
+ (if (eq? #{t 47918}# 'eval)
#t
- (if (eq? #{t 19495}# 'eval)
- #t
- (eq? #{t 19495}# 'expand)))))
- (#{lp 19439}# (cdr #{l 19493}#))
- (syntax-violation
- 'eval-when
- "invalid situation"
- #{e 19436}#
- (car #{l 19493}#)))))))
- (#{lp 19439}# #{result 19438}#)))))
- (#{syntax-type 4449}#
- (lambda (#{e 19497}#
- #{r 19498}#
- #{w 19499}#
- #{s 19500}#
- #{rib 19501}#
- #{mod 19502}#
- #{for-car? 19503}#)
- (if (symbol? #{e 19497}#)
- (let ((#{n 19504}#
- (#{id-var-name 4434}# #{e 19497}# #{w 19499}#)))
- (let ((#{b 19505}#
- (let ((#{t 19513}# (assq #{n 19504}# #{r 19498}#)))
- (if #{t 19513}#
- (cdr #{t 19513}#)
- (if (symbol? #{n 19504}#)
- (let ((#{t 19519}#
- (#{get-global-definition-hook 4378}#
- #{n 19504}#
- #{mod 19502}#)))
- (if #{t 19519}# #{t 19519}# '(global)))
- '(displaced-lexical))))))
- (let ((#{type 19506}# (car #{b 19505}#)))
- (if (eqv? #{type 19506}# 'lexical)
+ (eq? #{t 47918}# 'expand)))))
+ (#{lp 47850}# (cdr #{l 47916}#))
+ (syntax-violation
+ 'eval-when
+ "invalid situation"
+ #{e 47847}#
+ (car #{l 47916}#)))))))
+ (#{lp 47850}# #{result 47849}#)))))
+ (#{syntax-type 28270}#
+ (lambda (#{e 47920}#
+ #{r 47921}#
+ #{w 47922}#
+ #{s 47923}#
+ #{rib 47924}#
+ #{mod 47925}#
+ #{for-car? 47926}#)
+ (if (symbol? #{e 47920}#)
+ (call-with-values
+ (lambda ()
+ (#{resolve-identifier 28258}#
+ #{e 47920}#
+ #{w 47922}#
+ #{r 47921}#
+ #{mod 47925}#
+ #t))
+ (lambda (#{type 47929}# #{value 47930}# #{mod* 47931}#)
+ (if (eqv? #{type 47929}# 'macro)
+ (if #{for-car? 47926}#
+ (values
+ #{type 47929}#
+ #{value 47930}#
+ #{e 47920}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#)
+ (#{syntax-type 28270}#
+ (#{expand-macro 28274}#
+ #{value 47930}#
+ #{e 47920}#
+ #{r 47921}#
+ #{w 47922}#
+ #{s 47923}#
+ #{rib 47924}#
+ #{mod 47925}#)
+ #{r 47921}#
+ '(())
+ #{s 47923}#
+ #{rib 47924}#
+ #{mod 47925}#
+ #f))
+ (if (eqv? #{type 47929}# 'global)
+ (values
+ #{type 47929}#
+ #{value 47930}#
+ #{value 47930}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod* 47931}#)
+ (values
+ #{type 47929}#
+ #{value 47930}#
+ #{e 47920}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#)))))
+ (if (pair? #{e 47920}#)
+ (let ((#{first 47940}# (car #{e 47920}#)))
+ (call-with-values
+ (lambda ()
+ (#{syntax-type 28270}#
+ #{first 47940}#
+ #{r 47921}#
+ #{w 47922}#
+ #{s 47923}#
+ #{rib 47924}#
+ #{mod 47925}#
+ #t))
+ (lambda (#{ftype 47942}#
+ #{fval 47943}#
+ #{fe 47944}#
+ #{fw 47945}#
+ #{fs 47946}#
+ #{fmod 47947}#)
+ (if (eqv? #{ftype 47942}# 'lexical)
(values
- #{type 19506}#
- (cdr #{b 19505}#)
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)
- (if (eqv? #{type 19506}# 'global)
+ 'lexical-call
+ #{fval 47943}#
+ #{e 47920}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#)
+ (if (eqv? #{ftype 47942}# 'global)
(values
- #{type 19506}#
- #{n 19504}#
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)
- (if (eqv? #{type 19506}# 'macro)
- (if #{for-car? 19503}#
- (values
- #{type 19506}#
- (cdr #{b 19505}#)
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)
- (#{syntax-type 4449}#
- (#{expand-macro 4453}#
- (cdr #{b 19505}#)
- #{e 19497}#
- #{r 19498}#
- #{w 19499}#
- #{s 19500}#
- #{rib 19501}#
- #{mod 19502}#)
- #{r 19498}#
- '(())
- #{s 19500}#
- #{rib 19501}#
- #{mod 19502}#
- #f))
- (values
- #{type 19506}#
- (cdr #{b 19505}#)
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)))))))
- (if (pair? #{e 19497}#)
- (let ((#{first 19539}# (car #{e 19497}#)))
- (call-with-values
- (lambda ()
- (#{syntax-type 4449}#
- #{first 19539}#
- #{r 19498}#
- #{w 19499}#
- #{s 19500}#
- #{rib 19501}#
- #{mod 19502}#
- #t))
- (lambda (#{ftype 19541}#
- #{fval 19542}#
- #{fe 19543}#
- #{fw 19544}#
- #{fs 19545}#
- #{fmod 19546}#)
- (if (eqv? #{ftype 19541}# 'lexical)
- (values
- 'lexical-call
- #{fval 19542}#
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)
- (if (eqv? #{ftype 19541}# 'global)
- (values
- 'global-call
- (vector
- 'syntax-object
- #{fval 19542}#
- #{w 19499}#
- #{fmod 19546}#)
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)
- (if (eqv? #{ftype 19541}# 'macro)
- (#{syntax-type 4449}#
- (#{expand-macro 4453}#
- #{fval 19542}#
- #{e 19497}#
- #{r 19498}#
- #{w 19499}#
- #{s 19500}#
- #{rib 19501}#
- #{mod 19502}#)
- #{r 19498}#
- '(())
- #{s 19500}#
- #{rib 19501}#
- #{mod 19502}#
- #{for-car? 19503}#)
- (if (eqv? #{ftype 19541}# 'module-ref)
- (call-with-values
- (lambda ()
- (#{fval 19542}#
- #{e 19497}#
- #{r 19498}#
- #{w 19499}#))
- (lambda (#{e 19567}#
- #{r 19568}#
- #{w 19569}#
- #{s 19570}#
- #{mod 19571}#)
- (#{syntax-type 4449}#
- #{e 19567}#
- #{r 19568}#
- #{w 19569}#
- #{s 19570}#
- #{rib 19501}#
- #{mod 19571}#
- #{for-car? 19503}#)))
- (if (eqv? #{ftype 19541}# 'core)
+ 'global-call
+ (vector
+ 'syntax-object
+ #{fval 47943}#
+ #{w 47922}#
+ #{fmod 47947}#)
+ #{e 47920}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#)
+ (if (eqv? #{ftype 47942}# 'macro)
+ (#{syntax-type 28270}#
+ (#{expand-macro 28274}#
+ #{fval 47943}#
+ #{e 47920}#
+ #{r 47921}#
+ #{w 47922}#
+ #{s 47923}#
+ #{rib 47924}#
+ #{mod 47925}#)
+ #{r 47921}#
+ '(())
+ #{s 47923}#
+ #{rib 47924}#
+ #{mod 47925}#
+ #{for-car? 47926}#)
+ (if (eqv? #{ftype 47942}# 'module-ref)
+ (call-with-values
+ (lambda ()
+ (#{fval 47943}#
+ #{e 47920}#
+ #{r 47921}#
+ #{w 47922}#))
+ (lambda (#{e 47968}#
+ #{r 47969}#
+ #{w 47970}#
+ #{s 47971}#
+ #{mod 47972}#)
+ (#{syntax-type 28270}#
+ #{e 47968}#
+ #{r 47969}#
+ #{w 47970}#
+ #{s 47971}#
+ #{rib 47924}#
+ #{mod 47972}#
+ #{for-car? 47926}#)))
+ (if (eqv? #{ftype 47942}# 'core)
+ (values
+ 'core-form
+ #{fval 47943}#
+ #{e 47920}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#)
+ (if (eqv? #{ftype 47942}# 'local-syntax)
(values
- 'core-form
- #{fval 19542}#
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)
- (if (eqv? #{ftype 19541}# 'local-syntax)
+ 'local-syntax-form
+ #{fval 47943}#
+ #{e 47920}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#)
+ (if (eqv? #{ftype 47942}# 'begin)
(values
- 'local-syntax-form
- #{fval 19542}#
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)
- (if (eqv? #{ftype 19541}# 'begin)
+ 'begin-form
+ #f
+ #{e 47920}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#)
+ (if (eqv? #{ftype 47942}# 'eval-when)
(values
- 'begin-form
+ 'eval-when-form
#f
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)
- (if (eqv? #{ftype 19541}# 'eval-when)
- (values
- 'eval-when-form
- #f
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)
- (if (eqv? #{ftype 19541}# 'define)
- (let ((#{tmp 19588}#
+ #{e 47920}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#)
+ (if (eqv? #{ftype 47942}# 'define)
+ (let ((#{tmp 47989}#
+ ($sc-dispatch
+ #{e 47920}#
+ '(_ any any))))
+ (if (if #{tmp 47989}#
+ (@apply
+ (lambda (#{name 47993}#
+ #{val 47994}#)
+ (if (symbol? #{name 47993}#)
+ #t
+ (if (if (vector?
+ #{name 47993}#)
+ (if (= (vector-length
+ #{name 47993}#)
+ 4)
+ (eq? (vector-ref
+ #{name 47993}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol?
+ (vector-ref
+ #{name 47993}#
+ 1))
+ #f)))
+ #{tmp 47989}#)
+ #f)
+ (@apply
+ (lambda (#{name 48021}# #{val 48022}#)
+ (values
+ 'define-form
+ #{name 48021}#
+ #{val 48022}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#))
+ #{tmp 47989}#)
+ (let ((#{tmp 48023}#
+ ($sc-dispatch
+ #{e 47920}#
+ '(_ (any . any)
+ any
+ .
+ each-any))))
+ (if (if #{tmp 48023}#
+ (@apply
+ (lambda (#{name 48027}#
+ #{args 48028}#
+ #{e1 48029}#
+ #{e2 48030}#)
+ (if (if (symbol?
+ #{name 48027}#)
+ #t
+ (if (if (vector?
+ #{name 48027}#)
+ (if (= (vector-length
+ #{name 48027}#)
+ 4)
+ (eq? (vector-ref
+ #{name 48027}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol?
+ (vector-ref
+ #{name 48027}#
+ 1))
+ #f))
+ (#{valid-bound-ids? 28261}#
+ (#{lambda-var-list 28286}#
+ #{args 48028}#))
+ #f))
+ #{tmp 48023}#)
+ #f)
+ (@apply
+ (lambda (#{name 48493}#
+ #{args 48494}#
+ #{e1 48495}#
+ #{e2 48496}#)
+ (values
+ 'define-form
+ (if (if (null? (car #{w 47922}#))
+ (null? (cdr #{w 47922}#))
+ #f)
+ #{name 48493}#
+ (if (if (vector?
+ #{name 48493}#)
+ (if (= (vector-length
+ #{name 48493}#)
+ 4)
+ (eq? (vector-ref
+ #{name 48493}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 48526}#
+ (vector-ref
+ #{name 48493}#
+ 1))
+ (#{wrap 48527}#
+ (let ((#{w2 48537}#
+ (vector-ref
+ #{name 48493}#
+ 2)))
+ (let ((#{m1 48538}#
+ (car #{w 47922}#))
+ (#{s1 48539}#
+ (cdr #{w 47922}#)))
+ (if (null? #{m1 48538}#)
+ (if (null? #{s1 48539}#)
+ #{w2 48537}#
+ (cons (car #{w2 48537}#)
+ (let ((#{m2 48556}#
+ (cdr #{w2 48537}#)))
+ (if (null? #{m2 48556}#)
+ #{s1 48539}#
+ (append
+ #{s1 48539}#
+ #{m2 48556}#)))))
+ (cons (let ((#{m2 48564}#
+ (car #{w2 48537}#)))
+ (if (null? #{m2 48564}#)
+ #{m1 48538}#
+ (append
+ #{m1 48538}#
+ #{m2 48564}#)))
+ (let ((#{m2 48572}#
+ (cdr #{w2 48537}#)))
+ (if (null? #{m2 48572}#)
+ #{s1 48539}#
+ (append
+ #{s1 48539}#
+ #{m2 48572}#))))))))
+ (#{module 48528}#
+ (vector-ref
+ #{name 48493}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 48526}#
+ #{wrap 48527}#
+ #{module 48528}#))
+ (if (null? #{name 48493}#)
+ #{name 48493}#
+ (vector
+ 'syntax-object
+ #{name 48493}#
+ #{w 47922}#
+ #{mod 47925}#))))
+ (let ((#{e 48598}#
+ (cons '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(name
+ args
+ e1
+ e2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i25779"
+ "i25780"
+ "i25781"
+ "i25782"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(ftype
+ fval
+ fe
+ fw
+ fs
+ fmod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i25732"
+ "i25733"
+ "i25734"
+ "i25735"
+ "i25736"
+ "i25737"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(first)
+ #((top))
+ #("i25724"))
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ ()
+ ()
+ ())
+ #(ribcage
+ #(e
+ r
+ w
+ s
+ rib
+ mod
+ for-car?)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i25703"
+ "i25704"
+ "i25705"
+ "i25706"
+ "i25707"
+ "i25708"
+ "i25709"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top)
+ (top)
+ (top))
+ ("i23873"
+ "i23872"
+ "i23871"))
+ #(ribcage
+ ()
+ ()
+ ()))
+ (hygiene
+ guile))
+ (let ((#{x 48602}#
+ (cons #{args 48494}#
+ (cons #{e1 48495}#
+ #{e2 48496}#))))
+ (if (if (null? (car #{w 47922}#))
+ (null? (cdr #{w 47922}#))
+ #f)
+ #{x 48602}#
+ (if (if (vector?
+ #{x 48602}#)
+ (if (= (vector-length
+ #{x 48602}#)
+ 4)
+ (eq? (vector-ref
+ #{x 48602}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 48620}#
+ (vector-ref
+ #{x 48602}#
+ 1))
+ (#{wrap 48621}#
+ (let ((#{w2 48629}#
+ (vector-ref
+ #{x 48602}#
+ 2)))
+ (let ((#{m1 48630}#
+ (car #{w 47922}#))
+ (#{s1 48631}#
+ (cdr #{w 47922}#)))
+ (if (null? #{m1 48630}#)
+ (if (null? #{s1 48631}#)
+ #{w2 48629}#
+ (cons (car #{w2 48629}#)
+ (let ((#{m2 48646}#
+ (cdr #{w2 48629}#)))
+ (if (null? #{m2 48646}#)
+ #{s1 48631}#
+ (append
+ #{s1 48631}#
+ #{m2 48646}#)))))
+ (cons (let ((#{m2 48654}#
+ (car #{w2 48629}#)))
+ (if (null? #{m2 48654}#)
+ #{m1 48630}#
+ (append
+ #{m1 48630}#
+ #{m2 48654}#)))
+ (let ((#{m2 48662}#
+ (cdr #{w2 48629}#)))
+ (if (null? #{m2 48662}#)
+ #{s1 48631}#
+ (append
+ #{s1 48631}#
+ #{m2 48662}#))))))))
+ (#{module 48622}#
+ (vector-ref
+ #{x 48602}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 48620}#
+ #{wrap 48621}#
+ #{module 48622}#))
+ (if (null? #{x 48602}#)
+ #{x 48602}#
+ (vector
+ 'syntax-object
+ #{x 48602}#
+ #{w 47922}#
+ #{mod 47925}#))))))))
+ (begin
+ (if (if (pair? #{e 48598}#)
+ #{s 47923}#
+ #f)
+ (set-source-properties!
+ #{e 48598}#
+ #{s 47923}#))
+ #{e 48598}#))
+ '(())
+ #{s 47923}#
+ #{mod 47925}#))
+ #{tmp 48023}#)
+ (let ((#{tmp 48681}#
+ ($sc-dispatch
+ #{e 47920}#
+ '(_ any))))
+ (if (if #{tmp 48681}#
+ (@apply
+ (lambda (#{name 48685}#)
+ (if (symbol?
+ #{name 48685}#)
+ #t
+ (if (if (vector?
+ #{name 48685}#)
+ (if (= (vector-length
+ #{name 48685}#)
+ 4)
+ (eq? (vector-ref
+ #{name 48685}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol?
+ (vector-ref
+ #{name 48685}#
+ 1))
+ #f)))
+ #{tmp 48681}#)
+ #f)
+ (@apply
+ (lambda (#{name 48712}#)
+ (values
+ 'define-form
+ (if (if (null? (car #{w 47922}#))
+ (null? (cdr #{w 47922}#))
+ #f)
+ #{name 48712}#
+ (if (if (vector?
+ #{name 48712}#)
+ (if (= (vector-length
+ #{name 48712}#)
+ 4)
+ (eq? (vector-ref
+ #{name 48712}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 48742}#
+ (vector-ref
+ #{name 48712}#
+ 1))
+ (#{wrap 48743}#
+ (let ((#{w2 48753}#
+ (vector-ref
+ #{name 48712}#
+ 2)))
+ (let ((#{m1 48754}#
+ (car #{w 47922}#))
+ (#{s1 48755}#
+ (cdr #{w 47922}#)))
+ (if (null? #{m1 48754}#)
+ (if (null? #{s1 48755}#)
+ #{w2 48753}#
+ (cons (car #{w2 48753}#)
+ (let ((#{m2 48772}#
+ (cdr #{w2 48753}#)))
+ (if (null? #{m2 48772}#)
+ #{s1 48755}#
+ (append
+ #{s1 48755}#
+ #{m2 48772}#)))))
+ (cons (let ((#{m2 48780}#
+ (car #{w2 48753}#)))
+ (if (null? #{m2 48780}#)
+ #{m1 48754}#
+ (append
+ #{m1 48754}#
+ #{m2 48780}#)))
+ (let ((#{m2 48788}#
+ (cdr #{w2 48753}#)))
+ (if (null? #{m2 48788}#)
+ #{s1 48755}#
+ (append
+ #{s1 48755}#
+ #{m2 48788}#))))))))
+ (#{module 48744}#
+ (vector-ref
+ #{name 48712}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 48742}#
+ #{wrap 48743}#
+ #{module 48744}#))
+ (if (null? #{name 48712}#)
+ #{name 48712}#
+ (vector
+ 'syntax-object
+ #{name 48712}#
+ #{w 47922}#
+ #{mod 47925}#))))
+ '(#(syntax-object
+ if
+ ((top)
+ #(ribcage
+ #(name)
+ #((top))
+ #("i25792"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(ftype
+ fval
+ fe
+ fw
+ fs
+ fmod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i25732"
+ "i25733"
+ "i25734"
+ "i25735"
+ "i25736"
+ "i25737"))
+ #(ribcage () () ())
+ #(ribcage
+ #(first)
+ #((top))
+ #("i25724"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(e
+ r
+ w
+ s
+ rib
+ mod
+ for-car?)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i25703"
+ "i25704"
+ "i25705"
+ "i25706"
+ "i25707"
+ "i25708"
+ "i25709"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873"
+ "i23872"
+ "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile))
+ #(syntax-object
+ #f
+ ((top)
+ #(ribcage
+ #(name)
+ #((top))
+ #("i25792"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(ftype
+ fval
+ fe
+ fw
+ fs
+ fmod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i25732"
+ "i25733"
+ "i25734"
+ "i25735"
+ "i25736"
+ "i25737"))
+ #(ribcage () () ())
+ #(ribcage
+ #(first)
+ #((top))
+ #("i25724"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(e
+ r
+ w
+ s
+ rib
+ mod
+ for-car?)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i25703"
+ "i25704"
+ "i25705"
+ "i25706"
+ "i25707"
+ "i25708"
+ "i25709"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873"
+ "i23872"
+ "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile))
+ #(syntax-object
+ #f
+ ((top)
+ #(ribcage
+ #(name)
+ #((top))
+ #("i25792"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(ftype
+ fval
+ fe
+ fw
+ fs
+ fmod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i25732"
+ "i25733"
+ "i25734"
+ "i25735"
+ "i25736"
+ "i25737"))
+ #(ribcage () () ())
+ #(ribcage
+ #(first)
+ #((top))
+ #("i25724"))
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(e
+ r
+ w
+ s
+ rib
+ mod
+ for-car?)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i25703"
+ "i25704"
+ "i25705"
+ "i25706"
+ "i25707"
+ "i25708"
+ "i25709"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873"
+ "i23872"
+ "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ '(())
+ #{s 47923}#
+ #{mod 47925}#))
+ #{tmp 48681}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 47920}#)))))))
+ (if (eqv? #{ftype 47942}# 'define-syntax)
+ (let ((#{tmp 48827}#
($sc-dispatch
- #{e 19497}#
+ #{e 47920}#
'(_ any any))))
- (if (if #{tmp 19588}#
+ (if (if #{tmp 48827}#
(@apply
- (lambda (#{name 19592}#
- #{val 19593}#)
- (if (symbol? #{name 19592}#)
+ (lambda (#{name 48831}#
+ #{val 48832}#)
+ (if (symbol? #{name 48831}#)
#t
(if (if (vector?
- #{name 19592}#)
+ #{name 48831}#)
(if (= (vector-length
- #{name 19592}#)
+ #{name 48831}#)
4)
(eq? (vector-ref
- #{name 19592}#
+ #{name 48831}#
0)
'syntax-object)
#f)
#f)
(symbol?
(vector-ref
- #{name 19592}#
+ #{name 48831}#
1))
#f)))
- #{tmp 19588}#)
+ #{tmp 48827}#)
#f)
(@apply
- (lambda (#{name 19620}#
- #{val 19621}#)
+ (lambda (#{name 48859}#
+ #{val 48860}#)
(values
- 'define-form
- #{name 19620}#
- #{val 19621}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#))
- #{tmp 19588}#)
- (let ((#{tmp 19622}#
- ($sc-dispatch
- #{e 19497}#
- '(_ (any . any)
- any
- .
- each-any))))
- (if (if #{tmp 19622}#
- (@apply
- (lambda (#{name 19626}#
- #{args 19627}#
- #{e1 19628}#
- #{e2 19629}#)
- (if (if (symbol?
- #{name 19626}#)
- #t
- (if (if (vector?
- #{name 19626}#)
- (if (= (vector-length
- #{name 19626}#)
- 4)
- (eq? (vector-ref
- #{name 19626}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- #{name 19626}#
- 1))
- #f))
- (#{valid-bound-ids? 4440}#
- (letrec*
- ((#{lvl 19778}#
- (lambda (#{vars 19780}#
- #{ls 19781}#
- #{w 19782}#)
- (if (pair? #{vars 19780}#)
- (#{lvl 19778}#
- (cdr #{vars 19780}#)
- (cons (#{wrap 4443}#
- (car #{vars 19780}#)
- #{w 19782}#
- #f)
- #{ls 19781}#)
- #{w 19782}#)
- (if (if (symbol?
- #{vars 19780}#)
- #t
- (if (if (vector?
- #{vars 19780}#)
- (if (= (vector-length
- #{vars 19780}#)
- 4)
- (eq? (vector-ref
- #{vars 19780}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- #{vars 19780}#
- 1))
- #f))
- (cons (#{wrap 4443}#
- #{vars 19780}#
- #{w 19782}#
- #f)
- #{ls 19781}#)
- (if (null? #{vars 19780}#)
- #{ls 19781}#
- (if (if (vector?
- #{vars 19780}#)
- (if (= (vector-length
- #{vars 19780}#)
- 4)
- (eq? (vector-ref
- #{vars 19780}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (#{lvl 19778}#
- (vector-ref
- #{vars 19780}#
- 1)
- #{ls 19781}#
- (#{join-wraps 4431}#
- #{w 19782}#
- (vector-ref
- #{vars 19780}#
- 2)))
- (cons #{vars 19780}#
- #{ls 19781}#))))))))
- (#{lvl 19778}#
- #{args 19627}#
- '()
- '(()))))
- #f))
- #{tmp 19622}#)
- #f)
- (@apply
- (lambda (#{name 19826}#
- #{args 19827}#
- #{e1 19828}#
- #{e2 19829}#)
- (values
- 'define-form
- (#{wrap 4443}#
- #{name 19826}#
- #{w 19499}#
- #{mod 19502}#)
- (let ((#{e 19835}#
- (cons '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(name
- args
- e1
- e2)
- #((top)
- (top)
- (top)
- (top))
- #("i1899"
- "i1900"
- "i1901"
- "i1902"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(ftype
- fval
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i1852"
- "i1853"
- "i1854"
- "i1855"
- "i1856"
- "i1857"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(first)
- #((top))
- #("i1844"))
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
- for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i1816"
- "i1817"
- "i1818"
- "i1819"
- "i1820"
- "i1821"
- "i1822"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene
- guile))
- (#{wrap 4443}#
- (cons #{args 19827}#
- (cons #{e1 19828}#
- #{e2 19829}#))
- #{w 19499}#
- #{mod 19502}#))))
- (begin
- (if (if (pair? #{e 19835}#)
- #{s 19500}#
- #f)
- (set-source-properties!
- #{e 19835}#
- #{s 19500}#))
- #{e 19835}#))
- '(())
- #{s 19500}#
- #{mod 19502}#))
- #{tmp 19622}#)
- (let ((#{tmp 19842}#
- ($sc-dispatch
- #{e 19497}#
- '(_ any))))
- (if (if #{tmp 19842}#
- (@apply
- (lambda (#{name 19846}#)
- (if (symbol?
- #{name 19846}#)
- #t
- (if (if (vector?
- #{name 19846}#)
- (if (= (vector-length
- #{name 19846}#)
- 4)
- (eq? (vector-ref
- #{name 19846}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- #{name 19846}#
- 1))
- #f)))
- #{tmp 19842}#)
- #f)
- (@apply
- (lambda (#{name 19873}#)
- (values
- 'define-form
- (#{wrap 4443}#
- #{name 19873}#
- #{w 19499}#
- #{mod 19502}#)
- '(#(syntax-object
- if
- ((top)
- #(ribcage
- #(name)
- #((top))
- #("i1912"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ftype
- fval
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i1852"
- "i1853"
- "i1854"
- "i1855"
- "i1856"
- "i1857"))
- #(ribcage () () ())
- #(ribcage
- #(first)
- #((top))
- #("i1844"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
- for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i1816"
- "i1817"
- "i1818"
- "i1819"
- "i1820"
- "i1821"
- "i1822"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene guile))
- #(syntax-object
- #f
- ((top)
- #(ribcage
- #(name)
- #((top))
- #("i1912"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ftype
- fval
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i1852"
- "i1853"
- "i1854"
- "i1855"
- "i1856"
- "i1857"))
- #(ribcage () () ())
- #(ribcage
- #(first)
- #((top))
- #("i1844"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
- for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i1816"
- "i1817"
- "i1818"
- "i1819"
- "i1820"
- "i1821"
- "i1822"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene guile))
- #(syntax-object
- #f
- ((top)
- #(ribcage
- #(name)
- #((top))
- #("i1912"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(ftype
- fval
- fe
- fw
- fs
- fmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i1852"
- "i1853"
- "i1854"
- "i1855"
- "i1856"
- "i1857"))
- #(ribcage () () ())
- #(ribcage
- #(first)
- #((top))
- #("i1844"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(e
- r
- w
- s
- rib
- mod
- for-car?)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i1816"
- "i1817"
- "i1818"
- "i1819"
- "i1820"
- "i1821"
- "i1822"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene guile)))
- '(())
- #{s 19500}#
- #{mod 19502}#))
- #{tmp 19842}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{e 19497}#)))))))
- (if (eqv? #{ftype 19541}# 'define-syntax)
- (let ((#{tmp 19892}#
+ 'define-syntax-form
+ #{name 48859}#
+ #{val 48860}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#))
+ #{tmp 48827}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 47920}#)))
+ (if (eqv? #{ftype 47942}#
+ 'define-syntax-parameter)
+ (let ((#{tmp 48871}#
($sc-dispatch
- #{e 19497}#
+ #{e 47920}#
'(_ any any))))
- (if (if #{tmp 19892}#
+ (if (if #{tmp 48871}#
(@apply
- (lambda (#{name 19896}#
- #{val 19897}#)
- (if (symbol? #{name 19896}#)
+ (lambda (#{name 48875}#
+ #{val 48876}#)
+ (if (symbol? #{name 48875}#)
#t
(if (if (vector?
- #{name 19896}#)
+ #{name 48875}#)
(if (= (vector-length
- #{name 19896}#)
+ #{name 48875}#)
4)
(eq? (vector-ref
- #{name 19896}#
+ #{name 48875}#
0)
'syntax-object)
#f)
#f)
(symbol?
(vector-ref
- #{name 19896}#
+ #{name 48875}#
1))
#f)))
- #{tmp 19892}#)
+ #{tmp 48871}#)
#f)
(@apply
- (lambda (#{name 19924}#
- #{val 19925}#)
+ (lambda (#{name 48903}#
+ #{val 48904}#)
(values
- 'define-syntax-form
- #{name 19924}#
- #{val 19925}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#))
- #{tmp 19892}#)
+ 'define-syntax-parameter-form
+ #{name 48903}#
+ #{val 48904}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#))
+ #{tmp 48871}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{e 19497}#)))
- (if (eqv? #{ftype 19541}#
- 'define-syntax-parameter)
- (let ((#{tmp 19936}#
- ($sc-dispatch
- #{e 19497}#
- '(_ any any))))
- (if (if #{tmp 19936}#
- (@apply
- (lambda (#{name 19940}#
- #{val 19941}#)
- (if (symbol?
- #{name 19940}#)
- #t
- (if (if (vector?
- #{name 19940}#)
- (if (= (vector-length
- #{name 19940}#)
- 4)
- (eq? (vector-ref
- #{name 19940}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- #{name 19940}#
- 1))
- #f)))
- #{tmp 19936}#)
- #f)
- (@apply
- (lambda (#{name 19968}#
- #{val 19969}#)
- (values
- 'define-syntax-parameter-form
- #{name 19968}#
- #{val 19969}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#))
- #{tmp 19936}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{e 19497}#)))
- (values
- 'call
- #f
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)))))))))))))))
- (if (if (vector? #{e 19497}#)
- (if (= (vector-length #{e 19497}#) 4)
- (eq? (vector-ref #{e 19497}# 0) 'syntax-object)
- #f)
+ #{e 47920}#)))
+ (values
+ 'call
+ #f
+ #{e 47920}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#)))))))))))))))
+ (if (if (vector? #{e 47920}#)
+ (if (= (vector-length #{e 47920}#) 4)
+ (eq? (vector-ref #{e 47920}# 0) 'syntax-object)
#f)
- (#{syntax-type 4449}#
- (vector-ref #{e 19497}# 1)
- #{r 19498}#
- (#{join-wraps 4431}#
- #{w 19499}#
- (vector-ref #{e 19497}# 2))
- (let ((#{t 19996}#
- (#{source-annotation 4408}# #{e 19497}#)))
- (if #{t 19996}# #{t 19996}# #{s 19500}#))
- #{rib 19501}#
- (let ((#{t 20231}# (vector-ref #{e 19497}# 3)))
- (if #{t 20231}# #{t 20231}# #{mod 19502}#))
- #{for-car? 19503}#)
- (if (self-evaluating? #{e 19497}#)
- (values
- 'constant
- #f
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)
- (values
- 'other
- #f
- #{e 19497}#
- #{w 19499}#
- #{s 19500}#
- #{mod 19502}#)))))))
- (#{expand 4450}#
- (lambda (#{e 20240}#
- #{r 20241}#
- #{w 20242}#
- #{mod 20243}#)
- (call-with-values
- (lambda ()
- (#{syntax-type 4449}#
- #{e 20240}#
- #{r 20241}#
- #{w 20242}#
- (#{source-annotation 4408}# #{e 20240}#)
- #f
- #{mod 20243}#
- #f))
- (lambda (#{type 20398}#
- #{value 20399}#
- #{e 20400}#
- #{w 20401}#
- #{s 20402}#
- #{mod 20403}#)
- (#{expand-expr 4451}#
- #{type 20398}#
- #{value 20399}#
- #{e 20400}#
- #{r 20241}#
- #{w 20401}#
- #{s 20402}#
- #{mod 20403}#)))))
- (#{expand-expr 4451}#
- (lambda (#{type 20406}#
- #{value 20407}#
- #{e 20408}#
- #{r 20409}#
- #{w 20410}#
- #{s 20411}#
- #{mod 20412}#)
- (if (eqv? #{type 20406}# 'lexical)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- #{s 20411}#
- #{e 20408}#
- #{value 20407}#)
- (if (if (eqv? #{type 20406}# 'core)
- #t
- (eqv? #{type 20406}# 'core-form))
- (#{value 20407}#
- #{e 20408}#
- #{r 20409}#
- #{w 20410}#
- #{s 20411}#
- #{mod 20412}#)
- (if (eqv? #{type 20406}# 'module-ref)
- (call-with-values
- (lambda ()
- (#{value 20407}#
- #{e 20408}#
- #{r 20409}#
- #{w 20410}#))
- (lambda (#{e 20438}#
- #{r 20439}#
- #{w 20440}#
- #{s 20441}#
- #{mod 20442}#)
- (#{expand 4450}#
- #{e 20438}#
- #{r 20439}#
- #{w 20440}#
- #{mod 20442}#)))
- (if (eqv? #{type 20406}# 'lexical-call)
- (#{expand-application 4452}#
- (let ((#{id 20517}# (car #{e 20408}#)))
- (#{build-lexical-reference 4385}#
- 'fun
- (#{source-annotation 4408}# #{id 20517}#)
- (if (if (vector? #{id 20517}#)
- (if (= (vector-length #{id 20517}#) 4)
- (eq? (vector-ref #{id 20517}# 0) 'syntax-object)
- #f)
+ #f)
+ (#{syntax-type 28270}#
+ (vector-ref #{e 47920}# 1)
+ #{r 47921}#
+ (let ((#{w2 48929}# (vector-ref #{e 47920}# 2)))
+ (let ((#{m1 48930}# (car #{w 47922}#))
+ (#{s1 48931}# (cdr #{w 47922}#)))
+ (if (null? #{m1 48930}#)
+ (if (null? #{s1 48931}#)
+ #{w2 48929}#
+ (cons (car #{w2 48929}#)
+ (let ((#{m2 48942}# (cdr #{w2 48929}#)))
+ (if (null? #{m2 48942}#)
+ #{s1 48931}#
+ (append #{s1 48931}# #{m2 48942}#)))))
+ (cons (let ((#{m2 48950}# (car #{w2 48929}#)))
+ (if (null? #{m2 48950}#)
+ #{m1 48930}#
+ (append #{m1 48930}# #{m2 48950}#)))
+ (let ((#{m2 48958}# (cdr #{w2 48929}#)))
+ (if (null? #{m2 48958}#)
+ #{s1 48931}#
+ (append #{s1 48931}# #{m2 48958}#)))))))
+ (let ((#{t 48963}#
+ (#{source-annotation 28232}# #{e 47920}#)))
+ (if #{t 48963}# #{t 48963}# #{s 47923}#))
+ #{rib 47924}#
+ (let ((#{t 49239}# (vector-ref #{e 47920}# 3)))
+ (if #{t 49239}# #{t 49239}# #{mod 47925}#))
+ #{for-car? 47926}#)
+ (if (self-evaluating? #{e 47920}#)
+ (values
+ 'constant
+ #f
+ #{e 47920}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#)
+ (values
+ 'other
+ #f
+ #{e 47920}#
+ #{w 47922}#
+ #{s 47923}#
+ #{mod 47925}#)))))))
+ (#{expand 28271}#
+ (lambda (#{e 49248}#
+ #{r 49249}#
+ #{w 49250}#
+ #{mod 49251}#)
+ (call-with-values
+ (lambda ()
+ (#{syntax-type 28270}#
+ #{e 49248}#
+ #{r 49249}#
+ #{w 49250}#
+ (#{source-annotation 28232}# #{e 49248}#)
+ #f
+ #{mod 49251}#
+ #f))
+ (lambda (#{type 49437}#
+ #{value 49438}#
+ #{e 49439}#
+ #{w 49440}#
+ #{s 49441}#
+ #{mod 49442}#)
+ (#{expand-expr 28272}#
+ #{type 49437}#
+ #{value 49438}#
+ #{e 49439}#
+ #{r 49249}#
+ #{w 49440}#
+ #{s 49441}#
+ #{mod 49442}#)))))
+ (#{expand-expr 28272}#
+ (lambda (#{type 49445}#
+ #{value 49446}#
+ #{e 49447}#
+ #{r 49448}#
+ #{w 49449}#
+ #{s 49450}#
+ #{mod 49451}#)
+ (if (eqv? #{type 49445}# 'lexical)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 3)
+ #{s 49450}#
+ #{e 49447}#
+ #{value 49446}#)
+ (if (if (eqv? #{type 49445}# 'core)
+ #t
+ (eqv? #{type 49445}# 'core-form))
+ (#{value 49446}#
+ #{e 49447}#
+ #{r 49448}#
+ #{w 49449}#
+ #{s 49450}#
+ #{mod 49451}#)
+ (if (eqv? #{type 49445}# 'module-ref)
+ (call-with-values
+ (lambda ()
+ (#{value 49446}#
+ #{e 49447}#
+ #{r 49448}#
+ #{w 49449}#))
+ (lambda (#{e 49477}#
+ #{r 49478}#
+ #{w 49479}#
+ #{s 49480}#
+ #{mod 49481}#)
+ (#{expand 28271}#
+ #{e 49477}#
+ #{r 49478}#
+ #{w 49479}#
+ #{mod 49481}#)))
+ (if (eqv? #{type 49445}# 'lexical-call)
+ (#{expand-call 28273}#
+ (let ((#{id 49654}# (car #{e 49447}#)))
+ (#{build-lexical-reference 28208}#
+ 'fun
+ (#{source-annotation 28232}# #{id 49654}#)
+ (if (if (vector? #{id 49654}#)
+ (if (= (vector-length #{id 49654}#) 4)
+ (eq? (vector-ref #{id 49654}# 0) 'syntax-object)
#f)
- (syntax->datum #{id 20517}#)
- #{id 20517}#)
- #{value 20407}#))
- #{e 20408}#
- #{r 20409}#
- #{w 20410}#
- #{s 20411}#
- #{mod 20412}#)
- (if (eqv? #{type 20406}# 'global-call)
- (#{expand-application 4452}#
- (#{build-global-reference 4388}#
- (#{source-annotation 4408}# (car #{e 20408}#))
- (if (if (vector? #{value 20407}#)
- (if (= (vector-length #{value 20407}#) 4)
- (eq? (vector-ref #{value 20407}# 0)
- 'syntax-object)
- #f)
+ #f)
+ (syntax->datum #{id 49654}#)
+ #{id 49654}#)
+ #{value 49446}#))
+ #{e 49447}#
+ #{r 49448}#
+ #{w 49449}#
+ #{s 49450}#
+ #{mod 49451}#)
+ (if (eqv? #{type 49445}# 'global-call)
+ (#{expand-call 28273}#
+ (#{build-global-reference 28211}#
+ (#{source-annotation 28232}# (car #{e 49447}#))
+ (if (if (vector? #{value 49446}#)
+ (if (= (vector-length #{value 49446}#) 4)
+ (eq? (vector-ref #{value 49446}# 0)
+ 'syntax-object)
#f)
- (vector-ref #{value 20407}# 1)
- #{value 20407}#)
- (if (if (vector? #{value 20407}#)
- (if (= (vector-length #{value 20407}#) 4)
- (eq? (vector-ref #{value 20407}# 0)
- 'syntax-object)
- #f)
+ #f)
+ (vector-ref #{value 49446}# 1)
+ #{value 49446}#)
+ (if (if (vector? #{value 49446}#)
+ (if (= (vector-length #{value 49446}#) 4)
+ (eq? (vector-ref #{value 49446}# 0)
+ 'syntax-object)
#f)
- (vector-ref #{value 20407}# 3)
- #{mod 20412}#))
- #{e 20408}#
- #{r 20409}#
- #{w 20410}#
- #{s 20411}#
- #{mod 20412}#)
- (if (eqv? #{type 20406}# 'constant)
- (let ((#{exp 20854}#
- (#{strip 4463}#
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 20408}#) #{s 20411}# #f)
- (set-source-properties!
- #{e 20408}#
- #{s 20411}#))
- #{e 20408}#)
- #{w 20410}#
- #{mod 20412}#)
- '(()))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #{s 20411}#
- #{exp 20854}#))
- (if (eqv? #{type 20406}# 'global)
- (#{analyze-variable 4387}#
- #{mod 20412}#
- #{value 20407}#
- (lambda (#{mod 20890}#
- #{var 20891}#
- #{public? 20892}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #{s 20411}#
- #{mod 20890}#
- #{var 20891}#
- #{public? 20892}#))
- (lambda (#{var 20901}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #{s 20411}#
- #{var 20901}#)))
- (if (eqv? #{type 20406}# 'call)
- (#{expand-application 4452}#
- (#{expand 4450}#
- (car #{e 20408}#)
- #{r 20409}#
- #{w 20410}#
- #{mod 20412}#)
- #{e 20408}#
- #{r 20409}#
- #{w 20410}#
- #{s 20411}#
- #{mod 20412}#)
- (if (eqv? #{type 20406}# 'begin-form)
- (let ((#{tmp 20976}#
- ($sc-dispatch
- #{e 20408}#
- '(_ any . each-any))))
- (if #{tmp 20976}#
- (@apply
- (lambda (#{e1 20980}# #{e2 20981}#)
- (#{expand-sequence 4445}#
- (cons #{e1 20980}# #{e2 20981}#)
- #{r 20409}#
- #{w 20410}#
- #{s 20411}#
- #{mod 20412}#))
- #{tmp 20976}#)
- (let ((#{tmp 21068}#
- ($sc-dispatch #{e 20408}# '(_))))
- (if #{tmp 21068}#
- (@apply
- (lambda ()
- (if (include-deprecated-features)
- (begin
- (issue-deprecation-warning
- "Sequences of zero expressions are deprecated. Use *unspecified*.")
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- #f))
- (syntax-violation
- #f
- "sequence of zero expressions"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 20408}#)
- #{s 20411}#
- #f)
- (set-source-properties!
- #{e 20408}#
- #{s 20411}#))
- #{e 20408}#)
- #{w 20410}#
- #{mod 20412}#))))
- #{tmp 21068}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{e 20408}#)))))
- (if (eqv? #{type 20406}# 'local-syntax-form)
- (#{expand-local-syntax 4455}#
- #{value 20407}#
- #{e 20408}#
- #{r 20409}#
- #{w 20410}#
- #{s 20411}#
- #{mod 20412}#
- #{expand-sequence 4445}#)
- (if (eqv? #{type 20406}# 'eval-when-form)
- (let ((#{tmp 21179}#
- ($sc-dispatch
- #{e 20408}#
- '(_ each-any any . each-any))))
- (if #{tmp 21179}#
- (@apply
- (lambda (#{x 21183}#
- #{e1 21184}#
- #{e2 21185}#)
- (let ((#{when-list 21186}#
- (#{parse-when-list 4448}#
- #{e 20408}#
- #{x 21183}#)))
- (if (memq 'eval #{when-list 21186}#)
- (#{expand-sequence 4445}#
- (cons #{e1 21184}# #{e2 21185}#)
- #{r 20409}#
- #{w 20410}#
- #{s 20411}#
- #{mod 20412}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- #f))))
- #{tmp 21179}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{e 20408}#)))
- (if (if (eqv? #{type 20406}# 'define-form)
+ #f)
+ (vector-ref #{value 49446}# 3)
+ #{mod 49451}#))
+ #{e 49447}#
+ #{r 49448}#
+ #{w 49449}#
+ #{s 49450}#
+ #{mod 49451}#)
+ (if (eqv? #{type 49445}# 'constant)
+ (let ((#{exp 50328}#
+ (#{strip 28284}#
+ (let ((#{x 50341}#
+ (begin
+ (if (if (pair? #{e 49447}#)
+ #{s 49450}#
+ #f)
+ (set-source-properties!
+ #{e 49447}#
+ #{s 49450}#))
+ #{e 49447}#)))
+ (if (if (null? (car #{w 49449}#))
+ (null? (cdr #{w 49449}#))
+ #f)
+ #{x 50341}#
+ (if (if (vector? #{x 50341}#)
+ (if (= (vector-length #{x 50341}#) 4)
+ (eq? (vector-ref #{x 50341}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 50373}#
+ (vector-ref #{x 50341}# 1))
+ (#{wrap 50374}#
+ (let ((#{w2 50382}#
+ (vector-ref #{x 50341}# 2)))
+ (let ((#{m1 50383}#
+ (car #{w 49449}#))
+ (#{s1 50384}#
+ (cdr #{w 49449}#)))
+ (if (null? #{m1 50383}#)
+ (if (null? #{s1 50384}#)
+ #{w2 50382}#
+ (cons (car #{w2 50382}#)
+ (let ((#{m2 50399}#
+ (cdr #{w2 50382}#)))
+ (if (null? #{m2 50399}#)
+ #{s1 50384}#
+ (append
+ #{s1 50384}#
+ #{m2 50399}#)))))
+ (cons (let ((#{m2 50407}#
+ (car #{w2 50382}#)))
+ (if (null? #{m2 50407}#)
+ #{m1 50383}#
+ (append
+ #{m1 50383}#
+ #{m2 50407}#)))
+ (let ((#{m2 50415}#
+ (cdr #{w2 50382}#)))
+ (if (null? #{m2 50415}#)
+ #{s1 50384}#
+ (append
+ #{s1 50384}#
+ #{m2 50415}#))))))))
+ (#{module 50375}#
+ (vector-ref #{x 50341}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 50373}#
+ #{wrap 50374}#
+ #{module 50375}#))
+ (if (null? #{x 50341}#)
+ #{x 50341}#
+ (vector
+ 'syntax-object
+ #{x 50341}#
+ #{w 49449}#
+ #{mod 49451}#)))))
+ '(()))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #{s 49450}#
+ #{exp 50328}#))
+ (if (eqv? #{type 49445}# 'global)
+ (#{analyze-variable 28210}#
+ #{mod 49451}#
+ #{value 49446}#
+ (lambda (#{mod 50440}# #{var 50441}# #{public? 50442}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 5)
+ #{s 49450}#
+ #{mod 50440}#
+ #{var 50441}#
+ #{public? 50442}#))
+ (lambda (#{var 50450}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 7)
+ #{s 49450}#
+ #{var 50450}#)))
+ (if (eqv? #{type 49445}# 'call)
+ (#{expand-call 28273}#
+ (#{expand 28271}#
+ (car #{e 49447}#)
+ #{r 49448}#
+ #{w 49449}#
+ #{mod 49451}#)
+ #{e 49447}#
+ #{r 49448}#
+ #{w 49449}#
+ #{s 49450}#
+ #{mod 49451}#)
+ (if (eqv? #{type 49445}# 'begin-form)
+ (let ((#{tmp 50620}#
+ ($sc-dispatch
+ #{e 49447}#
+ '(_ any . each-any))))
+ (if #{tmp 50620}#
+ (@apply
+ (lambda (#{e1 50624}# #{e2 50625}#)
+ (#{expand-sequence 28266}#
+ (cons #{e1 50624}# #{e2 50625}#)
+ #{r 49448}#
+ #{w 49449}#
+ #{s 49450}#
+ #{mod 49451}#))
+ #{tmp 50620}#)
+ (let ((#{tmp 50720}#
+ ($sc-dispatch #{e 49447}# '(_))))
+ (if #{tmp 50720}#
+ (@apply
+ (lambda ()
+ (begin
+ (issue-deprecation-warning
+ "Sequences of zero expressions are deprecated. Use *unspecified*.")
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 0)
+ #f)))
+ #{tmp 50720}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 49447}#)))))
+ (if (eqv? #{type 49445}# 'local-syntax-form)
+ (#{expand-local-syntax 28276}#
+ #{value 49446}#
+ #{e 49447}#
+ #{r 49448}#
+ #{w 49449}#
+ #{s 49450}#
+ #{mod 49451}#
+ #{expand-sequence 28266}#)
+ (if (eqv? #{type 49445}# 'eval-when-form)
+ (let ((#{tmp 50812}#
+ ($sc-dispatch
+ #{e 49447}#
+ '(_ each-any any . each-any))))
+ (if #{tmp 50812}#
+ (@apply
+ (lambda (#{x 50816}#
+ #{e1 50817}#
+ #{e2 50818}#)
+ (let ((#{when-list 50819}#
+ (#{parse-when-list 28269}#
+ #{e 49447}#
+ #{x 50816}#)))
+ (if (memq 'eval #{when-list 50819}#)
+ (#{expand-sequence 28266}#
+ (cons #{e1 50817}# #{e2 50818}#)
+ #{r 49448}#
+ #{w 49449}#
+ #{s 49450}#
+ #{mod 49451}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 0)
+ #f))))
+ #{tmp 50812}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 49447}#)))
+ (if (if (eqv? #{type 49445}# 'define-form)
+ #t
+ (if (eqv? #{type 49445}#
+ 'define-syntax-form)
#t
- (if (eqv? #{type 20406}#
- 'define-syntax-form)
- #t
- (eqv? #{type 20406}#
- 'define-syntax-parameter-form)))
+ (eqv? #{type 49445}#
+ 'define-syntax-parameter-form)))
+ (syntax-violation
+ #f
+ "definition in expression context"
+ #{e 49447}#
+ (if (if (null? (car #{w 49449}#))
+ (null? (cdr #{w 49449}#))
+ #f)
+ #{value 49446}#
+ (if (if (vector? #{value 49446}#)
+ (if (= (vector-length #{value 49446}#)
+ 4)
+ (eq? (vector-ref #{value 49446}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 51026}#
+ (vector-ref #{value 49446}# 1))
+ (#{wrap 51027}#
+ (let ((#{w2 51037}#
+ (vector-ref
+ #{value 49446}#
+ 2)))
+ (let ((#{m1 51038}#
+ (car #{w 49449}#))
+ (#{s1 51039}#
+ (cdr #{w 49449}#)))
+ (if (null? #{m1 51038}#)
+ (if (null? #{s1 51039}#)
+ #{w2 51037}#
+ (cons (car #{w2 51037}#)
+ (let ((#{m2 51056}#
+ (cdr #{w2 51037}#)))
+ (if (null? #{m2 51056}#)
+ #{s1 51039}#
+ (append
+ #{s1 51039}#
+ #{m2 51056}#)))))
+ (cons (let ((#{m2 51064}#
+ (car #{w2 51037}#)))
+ (if (null? #{m2 51064}#)
+ #{m1 51038}#
+ (append
+ #{m1 51038}#
+ #{m2 51064}#)))
+ (let ((#{m2 51072}#
+ (cdr #{w2 51037}#)))
+ (if (null? #{m2 51072}#)
+ #{s1 51039}#
+ (append
+ #{s1 51039}#
+ #{m2 51072}#))))))))
+ (#{module 51028}#
+ (vector-ref #{value 49446}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 51026}#
+ #{wrap 51027}#
+ #{module 51028}#))
+ (if (null? #{value 49446}#)
+ #{value 49446}#
+ (vector
+ 'syntax-object
+ #{value 49446}#
+ #{w 49449}#
+ #{mod 49451}#)))))
+ (if (eqv? #{type 49445}# 'syntax)
(syntax-violation
#f
- "definition in expression context"
- #{e 20408}#
- (#{wrap 4443}#
- #{value 20407}#
- #{w 20410}#
- #{mod 20412}#))
- (if (eqv? #{type 20406}# 'syntax)
+ "reference to pattern variable outside syntax form"
+ (let ((#{x 51107}#
+ (begin
+ (if (if (pair? #{e 49447}#)
+ #{s 49450}#
+ #f)
+ (set-source-properties!
+ #{e 49447}#
+ #{s 49450}#))
+ #{e 49447}#)))
+ (if (if (null? (car #{w 49449}#))
+ (null? (cdr #{w 49449}#))
+ #f)
+ #{x 51107}#
+ (if (if (vector? #{x 51107}#)
+ (if (= (vector-length #{x 51107}#)
+ 4)
+ (eq? (vector-ref #{x 51107}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 51139}#
+ (vector-ref #{x 51107}# 1))
+ (#{wrap 51140}#
+ (let ((#{w2 51148}#
+ (vector-ref
+ #{x 51107}#
+ 2)))
+ (let ((#{m1 51149}#
+ (car #{w 49449}#))
+ (#{s1 51150}#
+ (cdr #{w 49449}#)))
+ (if (null? #{m1 51149}#)
+ (if (null? #{s1 51150}#)
+ #{w2 51148}#
+ (cons (car #{w2 51148}#)
+ (let ((#{m2 51165}#
+ (cdr #{w2 51148}#)))
+ (if (null? #{m2 51165}#)
+ #{s1 51150}#
+ (append
+ #{s1 51150}#
+ #{m2 51165}#)))))
+ (cons (let ((#{m2 51173}#
+ (car #{w2 51148}#)))
+ (if (null? #{m2 51173}#)
+ #{m1 51149}#
+ (append
+ #{m1 51149}#
+ #{m2 51173}#)))
+ (let ((#{m2 51181}#
+ (cdr #{w2 51148}#)))
+ (if (null? #{m2 51181}#)
+ #{s1 51150}#
+ (append
+ #{s1 51150}#
+ #{m2 51181}#))))))))
+ (#{module 51141}#
+ (vector-ref #{x 51107}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 51139}#
+ #{wrap 51140}#
+ #{module 51141}#))
+ (if (null? #{x 51107}#)
+ #{x 51107}#
+ (vector
+ 'syntax-object
+ #{x 51107}#
+ #{w 49449}#
+ #{mod 49451}#))))))
+ (if (eqv? #{type 49445}# 'displaced-lexical)
(syntax-violation
#f
- "reference to pattern variable outside syntax form"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 20408}#)
- #{s 20411}#
- #f)
- (set-source-properties!
- #{e 20408}#
- #{s 20411}#))
- #{e 20408}#)
- #{w 20410}#
- #{mod 20412}#))
- (if (eqv? #{type 20406}# 'displaced-lexical)
- (syntax-violation
- #f
- "reference to identifier outside its scope"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 20408}#)
- #{s 20411}#
+ "reference to identifier outside its scope"
+ (let ((#{x 51208}#
+ (begin
+ (if (if (pair? #{e 49447}#)
+ #{s 49450}#
+ #f)
+ (set-source-properties!
+ #{e 49447}#
+ #{s 49450}#))
+ #{e 49447}#)))
+ (if (if (null? (car #{w 49449}#))
+ (null? (cdr #{w 49449}#))
+ #f)
+ #{x 51208}#
+ (if (if (vector? #{x 51208}#)
+ (if (= (vector-length
+ #{x 51208}#)
+ 4)
+ (eq? (vector-ref
+ #{x 51208}#
+ 0)
+ 'syntax-object)
#f)
- (set-source-properties!
- #{e 20408}#
- #{s 20411}#))
- #{e 20408}#)
- #{w 20410}#
- #{mod 20412}#))
- (syntax-violation
- #f
- "unexpected syntax"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 20408}#)
- #{s 20411}#
+ #f)
+ (let ((#{expression 51240}#
+ (vector-ref #{x 51208}# 1))
+ (#{wrap 51241}#
+ (let ((#{w2 51249}#
+ (vector-ref
+ #{x 51208}#
+ 2)))
+ (let ((#{m1 51250}#
+ (car #{w 49449}#))
+ (#{s1 51251}#
+ (cdr #{w 49449}#)))
+ (if (null? #{m1 51250}#)
+ (if (null? #{s1 51251}#)
+ #{w2 51249}#
+ (cons (car #{w2 51249}#)
+ (let ((#{m2 51266}#
+ (cdr #{w2 51249}#)))
+ (if (null? #{m2 51266}#)
+ #{s1 51251}#
+ (append
+ #{s1 51251}#
+ #{m2 51266}#)))))
+ (cons (let ((#{m2 51274}#
+ (car #{w2 51249}#)))
+ (if (null? #{m2 51274}#)
+ #{m1 51250}#
+ (append
+ #{m1 51250}#
+ #{m2 51274}#)))
+ (let ((#{m2 51282}#
+ (cdr #{w2 51249}#)))
+ (if (null? #{m2 51282}#)
+ #{s1 51251}#
+ (append
+ #{s1 51251}#
+ #{m2 51282}#))))))))
+ (#{module 51242}#
+ (vector-ref #{x 51208}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 51240}#
+ #{wrap 51241}#
+ #{module 51242}#))
+ (if (null? #{x 51208}#)
+ #{x 51208}#
+ (vector
+ 'syntax-object
+ #{x 51208}#
+ #{w 49449}#
+ #{mod 49451}#))))))
+ (syntax-violation
+ #f
+ "unexpected syntax"
+ (let ((#{x 51306}#
+ (begin
+ (if (if (pair? #{e 49447}#)
+ #{s 49450}#
+ #f)
+ (set-source-properties!
+ #{e 49447}#
+ #{s 49450}#))
+ #{e 49447}#)))
+ (if (if (null? (car #{w 49449}#))
+ (null? (cdr #{w 49449}#))
+ #f)
+ #{x 51306}#
+ (if (if (vector? #{x 51306}#)
+ (if (= (vector-length
+ #{x 51306}#)
+ 4)
+ (eq? (vector-ref
+ #{x 51306}#
+ 0)
+ 'syntax-object)
#f)
- (set-source-properties!
- #{e 20408}#
- #{s 20411}#))
- #{e 20408}#)
- #{w 20410}#
- #{mod 20412}#))))))))))))))))))
- (#{expand-application 4452}#
- (lambda (#{x 21426}#
- #{e 21427}#
- #{r 21428}#
- #{w 21429}#
- #{s 21430}#
- #{mod 21431}#)
- (let ((#{tmp 21433}#
- ($sc-dispatch #{e 21427}# '(any . each-any))))
- (if #{tmp 21433}#
- (@apply
- (lambda (#{e0 21437}# #{e1 21438}#)
- (#{build-application 4382}#
- #{s 21430}#
- #{x 21426}#
- (map (lambda (#{e 21518}#)
- (#{expand 4450}#
- #{e 21518}#
- #{r 21428}#
- #{w 21429}#
- #{mod 21431}#))
- #{e1 21438}#)))
- #{tmp 21433}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{e 21427}#)))))
- (#{expand-macro 4453}#
- (lambda (#{p 21594}#
- #{e 21595}#
- #{r 21596}#
- #{w 21597}#
- #{s 21598}#
- #{rib 21599}#
- #{mod 21600}#)
- (letrec*
- ((#{rebuild-macro-output 21601}#
- (lambda (#{x 21633}# #{m 21634}#)
- (if (pair? #{x 21633}#)
- (let ((#{e 21638}#
- (cons (#{rebuild-macro-output 21601}#
- (car #{x 21633}#)
- #{m 21634}#)
- (#{rebuild-macro-output 21601}#
- (cdr #{x 21633}#)
- #{m 21634}#))))
- (begin
- (if (if (pair? #{e 21638}#) #{s 21598}# #f)
- (set-source-properties! #{e 21638}# #{s 21598}#))
- #{e 21638}#))
- (if (if (vector? #{x 21633}#)
- (if (= (vector-length #{x 21633}#) 4)
- (eq? (vector-ref #{x 21633}# 0) 'syntax-object)
- #f)
+ #f)
+ (let ((#{expression 51338}#
+ (vector-ref #{x 51306}# 1))
+ (#{wrap 51339}#
+ (let ((#{w2 51347}#
+ (vector-ref
+ #{x 51306}#
+ 2)))
+ (let ((#{m1 51348}#
+ (car #{w 49449}#))
+ (#{s1 51349}#
+ (cdr #{w 49449}#)))
+ (if (null? #{m1 51348}#)
+ (if (null? #{s1 51349}#)
+ #{w2 51347}#
+ (cons (car #{w2 51347}#)
+ (let ((#{m2 51364}#
+ (cdr #{w2 51347}#)))
+ (if (null? #{m2 51364}#)
+ #{s1 51349}#
+ (append
+ #{s1 51349}#
+ #{m2 51364}#)))))
+ (cons (let ((#{m2 51372}#
+ (car #{w2 51347}#)))
+ (if (null? #{m2 51372}#)
+ #{m1 51348}#
+ (append
+ #{m1 51348}#
+ #{m2 51372}#)))
+ (let ((#{m2 51380}#
+ (cdr #{w2 51347}#)))
+ (if (null? #{m2 51380}#)
+ #{s1 51349}#
+ (append
+ #{s1 51349}#
+ #{m2 51380}#))))))))
+ (#{module 51340}#
+ (vector-ref #{x 51306}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 51338}#
+ #{wrap 51339}#
+ #{module 51340}#))
+ (if (null? #{x 51306}#)
+ #{x 51306}#
+ (vector
+ 'syntax-object
+ #{x 51306}#
+ #{w 49449}#
+ #{mod 49451}#))))))))))))))))))))))
+ (#{expand-call 28273}#
+ (lambda (#{x 51395}#
+ #{e 51396}#
+ #{r 51397}#
+ #{w 51398}#
+ #{s 51399}#
+ #{mod 51400}#)
+ (let ((#{tmp 51402}#
+ ($sc-dispatch #{e 51396}# '(any . each-any))))
+ (if #{tmp 51402}#
+ (@apply
+ (lambda (#{e0 51406}# #{e1 51407}#)
+ (#{build-call 28205}#
+ #{s 51399}#
+ #{x 51395}#
+ (map (lambda (#{e 51495}#)
+ (#{expand 28271}#
+ #{e 51495}#
+ #{r 51397}#
+ #{w 51398}#
+ #{mod 51400}#))
+ #{e1 51407}#)))
+ #{tmp 51402}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 51396}#)))))
+ (#{expand-macro 28274}#
+ (lambda (#{p 51579}#
+ #{e 51580}#
+ #{r 51581}#
+ #{w 51582}#
+ #{s 51583}#
+ #{rib 51584}#
+ #{mod 51585}#)
+ (letrec*
+ ((#{rebuild-macro-output 51586}#
+ (lambda (#{x 51693}# #{m 51694}#)
+ (if (pair? #{x 51693}#)
+ (let ((#{e 51698}#
+ (cons (#{rebuild-macro-output 51586}#
+ (car #{x 51693}#)
+ #{m 51694}#)
+ (#{rebuild-macro-output 51586}#
+ (cdr #{x 51693}#)
+ #{m 51694}#))))
+ (begin
+ (if (if (pair? #{e 51698}#) #{s 51583}# #f)
+ (set-source-properties! #{e 51698}# #{s 51583}#))
+ #{e 51698}#))
+ (if (if (vector? #{x 51693}#)
+ (if (= (vector-length #{x 51693}#) 4)
+ (eq? (vector-ref #{x 51693}# 0) 'syntax-object)
#f)
- (let ((#{w 21654}# (vector-ref #{x 21633}# 2)))
- (let ((#{ms 21655}# (car #{w 21654}#))
- (#{s 21656}# (cdr #{w 21654}#)))
- (if (if (pair? #{ms 21655}#)
- (eq? (car #{ms 21655}#) #f)
- #f)
- (let ((#{expression 21664}#
- (vector-ref #{x 21633}# 1))
- (#{wrap 21665}#
- (cons (cdr #{ms 21655}#)
- (if #{rib 21599}#
- (cons #{rib 21599}#
- (cdr #{s 21656}#))
- (cdr #{s 21656}#))))
- (#{module 21666}# (vector-ref #{x 21633}# 3)))
- (vector
- 'syntax-object
- #{expression 21664}#
- #{wrap 21665}#
- #{module 21666}#))
- (let ((#{expression 21676}#
- (let ((#{e 21681}#
- (vector-ref #{x 21633}# 1)))
- (begin
- (if (if (pair? #{e 21681}#)
- #{s 21656}#
- #f)
- (set-source-properties!
- #{e 21681}#
- #{s 21656}#))
- #{e 21681}#)))
- (#{wrap 21677}#
- (cons (cons #{m 21634}# #{ms 21655}#)
- (if #{rib 21599}#
- (cons #{rib 21599}#
- (cons 'shift #{s 21656}#))
- (cons 'shift #{s 21656}#))))
- (#{module 21678}# (vector-ref #{x 21633}# 3)))
- (vector
- 'syntax-object
- #{expression 21676}#
- #{wrap 21677}#
- #{module 21678}#)))))
- (if (vector? #{x 21633}#)
- (let ((#{n 21693}# (vector-length #{x 21633}#)))
- (let ((#{v 21694}#
- (let ((#{e 21702}# (make-vector #{n 21693}#)))
+ #f)
+ (let ((#{w 51714}# (vector-ref #{x 51693}# 2)))
+ (let ((#{ms 51715}# (car #{w 51714}#))
+ (#{s 51716}# (cdr #{w 51714}#)))
+ (if (if (pair? #{ms 51715}#)
+ (eq? (car #{ms 51715}#) #f)
+ #f)
+ (let ((#{expression 51724}# (vector-ref #{x 51693}# 1))
+ (#{wrap 51725}#
+ (cons (cdr #{ms 51715}#)
+ (if #{rib 51584}#
+ (cons #{rib 51584}# (cdr #{s 51716}#))
+ (cdr #{s 51716}#))))
+ (#{module 51726}# (vector-ref #{x 51693}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 51724}#
+ #{wrap 51725}#
+ #{module 51726}#))
+ (let ((#{expression 51736}#
+ (let ((#{e 51741}# (vector-ref #{x 51693}# 1)))
(begin
- (if (if (pair? #{e 21702}#) #{x 21633}# #f)
+ (if (if (pair? #{e 51741}#) #{s 51716}# #f)
(set-source-properties!
- #{e 21702}#
- #{x 21633}#))
- #{e 21702}#))))
- (letrec*
- ((#{loop 21695}#
- (lambda (#{i 21747}#)
- (if (= #{i 21747}# #{n 21693}#)
- #{v 21694}#
- (begin
- (vector-set!
- #{v 21694}#
- #{i 21747}#
- (#{rebuild-macro-output 21601}#
- (vector-ref #{x 21633}# #{i 21747}#)
- #{m 21634}#))
- (#{loop 21695}# (#{1+}# #{i 21747}#)))))))
- (#{loop 21695}# 0))))
- (if (symbol? #{x 21633}#)
- (syntax-violation
- #f
- "encountered raw symbol in macro output"
- (let ((#{s 21753}# (cdr #{w 21597}#)))
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 21595}#) #{s 21753}# #f)
- (set-source-properties!
- #{e 21595}#
- #{s 21753}#))
- #{e 21595}#)
- #{w 21597}#
- #{mod 21600}#))
- #{x 21633}#)
- (begin
- (if (if (pair? #{x 21633}#) #{s 21598}# #f)
- (set-source-properties! #{x 21633}# #{s 21598}#))
- #{x 21633}#))))))))
- (with-fluids
- ((#{transformer-environment 4436}#
- (lambda (#{k 21602}#)
- (#{k 21602}#
- #{e 21595}#
- #{r 21596}#
- #{w 21597}#
- #{s 21598}#
- #{rib 21599}#
- #{mod 21600}#))))
- (#{rebuild-macro-output 21601}#
- (#{p 21594}#
- (let ((#{w 21609}#
- (cons (cons #f (car #{w 21597}#))
- (cons 'shift (cdr #{w 21597}#)))))
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 21595}#) #{s 21598}# #f)
- (set-source-properties! #{e 21595}# #{s 21598}#))
- #{e 21595}#)
- #{w 21609}#
- #{mod 21600}#)))
- (gensym "m"))))))
- (#{expand-body 4454}#
- (lambda (#{body 21785}#
- #{outer-form 21786}#
- #{r 21787}#
- #{w 21788}#
- #{mod 21789}#)
- (let ((#{r 21790}#
- (cons '("placeholder" placeholder) #{r 21787}#)))
- (let ((#{ribcage 21791}# (vector 'ribcage '() '() '())))
- (let ((#{w 21792}#
- (cons (car #{w 21788}#)
- (cons #{ribcage 21791}# (cdr #{w 21788}#)))))
- (letrec*
- ((#{parse 21793}#
- (lambda (#{body 21806}#
- #{ids 21807}#
- #{labels 21808}#
- #{var-ids 21809}#
- #{vars 21810}#
- #{vals 21811}#
- #{bindings 21812}#)
- (if (null? #{body 21806}#)
- (syntax-violation
- #f
- "no expressions in body"
- #{outer-form 21786}#)
- (let ((#{e 21813}# (cdr (car #{body 21806}#)))
- (#{er 21814}# (car (car #{body 21806}#))))
- (call-with-values
- (lambda ()
- (#{syntax-type 4449}#
- #{e 21813}#
- #{er 21814}#
- '(())
- (#{source-annotation 4408}# #{er 21814}#)
- #{ribcage 21791}#
- #{mod 21789}#
- #f))
- (lambda (#{type 21971}#
- #{value 21972}#
- #{e 21973}#
- #{w 21974}#
- #{s 21975}#
- #{mod 21976}#)
- (if (eqv? #{type 21971}# 'define-form)
- (let ((#{id 21980}#
- (#{wrap 4443}#
- #{value 21972}#
- #{w 21974}#
- #{mod 21976}#))
- (#{label 21981}#
- (symbol->string (gensym "i"))))
- (let ((#{var 21982}#
- (let ((#{id 22042}#
- (if (if (vector?
- #{id 21980}#)
- (if (= (vector-length
- #{id 21980}#)
- 4)
- (eq? (vector-ref
- #{id 21980}#
- 0)
- 'syntax-object)
- #f)
+ #{e 51741}#
+ #{s 51716}#))
+ #{e 51741}#)))
+ (#{wrap 51737}#
+ (cons (cons #{m 51694}# #{ms 51715}#)
+ (if #{rib 51584}#
+ (cons #{rib 51584}#
+ (cons 'shift #{s 51716}#))
+ (cons 'shift #{s 51716}#))))
+ (#{module 51738}# (vector-ref #{x 51693}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 51736}#
+ #{wrap 51737}#
+ #{module 51738}#)))))
+ (if (vector? #{x 51693}#)
+ (let ((#{n 51753}# (vector-length #{x 51693}#)))
+ (let ((#{v 51754}#
+ (let ((#{e 51820}# (make-vector #{n 51753}#)))
+ (begin
+ (if (if (pair? #{e 51820}#) #{x 51693}# #f)
+ (set-source-properties!
+ #{e 51820}#
+ #{x 51693}#))
+ #{e 51820}#))))
+ (letrec*
+ ((#{loop 51755}#
+ (lambda (#{i 51816}#)
+ (if (= #{i 51816}# #{n 51753}#)
+ #{v 51754}#
+ (begin
+ (vector-set!
+ #{v 51754}#
+ #{i 51816}#
+ (#{rebuild-macro-output 51586}#
+ (vector-ref #{x 51693}# #{i 51816}#)
+ #{m 51694}#))
+ (#{loop 51755}# (#{1+}# #{i 51816}#)))))))
+ (#{loop 51755}# 0))))
+ (if (symbol? #{x 51693}#)
+ (syntax-violation
+ #f
+ "encountered raw symbol in macro output"
+ (let ((#{s 51831}# (cdr #{w 51582}#)))
+ (let ((#{x 51835}#
+ (begin
+ (if (if (pair? #{e 51580}#) #{s 51831}# #f)
+ (set-source-properties!
+ #{e 51580}#
+ #{s 51831}#))
+ #{e 51580}#)))
+ (if (if (null? (car #{w 51582}#))
+ (null? (cdr #{w 51582}#))
+ #f)
+ #{x 51835}#
+ (if (if (vector? #{x 51835}#)
+ (if (= (vector-length #{x 51835}#) 4)
+ (eq? (vector-ref #{x 51835}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 51867}#
+ (vector-ref #{x 51835}# 1))
+ (#{wrap 51868}#
+ (let ((#{w2 51876}#
+ (vector-ref #{x 51835}# 2)))
+ (let ((#{m1 51877}#
+ (car #{w 51582}#))
+ (#{s1 51878}#
+ (cdr #{w 51582}#)))
+ (if (null? #{m1 51877}#)
+ (if (null? #{s1 51878}#)
+ #{w2 51876}#
+ (cons (car #{w2 51876}#)
+ (let ((#{m2 51893}#
+ (cdr #{w2 51876}#)))
+ (if (null? #{m2 51893}#)
+ #{s1 51878}#
+ (append
+ #{s1 51878}#
+ #{m2 51893}#)))))
+ (cons (let ((#{m2 51901}#
+ (car #{w2 51876}#)))
+ (if (null? #{m2 51901}#)
+ #{m1 51877}#
+ (append
+ #{m1 51877}#
+ #{m2 51901}#)))
+ (let ((#{m2 51909}#
+ (cdr #{w2 51876}#)))
+ (if (null? #{m2 51909}#)
+ #{s1 51878}#
+ (append
+ #{s1 51878}#
+ #{m2 51909}#))))))))
+ (#{module 51869}#
+ (vector-ref #{x 51835}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 51867}#
+ #{wrap 51868}#
+ #{module 51869}#))
+ (if (null? #{x 51835}#)
+ #{x 51835}#
+ (vector
+ 'syntax-object
+ #{x 51835}#
+ #{w 51582}#
+ #{mod 51585}#))))))
+ #{x 51693}#)
+ (begin
+ (if (if (pair? #{x 51693}#) #{s 51583}# #f)
+ (set-source-properties! #{x 51693}# #{s 51583}#))
+ #{x 51693}#))))))))
+ (#{rebuild-macro-output 51586}#
+ (#{p 51579}#
+ (let ((#{w 51593}#
+ (cons (cons #f (car #{w 51582}#))
+ (cons 'shift (cdr #{w 51582}#)))))
+ (let ((#{x 51598}#
+ (begin
+ (if (if (pair? #{e 51580}#) #{s 51583}# #f)
+ (set-source-properties! #{e 51580}# #{s 51583}#))
+ #{e 51580}#)))
+ (if (if (null? (car #{w 51593}#))
+ (null? (cdr #{w 51593}#))
+ #f)
+ #{x 51598}#
+ (if (if (vector? #{x 51598}#)
+ (if (= (vector-length #{x 51598}#) 4)
+ (eq? (vector-ref #{x 51598}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 51636}# (vector-ref #{x 51598}# 1))
+ (#{wrap 51637}#
+ (let ((#{w2 51645}# (vector-ref #{x 51598}# 2)))
+ (let ((#{m1 51646}# (car #{w 51593}#))
+ (#{s1 51647}# (cdr #{w 51593}#)))
+ (if (null? #{m1 51646}#)
+ (if (null? #{s1 51647}#)
+ #{w2 51645}#
+ (cons (car #{w2 51645}#)
+ (let ((#{m2 51662}#
+ (cdr #{w2 51645}#)))
+ (if (null? #{m2 51662}#)
+ #{s1 51647}#
+ (append
+ #{s1 51647}#
+ #{m2 51662}#)))))
+ (cons (let ((#{m2 51670}#
+ (car #{w2 51645}#)))
+ (if (null? #{m2 51670}#)
+ #{m1 51646}#
+ (append
+ #{m1 51646}#
+ #{m2 51670}#)))
+ (let ((#{m2 51678}#
+ (cdr #{w2 51645}#)))
+ (if (null? #{m2 51678}#)
+ #{s1 51647}#
+ (append
+ #{s1 51647}#
+ #{m2 51678}#))))))))
+ (#{module 51638}# (vector-ref #{x 51598}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 51636}#
+ #{wrap 51637}#
+ #{module 51638}#))
+ (if (null? #{x 51598}#)
+ #{x 51598}#
+ (vector
+ 'syntax-object
+ #{x 51598}#
+ #{w 51593}#
+ #{mod 51585}#)))))))
+ (gensym "m")))))
+ (#{expand-body 28275}#
+ (lambda (#{body 51939}#
+ #{outer-form 51940}#
+ #{r 51941}#
+ #{w 51942}#
+ #{mod 51943}#)
+ (let ((#{r 51944}#
+ (cons '("placeholder" placeholder) #{r 51941}#)))
+ (let ((#{ribcage 51945}# (vector 'ribcage '() '() '())))
+ (let ((#{w 51946}#
+ (cons (car #{w 51942}#)
+ (cons #{ribcage 51945}# (cdr #{w 51942}#)))))
+ (letrec*
+ ((#{parse 51947}#
+ (lambda (#{body 52055}#
+ #{ids 52056}#
+ #{labels 52057}#
+ #{var-ids 52058}#
+ #{vars 52059}#
+ #{vals 52060}#
+ #{bindings 52061}#)
+ (if (null? #{body 52055}#)
+ (syntax-violation
+ #f
+ "no expressions in body"
+ #{outer-form 51940}#)
+ (let ((#{e 52062}# (cdr (car #{body 52055}#)))
+ (#{er 52063}# (car (car #{body 52055}#))))
+ (call-with-values
+ (lambda ()
+ (#{syntax-type 28270}#
+ #{e 52062}#
+ #{er 52063}#
+ '(())
+ (#{source-annotation 28232}# #{er 52063}#)
+ #{ribcage 51945}#
+ #{mod 51943}#
+ #f))
+ (lambda (#{type 52251}#
+ #{value 52252}#
+ #{e 52253}#
+ #{w 52254}#
+ #{s 52255}#
+ #{mod 52256}#)
+ (if (eqv? #{type 52251}# 'define-form)
+ (let ((#{id 52260}#
+ (if (if (null? (car #{w 52254}#))
+ (null? (cdr #{w 52254}#))
+ #f)
+ #{value 52252}#
+ (if (if (vector? #{value 52252}#)
+ (if (= (vector-length
+ #{value 52252}#)
+ 4)
+ (eq? (vector-ref
+ #{value 52252}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 52305}#
+ (vector-ref
+ #{value 52252}#
+ 1))
+ (#{wrap 52306}#
+ (let ((#{w2 52316}#
+ (vector-ref
+ #{value 52252}#
+ 2)))
+ (let ((#{m1 52317}#
+ (car #{w 52254}#))
+ (#{s1 52318}#
+ (cdr #{w 52254}#)))
+ (if (null? #{m1 52317}#)
+ (if (null? #{s1 52318}#)
+ #{w2 52316}#
+ (cons (car #{w2 52316}#)
+ (let ((#{m2 52335}#
+ (cdr #{w2 52316}#)))
+ (if (null? #{m2 52335}#)
+ #{s1 52318}#
+ (append
+ #{s1 52318}#
+ #{m2 52335}#)))))
+ (cons (let ((#{m2 52343}#
+ (car #{w2 52316}#)))
+ (if (null? #{m2 52343}#)
+ #{m1 52317}#
+ (append
+ #{m1 52317}#
+ #{m2 52343}#)))
+ (let ((#{m2 52351}#
+ (cdr #{w2 52316}#)))
+ (if (null? #{m2 52351}#)
+ #{s1 52318}#
+ (append
+ #{s1 52318}#
+ #{m2 52351}#))))))))
+ (#{module 52307}#
+ (vector-ref
+ #{value 52252}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 52305}#
+ #{wrap 52306}#
+ #{module 52307}#))
+ (if (null? #{value 52252}#)
+ #{value 52252}#
+ (vector
+ 'syntax-object
+ #{value 52252}#
+ #{w 52254}#
+ #{mod 52256}#)))))
+ (#{label 52261}#
+ (symbol->string (gensym "i"))))
+ (let ((#{var 52262}#
+ (let ((#{id 52412}#
+ (if (if (vector? #{id 52260}#)
+ (if (= (vector-length
+ #{id 52260}#)
+ 4)
+ (eq? (vector-ref
+ #{id 52260}#
+ 0)
+ 'syntax-object)
#f)
- (vector-ref #{id 21980}# 1)
- #{id 21980}#)))
- (gensym
- (string-append
- (symbol->string #{id 22042}#)
- " ")))))
+ #f)
+ (vector-ref #{id 52260}# 1)
+ #{id 52260}#)))
+ (gensym
+ (string-append
+ (symbol->string #{id 52412}#)
+ " ")))))
+ (begin
(begin
- (let ((#{update 22032}#
- (cons (vector-ref #{id 21980}# 1)
+ (let ((#{update 52271}#
+ (cons (vector-ref #{id 52260}# 1)
(vector-ref
- #{ribcage 21791}#
+ #{ribcage 51945}#
1))))
(vector-set!
- #{ribcage 21791}#
+ #{ribcage 51945}#
1
- #{update 22032}#))
- (let ((#{update 22034}#
+ #{update 52271}#))
+ (let ((#{update 52383}#
(cons (car (vector-ref
- #{id 21980}#
+ #{id 52260}#
2))
(vector-ref
- #{ribcage 21791}#
+ #{ribcage 51945}#
2))))
(vector-set!
- #{ribcage 21791}#
+ #{ribcage 51945}#
2
- #{update 22034}#))
- (let ((#{update 22036}#
- (cons #{label 21981}#
+ #{update 52383}#))
+ (let ((#{update 52398}#
+ (cons #{label 52261}#
(vector-ref
- #{ribcage 21791}#
+ #{ribcage 51945}#
3))))
(vector-set!
- #{ribcage 21791}#
+ #{ribcage 51945}#
3
- #{update 22036}#))
- (#{parse 21793}#
- (cdr #{body 21806}#)
- (cons #{id 21980}# #{ids 21807}#)
- (cons #{label 21981}# #{labels 21808}#)
- (cons #{id 21980}# #{var-ids 21809}#)
- (cons #{var 21982}# #{vars 21810}#)
- (cons (cons #{er 21814}#
- (#{wrap 4443}#
- #{e 21973}#
- #{w 21974}#
- #{mod 21976}#))
- #{vals 21811}#)
- (cons (cons 'lexical #{var 21982}#)
- #{bindings 21812}#)))))
- (if (if (eqv? #{type 21971}#
- 'define-syntax-form)
- #t
- (eqv? #{type 21971}#
- 'define-syntax-parameter-form))
- (let ((#{id 22075}#
- (#{wrap 4443}#
- #{value 21972}#
- #{w 21974}#
- #{mod 21976}#))
- (#{label 22076}#
- (symbol->string (gensym "i"))))
+ #{update 52398}#)))
+ (#{parse 51947}#
+ (cdr #{body 52055}#)
+ (cons #{id 52260}# #{ids 52056}#)
+ (cons #{label 52261}# #{labels 52057}#)
+ (cons #{id 52260}# #{var-ids 52058}#)
+ (cons #{var 52262}# #{vars 52059}#)
+ (cons (cons #{er 52063}#
+ (if (if (null? (car #{w 52254}#))
+ (null? (cdr #{w 52254}#))
+ #f)
+ #{e 52253}#
+ (if (if (vector?
+ #{e 52253}#)
+ (if (= (vector-length
+ #{e 52253}#)
+ 4)
+ (eq? (vector-ref
+ #{e 52253}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 52464}#
+ (vector-ref
+ #{e 52253}#
+ 1))
+ (#{wrap 52465}#
+ (let ((#{w2 52475}#
+ (vector-ref
+ #{e 52253}#
+ 2)))
+ (let ((#{m1 52476}#
+ (car #{w 52254}#))
+ (#{s1 52477}#
+ (cdr #{w 52254}#)))
+ (if (null? #{m1 52476}#)
+ (if (null? #{s1 52477}#)
+ #{w2 52475}#
+ (cons (car #{w2 52475}#)
+ (let ((#{m2 52494}#
+ (cdr #{w2 52475}#)))
+ (if (null? #{m2 52494}#)
+ #{s1 52477}#
+ (append
+ #{s1 52477}#
+ #{m2 52494}#)))))
+ (cons (let ((#{m2 52502}#
+ (car #{w2 52475}#)))
+ (if (null? #{m2 52502}#)
+ #{m1 52476}#
+ (append
+ #{m1 52476}#
+ #{m2 52502}#)))
+ (let ((#{m2 52510}#
+ (cdr #{w2 52475}#)))
+ (if (null? #{m2 52510}#)
+ #{s1 52477}#
+ (append
+ #{s1 52477}#
+ #{m2 52510}#))))))))
+ (#{module 52466}#
+ (vector-ref
+ #{e 52253}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 52464}#
+ #{wrap 52465}#
+ #{module 52466}#))
+ (if (null? #{e 52253}#)
+ #{e 52253}#
+ (vector
+ 'syntax-object
+ #{e 52253}#
+ #{w 52254}#
+ #{mod 52256}#)))))
+ #{vals 52060}#)
+ (cons (cons 'lexical #{var 52262}#)
+ #{bindings 52061}#)))))
+ (if (if (eqv? #{type 52251}# 'define-syntax-form)
+ #t
+ (eqv? #{type 52251}#
+ 'define-syntax-parameter-form))
+ (let ((#{id 52541}#
+ (if (if (null? (car #{w 52254}#))
+ (null? (cdr #{w 52254}#))
+ #f)
+ #{value 52252}#
+ (if (if (vector? #{value 52252}#)
+ (if (= (vector-length
+ #{value 52252}#)
+ 4)
+ (eq? (vector-ref
+ #{value 52252}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 52585}#
+ (vector-ref
+ #{value 52252}#
+ 1))
+ (#{wrap 52586}#
+ (let ((#{w2 52596}#
+ (vector-ref
+ #{value 52252}#
+ 2)))
+ (let ((#{m1 52597}#
+ (car #{w 52254}#))
+ (#{s1 52598}#
+ (cdr #{w 52254}#)))
+ (if (null? #{m1 52597}#)
+ (if (null? #{s1 52598}#)
+ #{w2 52596}#
+ (cons (car #{w2 52596}#)
+ (let ((#{m2 52615}#
+ (cdr #{w2 52596}#)))
+ (if (null? #{m2 52615}#)
+ #{s1 52598}#
+ (append
+ #{s1 52598}#
+ #{m2 52615}#)))))
+ (cons (let ((#{m2 52623}#
+ (car #{w2 52596}#)))
+ (if (null? #{m2 52623}#)
+ #{m1 52597}#
+ (append
+ #{m1 52597}#
+ #{m2 52623}#)))
+ (let ((#{m2 52631}#
+ (cdr #{w2 52596}#)))
+ (if (null? #{m2 52631}#)
+ #{s1 52598}#
+ (append
+ #{s1 52598}#
+ #{m2 52631}#))))))))
+ (#{module 52587}#
+ (vector-ref
+ #{value 52252}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 52585}#
+ #{wrap 52586}#
+ #{module 52587}#))
+ (if (null? #{value 52252}#)
+ #{value 52252}#
+ (vector
+ 'syntax-object
+ #{value 52252}#
+ #{w 52254}#
+ #{mod 52256}#)))))
+ (#{label 52542}#
+ (symbol->string (gensym "i"))))
+ (begin
(begin
- (let ((#{update 22126}#
- (cons (vector-ref #{id 22075}# 1)
+ (let ((#{update 52551}#
+ (cons (vector-ref #{id 52541}# 1)
(vector-ref
- #{ribcage 21791}#
+ #{ribcage 51945}#
1))))
(vector-set!
- #{ribcage 21791}#
+ #{ribcage 51945}#
1
- #{update 22126}#))
- (let ((#{update 22128}#
+ #{update 52551}#))
+ (let ((#{update 52663}#
(cons (car (vector-ref
- #{id 22075}#
+ #{id 52541}#
2))
(vector-ref
- #{ribcage 21791}#
+ #{ribcage 51945}#
2))))
(vector-set!
- #{ribcage 21791}#
+ #{ribcage 51945}#
2
- #{update 22128}#))
- (let ((#{update 22130}#
- (cons #{label 22076}#
+ #{update 52663}#))
+ (let ((#{update 52678}#
+ (cons #{label 52542}#
(vector-ref
- #{ribcage 21791}#
+ #{ribcage 51945}#
3))))
(vector-set!
- #{ribcage 21791}#
+ #{ribcage 51945}#
3
- #{update 22130}#))
- (#{parse 21793}#
- (cdr #{body 21806}#)
- (cons #{id 22075}# #{ids 21807}#)
- (cons #{label 22076}# #{labels 21808}#)
- #{var-ids 21809}#
- #{vars 21810}#
- #{vals 21811}#
- (cons (cons 'macro
- (cons #{er 21814}#
- (#{wrap 4443}#
- #{e 21973}#
- #{w 21974}#
- #{mod 21976}#)))
- #{bindings 21812}#))))
- (if (eqv? #{type 21971}# 'begin-form)
- (let ((#{tmp 22138}#
- ($sc-dispatch
- #{e 21973}#
- '(_ . each-any))))
- (if #{tmp 22138}#
- (@apply
- (lambda (#{e1 22142}#)
- (#{parse 21793}#
- (letrec*
- ((#{f 22143}#
- (lambda (#{forms 22206}#)
- (if (null? #{forms 22206}#)
- (cdr #{body 21806}#)
- (cons (cons #{er 21814}#
- (#{wrap 4443}#
- (car #{forms 22206}#)
- #{w 21974}#
- #{mod 21976}#))
- (#{f 22143}#
- (cdr #{forms 22206}#)))))))
- (#{f 22143}# #{e1 22142}#))
- #{ids 21807}#
- #{labels 21808}#
- #{var-ids 21809}#
- #{vars 21810}#
- #{vals 21811}#
- #{bindings 21812}#))
- #{tmp 22138}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{e 21973}#)))
- (if (eqv? #{type 21971}#
- 'local-syntax-form)
- (#{expand-local-syntax 4455}#
- #{value 21972}#
- #{e 21973}#
- #{er 21814}#
- #{w 21974}#
- #{s 21975}#
- #{mod 21976}#
- (lambda (#{forms 22220}#
- #{er 22221}#
- #{w 22222}#
- #{s 22223}#
- #{mod 22224}#)
- (#{parse 21793}#
+ #{update 52678}#)))
+ (#{parse 51947}#
+ (cdr #{body 52055}#)
+ (cons #{id 52541}# #{ids 52056}#)
+ (cons #{label 52542}# #{labels 52057}#)
+ #{var-ids 52058}#
+ #{vars 52059}#
+ #{vals 52060}#
+ (cons (cons (if (eq? #{type 52251}#
+ 'define-syntax-parameter-form)
+ 'syntax-parameter
+ 'macro)
+ (cons #{er 52063}#
+ (if (if (null? (car #{w 52254}#))
+ (null? (cdr #{w 52254}#))
+ #f)
+ #{e 52253}#
+ (if (if (vector?
+ #{e 52253}#)
+ (if (= (vector-length
+ #{e 52253}#)
+ 4)
+ (eq? (vector-ref
+ #{e 52253}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 52717}#
+ (vector-ref
+ #{e 52253}#
+ 1))
+ (#{wrap 52718}#
+ (let ((#{w2 52728}#
+ (vector-ref
+ #{e 52253}#
+ 2)))
+ (let ((#{m1 52729}#
+ (car #{w 52254}#))
+ (#{s1 52730}#
+ (cdr #{w 52254}#)))
+ (if (null? #{m1 52729}#)
+ (if (null? #{s1 52730}#)
+ #{w2 52728}#
+ (cons (car #{w2 52728}#)
+ (let ((#{m2 52747}#
+ (cdr #{w2 52728}#)))
+ (if (null? #{m2 52747}#)
+ #{s1 52730}#
+ (append
+ #{s1 52730}#
+ #{m2 52747}#)))))
+ (cons (let ((#{m2 52755}#
+ (car #{w2 52728}#)))
+ (if (null? #{m2 52755}#)
+ #{m1 52729}#
+ (append
+ #{m1 52729}#
+ #{m2 52755}#)))
+ (let ((#{m2 52763}#
+ (cdr #{w2 52728}#)))
+ (if (null? #{m2 52763}#)
+ #{s1 52730}#
+ (append
+ #{s1 52730}#
+ #{m2 52763}#))))))))
+ (#{module 52719}#
+ (vector-ref
+ #{e 52253}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 52717}#
+ #{wrap 52718}#
+ #{module 52719}#))
+ (if (null? #{e 52253}#)
+ #{e 52253}#
+ (vector
+ 'syntax-object
+ #{e 52253}#
+ #{w 52254}#
+ #{mod 52256}#))))))
+ #{bindings 52061}#))))
+ (if (eqv? #{type 52251}# 'begin-form)
+ (let ((#{tmp 52790}#
+ ($sc-dispatch
+ #{e 52253}#
+ '(_ . each-any))))
+ (if #{tmp 52790}#
+ (@apply
+ (lambda (#{e1 52794}#)
+ (#{parse 51947}#
(letrec*
- ((#{f 22225}#
- (lambda (#{forms 22288}#)
- (if (null? #{forms 22288}#)
- (cdr #{body 21806}#)
- (cons (cons #{er 22221}#
- (#{wrap 4443}#
- (car #{forms 22288}#)
- #{w 22222}#
- #{mod 22224}#))
- (#{f 22225}#
- (cdr #{forms 22288}#)))))))
- (#{f 22225}# #{forms 22220}#))
- #{ids 21807}#
- #{labels 21808}#
- #{var-ids 21809}#
- #{vars 21810}#
- #{vals 21811}#
- #{bindings 21812}#)))
- (if (null? #{ids 21807}#)
- (#{build-sequence 4396}#
- #f
- (map (lambda (#{x 22353}#)
- (let ((#{e 22357}#
- (cdr #{x 22353}#))
- (#{r 22358}#
- (car #{x 22353}#)))
- (call-with-values
- (lambda ()
- (#{syntax-type 4449}#
- #{e 22357}#
- #{r 22358}#
- '(())
- (#{source-annotation 4408}#
- #{e 22357}#)
- #f
- #{mod 21976}#
- #f))
- (lambda (#{type 22362}#
- #{value 22363}#
- #{e 22364}#
- #{w 22365}#
- #{s 22366}#
- #{mod 22367}#)
- (#{expand-expr 4451}#
- #{type 22362}#
- #{value 22363}#
- #{e 22364}#
- #{r 22358}#
- #{w 22365}#
- #{s 22366}#
- #{mod 22367}#)))))
- (cons (cons #{er 21814}#
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 21973}#)
- #{s 21975}#
- #f)
- (set-source-properties!
- #{e 21973}#
- #{s 21975}#))
- #{e 21973}#)
- #{w 21974}#
- #{mod 21976}#))
- (cdr #{body 21806}#))))
- (begin
- (if (not (#{valid-bound-ids? 4440}#
- #{ids 21807}#))
- (syntax-violation
- #f
- "invalid or duplicate identifier in definition"
- #{outer-form 21786}#))
+ ((#{f 52795}#
+ (lambda (#{forms 52996}#)
+ (if (null? #{forms 52996}#)
+ (cdr #{body 52055}#)
+ (cons (cons #{er 52063}#
+ (let ((#{x 53000}#
+ (car #{forms 52996}#)))
+ (if (if (null? (car #{w 52254}#))
+ (null? (cdr #{w 52254}#))
+ #f)
+ #{x 53000}#
+ (if (if (vector?
+ #{x 53000}#)
+ (if (= (vector-length
+ #{x 53000}#)
+ 4)
+ (eq? (vector-ref
+ #{x 53000}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 53018}#
+ (vector-ref
+ #{x 53000}#
+ 1))
+ (#{wrap 53019}#
+ (let ((#{w2 53027}#
+ (vector-ref
+ #{x 53000}#
+ 2)))
+ (let ((#{m1 53028}#
+ (car #{w 52254}#))
+ (#{s1 53029}#
+ (cdr #{w 52254}#)))
+ (if (null? #{m1 53028}#)
+ (if (null? #{s1 53029}#)
+ #{w2 53027}#
+ (cons (car #{w2 53027}#)
+ (let ((#{m2 53044}#
+ (cdr #{w2 53027}#)))
+ (if (null? #{m2 53044}#)
+ #{s1 53029}#
+ (append
+ #{s1 53029}#
+ #{m2 53044}#)))))
+ (cons (let ((#{m2 53052}#
+ (car #{w2 53027}#)))
+ (if (null? #{m2 53052}#)
+ #{m1 53028}#
+ (append
+ #{m1 53028}#
+ #{m2 53052}#)))
+ (let ((#{m2 53060}#
+ (cdr #{w2 53027}#)))
+ (if (null? #{m2 53060}#)
+ #{s1 53029}#
+ (append
+ #{s1 53029}#
+ #{m2 53060}#))))))))
+ (#{module 53020}#
+ (vector-ref
+ #{x 53000}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 53018}#
+ #{wrap 53019}#
+ #{module 53020}#))
+ (if (null? #{x 53000}#)
+ #{x 53000}#
+ (vector
+ 'syntax-object
+ #{x 53000}#
+ #{w 52254}#
+ #{mod 52256}#))))))
+ (#{f 52795}#
+ (cdr #{forms 52996}#)))))))
+ (#{f 52795}# #{e1 52794}#))
+ #{ids 52056}#
+ #{labels 52057}#
+ #{var-ids 52058}#
+ #{vars 52059}#
+ #{vals 52060}#
+ #{bindings 52061}#))
+ #{tmp 52790}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 52253}#)))
+ (if (eqv? #{type 52251}# 'local-syntax-form)
+ (#{expand-local-syntax 28276}#
+ #{value 52252}#
+ #{e 52253}#
+ #{er 52063}#
+ #{w 52254}#
+ #{s 52255}#
+ #{mod 52256}#
+ (lambda (#{forms 53086}#
+ #{er 53087}#
+ #{w 53088}#
+ #{s 53089}#
+ #{mod 53090}#)
+ (#{parse 51947}#
(letrec*
- ((#{loop 22468}#
- (lambda (#{bs 22471}#
- #{er-cache 22472}#
- #{r-cache 22473}#)
- (if (not (null? #{bs 22471}#))
- (let ((#{b 22474}#
- (car #{bs 22471}#)))
- (if (eq? (car #{b 22474}#)
- 'macro)
- (let ((#{er 22476}#
- (car (cdr #{b 22474}#))))
- (let ((#{r-cache 22477}#
- (if (eq? #{er 22476}#
- #{er-cache 22472}#)
- #{r-cache 22473}#
- (#{macros-only-env 4411}#
- #{er 22476}#))))
- (begin
+ ((#{f 53091}#
+ (lambda (#{forms 53292}#)
+ (if (null? #{forms 53292}#)
+ (cdr #{body 52055}#)
+ (cons (cons #{er 53087}#
+ (let ((#{x 53296}#
+ (car #{forms 53292}#)))
+ (if (if (null? (car #{w 53088}#))
+ (null? (cdr #{w 53088}#))
+ #f)
+ #{x 53296}#
+ (if (if (vector?
+ #{x 53296}#)
+ (if (= (vector-length
+ #{x 53296}#)
+ 4)
+ (eq? (vector-ref
+ #{x 53296}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 53314}#
+ (vector-ref
+ #{x 53296}#
+ 1))
+ (#{wrap 53315}#
+ (let ((#{w2 53323}#
+ (vector-ref
+ #{x 53296}#
+ 2)))
+ (let ((#{m1 53324}#
+ (car #{w 53088}#))
+ (#{s1 53325}#
+ (cdr #{w 53088}#)))
+ (if (null? #{m1 53324}#)
+ (if (null? #{s1 53325}#)
+ #{w2 53323}#
+ (cons (car #{w2 53323}#)
+ (let ((#{m2 53340}#
+ (cdr #{w2 53323}#)))
+ (if (null? #{m2 53340}#)
+ #{s1 53325}#
+ (append
+ #{s1 53325}#
+ #{m2 53340}#)))))
+ (cons (let ((#{m2 53348}#
+ (car #{w2 53323}#)))
+ (if (null? #{m2 53348}#)
+ #{m1 53324}#
+ (append
+ #{m1 53324}#
+ #{m2 53348}#)))
+ (let ((#{m2 53356}#
+ (cdr #{w2 53323}#)))
+ (if (null? #{m2 53356}#)
+ #{s1 53325}#
+ (append
+ #{s1 53325}#
+ #{m2 53356}#))))))))
+ (#{module 53316}#
+ (vector-ref
+ #{x 53296}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 53314}#
+ #{wrap 53315}#
+ #{module 53316}#))
+ (if (null? #{x 53296}#)
+ #{x 53296}#
+ (vector
+ 'syntax-object
+ #{x 53296}#
+ #{w 53088}#
+ #{mod 53090}#))))))
+ (#{f 53091}#
+ (cdr #{forms 53292}#)))))))
+ (#{f 53091}# #{forms 53086}#))
+ #{ids 52056}#
+ #{labels 52057}#
+ #{var-ids 52058}#
+ #{vars 52059}#
+ #{vals 52060}#
+ #{bindings 52061}#)))
+ (if (null? #{ids 52056}#)
+ (#{build-sequence 28220}#
+ #f
+ (map (lambda (#{x 53441}#)
+ (#{expand 28271}#
+ (cdr #{x 53441}#)
+ (car #{x 53441}#)
+ '(())
+ #{mod 52256}#))
+ (cons (cons #{er 52063}#
+ (let ((#{x 53516}#
+ (begin
+ (if (if (pair? #{e 52253}#)
+ #{s 52255}#
+ #f)
+ (set-source-properties!
+ #{e 52253}#
+ #{s 52255}#))
+ #{e 52253}#)))
+ (if (if (null? (car #{w 52254}#))
+ (null? (cdr #{w 52254}#))
+ #f)
+ #{x 53516}#
+ (if (if (vector?
+ #{x 53516}#)
+ (if (= (vector-length
+ #{x 53516}#)
+ 4)
+ (eq? (vector-ref
+ #{x 53516}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 53548}#
+ (vector-ref
+ #{x 53516}#
+ 1))
+ (#{wrap 53549}#
+ (let ((#{w2 53557}#
+ (vector-ref
+ #{x 53516}#
+ 2)))
+ (let ((#{m1 53558}#
+ (car #{w 52254}#))
+ (#{s1 53559}#
+ (cdr #{w 52254}#)))
+ (if (null? #{m1 53558}#)
+ (if (null? #{s1 53559}#)
+ #{w2 53557}#
+ (cons (car #{w2 53557}#)
+ (let ((#{m2 53574}#
+ (cdr #{w2 53557}#)))
+ (if (null? #{m2 53574}#)
+ #{s1 53559}#
+ (append
+ #{s1 53559}#
+ #{m2 53574}#)))))
+ (cons (let ((#{m2 53582}#
+ (car #{w2 53557}#)))
+ (if (null? #{m2 53582}#)
+ #{m1 53558}#
+ (append
+ #{m1 53558}#
+ #{m2 53582}#)))
+ (let ((#{m2 53590}#
+ (cdr #{w2 53557}#)))
+ (if (null? #{m2 53590}#)
+ #{s1 53559}#
+ (append
+ #{s1 53559}#
+ #{m2 53590}#))))))))
+ (#{module 53550}#
+ (vector-ref
+ #{x 53516}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 53548}#
+ #{wrap 53549}#
+ #{module 53550}#))
+ (if (null? #{x 53516}#)
+ #{x 53516}#
+ (vector
+ 'syntax-object
+ #{x 53516}#
+ #{w 52254}#
+ #{mod 52256}#))))))
+ (cdr #{body 52055}#))))
+ (begin
+ (if (not (#{valid-bound-ids? 28261}#
+ #{ids 52056}#))
+ (syntax-violation
+ #f
+ "invalid or duplicate identifier in definition"
+ #{outer-form 51940}#))
+ (letrec*
+ ((#{loop 53689}#
+ (lambda (#{bs 53692}#
+ #{er-cache 53693}#
+ #{r-cache 53694}#)
+ (if (not (null? #{bs 53692}#))
+ (let ((#{b 53695}#
+ (car #{bs 53692}#)))
+ (if (let ((#{t 53698}#
+ (car #{b 53695}#)))
+ (if (eq? #{t 53698}#
+ 'macro)
+ #t
+ (eq? #{t 53698}#
+ 'syntax-parameter)))
+ (let ((#{er 53700}#
+ (car (cdr #{b 53695}#))))
+ (let ((#{r-cache 53701}#
+ (if (eq? #{er 53700}#
+ #{er-cache 53693}#)
+ #{r-cache 53694}#
+ (#{macros-only-env 28235}#
+ #{er 53700}#))))
+ (begin
+ (set-cdr!
+ #{b 53695}#
+ (#{eval-local-transformer 28277}#
+ (#{expand 28271}#
+ (cdr (cdr #{b 53695}#))
+ #{r-cache 53701}#
+ '(())
+ #{mod 52256}#)
+ #{mod 52256}#))
+ (if (eq? (car #{b 53695}#)
+ 'syntax-parameter)
(set-cdr!
- #{b 22474}#
- (#{eval-local-transformer 4456}#
- (#{expand 4450}#
- (cdr (cdr #{b 22474}#))
- #{r-cache 22477}#
- '(())
- #{mod 21976}#)
- #{mod 21976}#))
- (#{loop 22468}#
- (cdr #{bs 22471}#)
- #{er 22476}#
- #{r-cache 22477}#))))
- (#{loop 22468}#
- (cdr #{bs 22471}#)
- #{er-cache 22472}#
- #{r-cache 22473}#)))))))
- (#{loop 22468}#
- #{bindings 21812}#
- #f
- #f))
- (set-cdr!
- #{r 21790}#
- (#{extend-env 4409}#
- #{labels 21808}#
- #{bindings 21812}#
- (cdr #{r 21790}#)))
- (#{build-letrec 4399}#
+ #{b 53695}#
+ (list (cdr #{b 53695}#))))
+ (#{loop 53689}#
+ (cdr #{bs 53692}#)
+ #{er 53700}#
+ #{r-cache 53701}#))))
+ (#{loop 53689}#
+ (cdr #{bs 53692}#)
+ #{er-cache 53693}#
+ #{r-cache 53694}#)))))))
+ (#{loop 53689}#
+ #{bindings 52061}#
#f
- #t
- (reverse
- (map syntax->datum
- #{var-ids 21809}#))
- (reverse #{vars 21810}#)
- (map (lambda (#{x 22820}#)
- (let ((#{e 22824}#
- (cdr #{x 22820}#))
- (#{r 22825}#
- (car #{x 22820}#)))
- (call-with-values
- (lambda ()
- (#{syntax-type 4449}#
- #{e 22824}#
- #{r 22825}#
- '(())
- (#{source-annotation 4408}#
- #{e 22824}#)
- #f
- #{mod 21976}#
- #f))
- (lambda (#{type 22829}#
- #{value 22830}#
- #{e 22831}#
- #{w 22832}#
- #{s 22833}#
- #{mod 22834}#)
- (#{expand-expr 4451}#
- #{type 22829}#
- #{value 22830}#
- #{e 22831}#
- #{r 22825}#
- #{w 22832}#
- #{s 22833}#
- #{mod 22834}#)))))
- (reverse #{vals 21811}#))
- (let ((#{exps 22840}#
- (map (lambda (#{x 22841}#)
- (let ((#{e 22844}#
- (cdr #{x 22841}#))
- (#{r 22845}#
- (car #{x 22841}#)))
- (call-with-values
- (lambda ()
- (#{syntax-type 4449}#
- #{e 22844}#
- #{r 22845}#
- '(())
- (#{source-annotation 4408}#
- #{e 22844}#)
- #f
- #{mod 21976}#
- #f))
- (lambda (#{type 22849}#
- #{value 22850}#
- #{e 22851}#
- #{w 22852}#
- #{s 22853}#
- #{mod 22854}#)
- (#{expand-expr 4451}#
- #{type 22849}#
- #{value 22850}#
- #{e 22851}#
- #{r 22845}#
- #{w 22852}#
- #{s 22853}#
- #{mod 22854}#)))))
- (cons (cons #{er 21814}#
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 21973}#)
- #{s 21975}#
- #f)
- (set-source-properties!
- #{e 21973}#
- #{s 21975}#))
- #{e 21973}#)
- #{w 21974}#
- #{mod 21976}#))
- (cdr #{body 21806}#)))))
- (if (null? (cdr #{exps 22840}#))
- (car #{exps 22840}#)
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 12)
- #f
- #{exps 22840}#)))))))))))))))))
- (#{parse 21793}#
- (map (lambda (#{x 21796}#)
- (cons #{r 21790}#
- (#{wrap 4443}#
- #{x 21796}#
- #{w 21792}#
- #{mod 21789}#)))
- #{body 21785}#)
- '()
- '()
- '()
- '()
- '()
- '())))))))
- (#{expand-local-syntax 4455}#
- (lambda (#{rec? 22880}#
- #{e 22881}#
- #{r 22882}#
- #{w 22883}#
- #{s 22884}#
- #{mod 22885}#
- #{k 22886}#)
- (let ((#{tmp 22888}#
- ($sc-dispatch
- #{e 22881}#
- '(_ #(each (any any)) any . each-any))))
- (if #{tmp 22888}#
- (@apply
- (lambda (#{id 22892}#
- #{val 22893}#
- #{e1 22894}#
- #{e2 22895}#)
- (if (not (#{valid-bound-ids? 4440}# #{id 22892}#))
- (syntax-violation
- #f
- "duplicate bound keyword"
- #{e 22881}#)
- (let ((#{labels 22985}#
- (#{gen-labels 4418}# #{id 22892}#)))
- (let ((#{new-w 22986}#
- (#{make-binding-wrap 4429}#
- #{id 22892}#
- #{labels 22985}#
- #{w 22883}#)))
- (#{k 22886}#
- (cons #{e1 22894}# #{e2 22895}#)
- (#{extend-env 4409}#
- #{labels 22985}#
- (let ((#{trans-r 23024}#
- (#{macros-only-env 4411}# #{r 22882}#)))
- (begin
- (if #{rec? 22880}# #{new-w 22986}# #{w 22883}#)
- (map (lambda (#{x 23025}#)
- (cons 'macro
- (#{eval-local-transformer 4456}#
- (#{expand 4450}#
- #{x 23025}#
- #{trans-r 23024}#
- (values
- (if #{rec? 22880}#
- #{new-w 22986}#
- #{w 22883}#))
- #{mod 22885}#)
- #{mod 22885}#)))
- #{val 22893}#)))
- #{r 22882}#)
- #{new-w 22986}#
- #{s 22884}#
- #{mod 22885}#)))))
- #{tmp 22888}#)
- (syntax-violation
- #f
- "bad local syntax definition"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 22881}#) #{s 22884}# #f)
- (set-source-properties! #{e 22881}# #{s 22884}#))
- #{e 22881}#)
- #{w 22883}#
- #{mod 22885}#))))))
- (#{eval-local-transformer 4456}#
- (lambda (#{expanded 23321}# #{mod 23322}#)
- (let ((#{p 23323}# (primitive-eval #{expanded 23321}#)))
- (if (procedure? #{p 23323}#)
- #{p 23323}#
- (syntax-violation
- #f
- "nonprocedure transformer"
- #{p 23323}#)))))
- (#{ellipsis? 4458}#
- (lambda (#{x 5119}#)
- (if (if (if (vector? #{x 5119}#)
- (if (= (vector-length #{x 5119}#) 4)
- (eq? (vector-ref #{x 5119}# 0) 'syntax-object)
+ #f))
+ (set-cdr!
+ #{r 51944}#
+ (#{extend-env 28233}#
+ #{labels 52057}#
+ #{bindings 52061}#
+ (cdr #{r 51944}#)))
+ (#{build-letrec 28223}#
+ #f
+ #t
+ (reverse
+ (map syntax->datum
+ #{var-ids 52058}#))
+ (reverse #{vars 52059}#)
+ (map (lambda (#{x 54121}#)
+ (#{expand 28271}#
+ (cdr #{x 54121}#)
+ (car #{x 54121}#)
+ '(())
+ #{mod 52256}#))
+ (reverse #{vals 52060}#))
+ (#{build-sequence 28220}#
+ #f
+ (map (lambda (#{x 54257}#)
+ (#{expand 28271}#
+ (cdr #{x 54257}#)
+ (car #{x 54257}#)
+ '(())
+ #{mod 52256}#))
+ (cons (cons #{er 52063}#
+ (let ((#{x 54332}#
+ (begin
+ (if (if (pair? #{e 52253}#)
+ #{s 52255}#
+ #f)
+ (set-source-properties!
+ #{e 52253}#
+ #{s 52255}#))
+ #{e 52253}#)))
+ (if (if (null? (car #{w 52254}#))
+ (null? (cdr #{w 52254}#))
+ #f)
+ #{x 54332}#
+ (if (if (vector?
+ #{x 54332}#)
+ (if (= (vector-length
+ #{x 54332}#)
+ 4)
+ (eq? (vector-ref
+ #{x 54332}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 54364}#
+ (vector-ref
+ #{x 54332}#
+ 1))
+ (#{wrap 54365}#
+ (let ((#{w2 54373}#
+ (vector-ref
+ #{x 54332}#
+ 2)))
+ (let ((#{m1 54374}#
+ (car #{w 52254}#))
+ (#{s1 54375}#
+ (cdr #{w 52254}#)))
+ (if (null? #{m1 54374}#)
+ (if (null? #{s1 54375}#)
+ #{w2 54373}#
+ (cons (car #{w2 54373}#)
+ (let ((#{m2 54390}#
+ (cdr #{w2 54373}#)))
+ (if (null? #{m2 54390}#)
+ #{s1 54375}#
+ (append
+ #{s1 54375}#
+ #{m2 54390}#)))))
+ (cons (let ((#{m2 54398}#
+ (car #{w2 54373}#)))
+ (if (null? #{m2 54398}#)
+ #{m1 54374}#
+ (append
+ #{m1 54374}#
+ #{m2 54398}#)))
+ (let ((#{m2 54406}#
+ (cdr #{w2 54373}#)))
+ (if (null? #{m2 54406}#)
+ #{s1 54375}#
+ (append
+ #{s1 54375}#
+ #{m2 54406}#))))))))
+ (#{module 54366}#
+ (vector-ref
+ #{x 54332}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 54364}#
+ #{wrap 54365}#
+ #{module 54366}#))
+ (if (null? #{x 54332}#)
+ #{x 54332}#
+ (vector
+ 'syntax-object
+ #{x 54332}#
+ #{w 52254}#
+ #{mod 52256}#))))))
+ (cdr #{body 52055}#))))))))))))))))))
+ (#{parse 51947}#
+ (map (lambda (#{x 51950}#)
+ (cons #{r 51944}#
+ (if (if (null? (car #{w 51946}#))
+ (null? (cdr #{w 51946}#))
+ #f)
+ #{x 51950}#
+ (if (if (vector? #{x 51950}#)
+ (if (= (vector-length #{x 51950}#) 4)
+ (eq? (vector-ref #{x 51950}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 51986}#
+ (vector-ref #{x 51950}# 1))
+ (#{wrap 51987}#
+ (let ((#{w2 51997}#
+ (vector-ref #{x 51950}# 2)))
+ (let ((#{m1 51998}#
+ (car #{w 51946}#))
+ (#{s1 51999}#
+ (cdr #{w 51946}#)))
+ (if (null? #{m1 51998}#)
+ (if (null? #{s1 51999}#)
+ #{w2 51997}#
+ (cons (car #{w2 51997}#)
+ (let ((#{m2 52016}#
+ (cdr #{w2 51997}#)))
+ (if (null? #{m2 52016}#)
+ #{s1 51999}#
+ (append
+ #{s1 51999}#
+ #{m2 52016}#)))))
+ (cons (let ((#{m2 52024}#
+ (car #{w2 51997}#)))
+ (if (null? #{m2 52024}#)
+ #{m1 51998}#
+ (append
+ #{m1 51998}#
+ #{m2 52024}#)))
+ (let ((#{m2 52032}#
+ (cdr #{w2 51997}#)))
+ (if (null? #{m2 52032}#)
+ #{s1 51999}#
+ (append
+ #{s1 51999}#
+ #{m2 52032}#))))))))
+ (#{module 51988}#
+ (vector-ref #{x 51950}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 51986}#
+ #{wrap 51987}#
+ #{module 51988}#))
+ (if (null? #{x 51950}#)
+ #{x 51950}#
+ (vector
+ 'syntax-object
+ #{x 51950}#
+ #{w 51946}#
+ #{mod 51943}#))))))
+ #{body 51939}#)
+ '()
+ '()
+ '()
+ '()
+ '()
+ '())))))))
+ (#{expand-local-syntax 28276}#
+ (lambda (#{rec? 54421}#
+ #{e 54422}#
+ #{r 54423}#
+ #{w 54424}#
+ #{s 54425}#
+ #{mod 54426}#
+ #{k 54427}#)
+ (let ((#{tmp 54429}#
+ ($sc-dispatch
+ #{e 54422}#
+ '(_ #(each (any any)) any . each-any))))
+ (if #{tmp 54429}#
+ (@apply
+ (lambda (#{id 54433}#
+ #{val 54434}#
+ #{e1 54435}#
+ #{e2 54436}#)
+ (if (not (#{valid-bound-ids? 28261}# #{id 54433}#))
+ (syntax-violation
+ #f
+ "duplicate bound keyword"
+ #{e 54422}#)
+ (let ((#{labels 54533}#
+ (#{gen-labels 28241}# #{id 54433}#)))
+ (let ((#{new-w 54534}#
+ (#{make-binding-wrap 28252}#
+ #{id 54433}#
+ #{labels 54533}#
+ #{w 54424}#)))
+ (#{k 54427}#
+ (cons #{e1 54435}# #{e2 54436}#)
+ (#{extend-env 28233}#
+ #{labels 54533}#
+ (let ((#{trans-r 54574}#
+ (#{macros-only-env 28235}# #{r 54423}#)))
+ (begin
+ (if #{rec? 54421}# #{new-w 54534}# #{w 54424}#)
+ (map (lambda (#{x 54575}#)
+ (cons 'macro
+ (#{eval-local-transformer 28277}#
+ (#{expand 28271}#
+ #{x 54575}#
+ #{trans-r 54574}#
+ (values
+ (if #{rec? 54421}#
+ #{new-w 54534}#
+ #{w 54424}#))
+ #{mod 54426}#)
+ #{mod 54426}#)))
+ #{val 54434}#)))
+ #{r 54423}#)
+ #{new-w 54534}#
+ #{s 54425}#
+ #{mod 54426}#)))))
+ #{tmp 54429}#)
+ (syntax-violation
+ #f
+ "bad local syntax definition"
+ (let ((#{x 54904}#
+ (begin
+ (if (if (pair? #{e 54422}#) #{s 54425}# #f)
+ (set-source-properties! #{e 54422}# #{s 54425}#))
+ #{e 54422}#)))
+ (if (if (null? (car #{w 54424}#))
+ (null? (cdr #{w 54424}#))
#f)
+ #{x 54904}#
+ (if (if (vector? #{x 54904}#)
+ (if (= (vector-length #{x 54904}#) 4)
+ (eq? (vector-ref #{x 54904}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 54936}# (vector-ref #{x 54904}# 1))
+ (#{wrap 54937}#
+ (let ((#{w2 54945}# (vector-ref #{x 54904}# 2)))
+ (let ((#{m1 54946}# (car #{w 54424}#))
+ (#{s1 54947}# (cdr #{w 54424}#)))
+ (if (null? #{m1 54946}#)
+ (if (null? #{s1 54947}#)
+ #{w2 54945}#
+ (cons (car #{w2 54945}#)
+ (let ((#{m2 54962}#
+ (cdr #{w2 54945}#)))
+ (if (null? #{m2 54962}#)
+ #{s1 54947}#
+ (append
+ #{s1 54947}#
+ #{m2 54962}#)))))
+ (cons (let ((#{m2 54970}# (car #{w2 54945}#)))
+ (if (null? #{m2 54970}#)
+ #{m1 54946}#
+ (append #{m1 54946}# #{m2 54970}#)))
+ (let ((#{m2 54978}# (cdr #{w2 54945}#)))
+ (if (null? #{m2 54978}#)
+ #{s1 54947}#
+ (append
+ #{s1 54947}#
+ #{m2 54978}#))))))))
+ (#{module 54938}# (vector-ref #{x 54904}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 54936}#
+ #{wrap 54937}#
+ #{module 54938}#))
+ (if (null? #{x 54904}#)
+ #{x 54904}#
+ (vector
+ 'syntax-object
+ #{x 54904}#
+ #{w 54424}#
+ #{mod 54426}#))))))))))
+ (#{eval-local-transformer 28277}#
+ (lambda (#{expanded 54996}# #{mod 54997}#)
+ (let ((#{p 54998}# (primitive-eval #{expanded 54996}#)))
+ (if (procedure? #{p 54998}#)
+ #{p 54998}#
+ (syntax-violation
+ #f
+ "nonprocedure transformer"
+ #{p 54998}#)))))
+ (#{ellipsis? 28279}#
+ (lambda (#{x 29819}#)
+ (if (if (if (vector? #{x 29819}#)
+ (if (= (vector-length #{x 29819}#) 4)
+ (eq? (vector-ref #{x 29819}# 0) 'syntax-object)
#f)
- (symbol? (vector-ref #{x 5119}# 1))
- #f)
- (if (eq? (if (if (vector? #{x 5119}#)
- (if (= (vector-length #{x 5119}#) 4)
- (eq? (vector-ref #{x 5119}# 0) 'syntax-object)
- #f)
- #f)
- (vector-ref #{x 5119}# 1)
- #{x 5119}#)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))))
- (eq? (#{id-var-name 4434}# #{x 5119}# '(()))
- (#{id-var-name 4434}#
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))
- '(())))
+ #f)
+ (symbol? (vector-ref #{x 29819}# 1))
#f)
- #f)))
- (#{lambda-formals 4459}#
- (lambda (#{orig-args 23328}#)
- (letrec*
- ((#{req 23329}#
- (lambda (#{args 23333}# #{rreq 23334}#)
- (let ((#{tmp 23336}# ($sc-dispatch #{args 23333}# '())))
- (if #{tmp 23336}#
- (@apply
- (lambda ()
- (#{check 23330}# (reverse #{rreq 23334}#) #f))
- #{tmp 23336}#)
- (let ((#{tmp 23459}#
- ($sc-dispatch #{args 23333}# '(any . any))))
- (if (if #{tmp 23459}#
- (@apply
- (lambda (#{a 23463}# #{b 23464}#)
- (if (symbol? #{a 23463}#)
- #t
- (if (if (vector? #{a 23463}#)
- (if (= (vector-length #{a 23463}#) 4)
- (eq? (vector-ref #{a 23463}# 0)
- 'syntax-object)
- #f)
+ (#{free-id=? 28259}#
+ #{x 29819}#
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i26166"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ #f)))
+ (#{lambda-formals 28280}#
+ (lambda (#{orig-args 55003}#)
+ (letrec*
+ ((#{req 55004}#
+ (lambda (#{args 55008}# #{rreq 55009}#)
+ (let ((#{tmp 55011}# ($sc-dispatch #{args 55008}# '())))
+ (if #{tmp 55011}#
+ (@apply
+ (lambda ()
+ (#{check 55005}# (reverse #{rreq 55009}#) #f))
+ #{tmp 55011}#)
+ (let ((#{tmp 55127}#
+ ($sc-dispatch #{args 55008}# '(any . any))))
+ (if (if #{tmp 55127}#
+ (@apply
+ (lambda (#{a 55131}# #{b 55132}#)
+ (if (symbol? #{a 55131}#)
+ #t
+ (if (if (vector? #{a 55131}#)
+ (if (= (vector-length #{a 55131}#) 4)
+ (eq? (vector-ref #{a 55131}# 0)
+ 'syntax-object)
#f)
- (symbol? (vector-ref #{a 23463}# 1))
- #f)))
- #{tmp 23459}#)
- #f)
- (@apply
- (lambda (#{a 23491}# #{b 23492}#)
- (#{req 23329}#
- #{b 23492}#
- (cons #{a 23491}# #{rreq 23334}#)))
- #{tmp 23459}#)
- (let ((#{tmp 23493}# (list #{args 23333}#)))
- (if (@apply
- (lambda (#{r 23495}#)
- (if (symbol? #{r 23495}#)
- #t
- (if (if (vector? #{r 23495}#)
- (if (= (vector-length #{r 23495}#) 4)
- (eq? (vector-ref #{r 23495}# 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref #{r 23495}# 1))
- #f)))
- #{tmp 23493}#)
- (@apply
- (lambda (#{r 23525}#)
- (#{check 23330}#
- (reverse #{rreq 23334}#)
- #{r 23525}#))
- #{tmp 23493}#)
- (syntax-violation
- 'lambda
- "invalid argument list"
- #{orig-args 23328}#
- #{args 23333}#)))))))))
- (#{check 23330}#
- (lambda (#{req 23656}# #{rest 23657}#)
- (if (#{distinct-bound-ids? 4441}#
- (if #{rest 23657}#
- (cons #{rest 23657}# #{req 23656}#)
- #{req 23656}#))
- (values #{req 23656}# #f #{rest 23657}# #f)
- (syntax-violation
- 'lambda
- "duplicate identifier in argument list"
- #{orig-args 23328}#)))))
- (#{req 23329}# #{orig-args 23328}# '()))))
- (#{expand-simple-lambda 4460}#
- (lambda (#{e 23773}#
- #{r 23774}#
- #{w 23775}#
- #{s 23776}#
- #{mod 23777}#
- #{req 23778}#
- #{rest 23779}#
- #{meta 23780}#
- #{body 23781}#)
- (let ((#{ids 23782}#
- (if #{rest 23779}#
- (append #{req 23778}# (list #{rest 23779}#))
- #{req 23778}#)))
- (let ((#{vars 23783}#
- (map #{gen-var 4464}# #{ids 23782}#)))
- (let ((#{labels 23784}#
- (#{gen-labels 4418}# #{ids 23782}#)))
- (#{build-simple-lambda 4391}#
- #{s 23776}#
- (map syntax->datum #{req 23778}#)
- (if #{rest 23779}#
- (syntax->datum #{rest 23779}#)
- #f)
- #{vars 23783}#
- #{meta 23780}#
- (#{expand-body 4454}#
- #{body 23781}#
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 23773}#) #{s 23776}# #f)
- (set-source-properties! #{e 23773}# #{s 23776}#))
- #{e 23773}#)
- #{w 23775}#
- #{mod 23777}#)
- (#{extend-var-env 4410}#
- #{labels 23784}#
- #{vars 23783}#
- #{r 23774}#)
- (#{make-binding-wrap 4429}#
- #{ids 23782}#
- #{labels 23784}#
- #{w 23775}#)
- #{mod 23777}#)))))))
- (#{lambda*-formals 4461}#
- (lambda (#{orig-args 24084}#)
- (letrec*
- ((#{req 24085}#
- (lambda (#{args 24092}# #{rreq 24093}#)
- (let ((#{tmp 24095}# ($sc-dispatch #{args 24092}# '())))
- (if #{tmp 24095}#
- (@apply
- (lambda ()
- (#{check 24089}#
- (reverse #{rreq 24093}#)
- '()
- #f
- '()))
- #{tmp 24095}#)
- (let ((#{tmp 24101}#
- ($sc-dispatch #{args 24092}# '(any . any))))
- (if (if #{tmp 24101}#
- (@apply
- (lambda (#{a 24105}# #{b 24106}#)
- (if (symbol? #{a 24105}#)
+ #f)
+ (symbol? (vector-ref #{a 55131}# 1))
+ #f)))
+ #{tmp 55127}#)
+ #f)
+ (@apply
+ (lambda (#{a 55159}# #{b 55160}#)
+ (#{req 55004}#
+ #{b 55160}#
+ (cons #{a 55159}# #{rreq 55009}#)))
+ #{tmp 55127}#)
+ (let ((#{tmp 55161}# (list #{args 55008}#)))
+ (if (@apply
+ (lambda (#{r 55163}#)
+ (if (symbol? #{r 55163}#)
#t
- (if (if (vector? #{a 24105}#)
- (if (= (vector-length #{a 24105}#) 4)
- (eq? (vector-ref #{a 24105}# 0)
+ (if (if (vector? #{r 55163}#)
+ (if (= (vector-length #{r 55163}#) 4)
+ (eq? (vector-ref #{r 55163}# 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref #{a 24105}# 1))
+ (symbol? (vector-ref #{r 55163}# 1))
#f)))
- #{tmp 24101}#)
- #f)
- (@apply
- (lambda (#{a 24133}# #{b 24134}#)
- (#{req 24085}#
- #{b 24134}#
- (cons #{a 24133}# #{rreq 24093}#)))
- #{tmp 24101}#)
- (let ((#{tmp 24135}#
- ($sc-dispatch #{args 24092}# '(any . any))))
- (if (if #{tmp 24135}#
- (@apply
- (lambda (#{a 24139}# #{b 24140}#)
- (eq? (syntax->datum #{a 24139}#)
- #:optional))
- #{tmp 24135}#)
- #f)
- (@apply
- (lambda (#{a 24141}# #{b 24142}#)
- (#{opt 24086}#
- #{b 24142}#
- (reverse #{rreq 24093}#)
- '()))
- #{tmp 24135}#)
- (let ((#{tmp 24145}#
- ($sc-dispatch
- #{args 24092}#
- '(any . any))))
- (if (if #{tmp 24145}#
- (@apply
- (lambda (#{a 24149}# #{b 24150}#)
- (eq? (syntax->datum #{a 24149}#)
- #:key))
- #{tmp 24145}#)
- #f)
- (@apply
- (lambda (#{a 24151}# #{b 24152}#)
- (#{key 24087}#
- #{b 24152}#
- (reverse #{rreq 24093}#)
- '()
- '()))
- #{tmp 24145}#)
- (let ((#{tmp 24155}#
- ($sc-dispatch
- #{args 24092}#
- '(any any))))
- (if (if #{tmp 24155}#
- (@apply
- (lambda (#{a 24159}# #{b 24160}#)
- (eq? (syntax->datum #{a 24159}#)
- #:rest))
- #{tmp 24155}#)
+ #{tmp 55161}#)
+ (@apply
+ (lambda (#{r 55193}#)
+ (#{check 55005}#
+ (reverse #{rreq 55009}#)
+ #{r 55193}#))
+ #{tmp 55161}#)
+ (syntax-violation
+ 'lambda
+ "invalid argument list"
+ #{orig-args 55003}#
+ #{args 55008}#)))))))))
+ (#{check 55005}#
+ (lambda (#{req 55317}# #{rest 55318}#)
+ (if (#{distinct-bound-ids? 28262}#
+ (if #{rest 55318}#
+ (cons #{rest 55318}# #{req 55317}#)
+ #{req 55317}#))
+ (values #{req 55317}# #f #{rest 55318}# #f)
+ (syntax-violation
+ 'lambda
+ "duplicate identifier in argument list"
+ #{orig-args 55003}#)))))
+ (#{req 55004}# #{orig-args 55003}# '()))))
+ (#{expand-simple-lambda 28281}#
+ (lambda (#{e 55427}#
+ #{r 55428}#
+ #{w 55429}#
+ #{s 55430}#
+ #{mod 55431}#
+ #{req 55432}#
+ #{rest 55433}#
+ #{meta 55434}#
+ #{body 55435}#)
+ (let ((#{ids 55436}#
+ (if #{rest 55433}#
+ (append #{req 55432}# (list #{rest 55433}#))
+ #{req 55432}#)))
+ (let ((#{vars 55437}#
+ (map #{gen-var 28285}# #{ids 55436}#)))
+ (let ((#{labels 55438}#
+ (#{gen-labels 28241}# #{ids 55436}#)))
+ (#{build-simple-lambda 28214}#
+ #{s 55430}#
+ (map syntax->datum #{req 55432}#)
+ (if #{rest 55433}#
+ (syntax->datum #{rest 55433}#)
+ #f)
+ #{vars 55437}#
+ #{meta 55434}#
+ (#{expand-body 28275}#
+ #{body 55435}#
+ (let ((#{x 55627}#
+ (begin
+ (if (if (pair? #{e 55427}#) #{s 55430}# #f)
+ (set-source-properties! #{e 55427}# #{s 55430}#))
+ #{e 55427}#)))
+ (if (if (null? (car #{w 55429}#))
+ (null? (cdr #{w 55429}#))
+ #f)
+ #{x 55627}#
+ (if (if (vector? #{x 55627}#)
+ (if (= (vector-length #{x 55627}#) 4)
+ (eq? (vector-ref #{x 55627}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 55659}# (vector-ref #{x 55627}# 1))
+ (#{wrap 55660}#
+ (let ((#{w2 55668}# (vector-ref #{x 55627}# 2)))
+ (let ((#{m1 55669}# (car #{w 55429}#))
+ (#{s1 55670}# (cdr #{w 55429}#)))
+ (if (null? #{m1 55669}#)
+ (if (null? #{s1 55670}#)
+ #{w2 55668}#
+ (cons (car #{w2 55668}#)
+ (let ((#{m2 55685}#
+ (cdr #{w2 55668}#)))
+ (if (null? #{m2 55685}#)
+ #{s1 55670}#
+ (append
+ #{s1 55670}#
+ #{m2 55685}#)))))
+ (cons (let ((#{m2 55693}#
+ (car #{w2 55668}#)))
+ (if (null? #{m2 55693}#)
+ #{m1 55669}#
+ (append
+ #{m1 55669}#
+ #{m2 55693}#)))
+ (let ((#{m2 55701}#
+ (cdr #{w2 55668}#)))
+ (if (null? #{m2 55701}#)
+ #{s1 55670}#
+ (append
+ #{s1 55670}#
+ #{m2 55701}#))))))))
+ (#{module 55661}# (vector-ref #{x 55627}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 55659}#
+ #{wrap 55660}#
+ #{module 55661}#))
+ (if (null? #{x 55627}#)
+ #{x 55627}#
+ (vector
+ 'syntax-object
+ #{x 55627}#
+ #{w 55429}#
+ #{mod 55431}#)))))
+ (#{extend-var-env 28234}#
+ #{labels 55438}#
+ #{vars 55437}#
+ #{r 55428}#)
+ (#{make-binding-wrap 28252}#
+ #{ids 55436}#
+ #{labels 55438}#
+ #{w 55429}#)
+ #{mod 55431}#)))))))
+ (#{lambda*-formals 28282}#
+ (lambda (#{orig-args 55932}#)
+ (letrec*
+ ((#{req 55933}#
+ (lambda (#{args 55940}# #{rreq 55941}#)
+ (let ((#{tmp 55943}# ($sc-dispatch #{args 55940}# '())))
+ (if #{tmp 55943}#
+ (@apply
+ (lambda ()
+ (#{check 55937}#
+ (reverse #{rreq 55941}#)
+ '()
+ #f
+ '()))
+ #{tmp 55943}#)
+ (let ((#{tmp 56062}#
+ ($sc-dispatch #{args 55940}# '(any . any))))
+ (if (if #{tmp 56062}#
+ (@apply
+ (lambda (#{a 56066}# #{b 56067}#)
+ (if (symbol? #{a 56066}#)
+ #t
+ (if (if (vector? #{a 56066}#)
+ (if (= (vector-length #{a 56066}#) 4)
+ (eq? (vector-ref #{a 56066}# 0)
+ 'syntax-object)
#f)
- (@apply
- (lambda (#{a 24161}# #{b 24162}#)
- (#{rest 24088}#
- #{b 24162}#
- (reverse #{rreq 24093}#)
- '()
- '()))
- #{tmp 24155}#)
- (let ((#{tmp 24165}#
- (list #{args 24092}#)))
- (if (@apply
- (lambda (#{r 24167}#)
- (if (symbol? #{r 24167}#)
- #t
- (if (if (vector? #{r 24167}#)
- (if (= (vector-length
- #{r 24167}#)
- 4)
- (eq? (vector-ref
- #{r 24167}#
- 0)
- 'syntax-object)
- #f)
+ #f)
+ (symbol? (vector-ref #{a 56066}# 1))
+ #f)))
+ #{tmp 56062}#)
+ #f)
+ (@apply
+ (lambda (#{a 56094}# #{b 56095}#)
+ (#{req 55933}#
+ #{b 56095}#
+ (cons #{a 56094}# #{rreq 55941}#)))
+ #{tmp 56062}#)
+ (let ((#{tmp 56096}#
+ ($sc-dispatch #{args 55940}# '(any . any))))
+ (if (if #{tmp 56096}#
+ (@apply
+ (lambda (#{a 56100}# #{b 56101}#)
+ (eq? (syntax->datum #{a 56100}#) #:optional))
+ #{tmp 56096}#)
+ #f)
+ (@apply
+ (lambda (#{a 56102}# #{b 56103}#)
+ (#{opt 55934}#
+ #{b 56103}#
+ (reverse #{rreq 55941}#)
+ '()))
+ #{tmp 56096}#)
+ (let ((#{tmp 56106}#
+ ($sc-dispatch #{args 55940}# '(any . any))))
+ (if (if #{tmp 56106}#
+ (@apply
+ (lambda (#{a 56110}# #{b 56111}#)
+ (eq? (syntax->datum #{a 56110}#) #:key))
+ #{tmp 56106}#)
+ #f)
+ (@apply
+ (lambda (#{a 56112}# #{b 56113}#)
+ (#{key 55935}#
+ #{b 56113}#
+ (reverse #{rreq 55941}#)
+ '()
+ '()))
+ #{tmp 56106}#)
+ (let ((#{tmp 56116}#
+ ($sc-dispatch
+ #{args 55940}#
+ '(any any))))
+ (if (if #{tmp 56116}#
+ (@apply
+ (lambda (#{a 56120}# #{b 56121}#)
+ (eq? (syntax->datum #{a 56120}#)
+ #:rest))
+ #{tmp 56116}#)
+ #f)
+ (@apply
+ (lambda (#{a 56122}# #{b 56123}#)
+ (#{rest 55936}#
+ #{b 56123}#
+ (reverse #{rreq 55941}#)
+ '()
+ '()))
+ #{tmp 56116}#)
+ (let ((#{tmp 56126}# (list #{args 55940}#)))
+ (if (@apply
+ (lambda (#{r 56128}#)
+ (if (symbol? #{r 56128}#)
+ #t
+ (if (if (vector? #{r 56128}#)
+ (if (= (vector-length
+ #{r 56128}#)
+ 4)
+ (eq? (vector-ref
+ #{r 56128}#
+ 0)
+ 'syntax-object)
#f)
- (symbol?
- (vector-ref #{r 24167}# 1))
- #f)))
- #{tmp 24165}#)
- (@apply
- (lambda (#{r 24197}#)
- (#{rest 24088}#
- #{r 24197}#
- (reverse #{rreq 24093}#)
- '()
- '()))
- #{tmp 24165}#)
- (syntax-violation
- 'lambda*
- "invalid argument list"
- #{orig-args 24084}#
- #{args 24092}#)))))))))))))))
- (#{opt 24086}#
- (lambda (#{args 24216}# #{req 24217}# #{ropt 24218}#)
- (let ((#{tmp 24220}# ($sc-dispatch #{args 24216}# '())))
- (if #{tmp 24220}#
- (@apply
- (lambda ()
- (#{check 24089}#
- #{req 24217}#
- (reverse #{ropt 24218}#)
- #f
- '()))
- #{tmp 24220}#)
- (let ((#{tmp 24226}#
- ($sc-dispatch #{args 24216}# '(any . any))))
- (if (if #{tmp 24226}#
- (@apply
- (lambda (#{a 24230}# #{b 24231}#)
- (if (symbol? #{a 24230}#)
- #t
- (if (if (vector? #{a 24230}#)
- (if (= (vector-length #{a 24230}#) 4)
- (eq? (vector-ref #{a 24230}# 0)
- 'syntax-object)
- #f)
+ #f)
+ (symbol?
+ (vector-ref #{r 56128}# 1))
+ #f)))
+ #{tmp 56126}#)
+ (@apply
+ (lambda (#{r 56158}#)
+ (#{rest 55936}#
+ #{r 56158}#
+ (reverse #{rreq 55941}#)
+ '()
+ '()))
+ #{tmp 56126}#)
+ (syntax-violation
+ 'lambda*
+ "invalid argument list"
+ #{orig-args 55932}#
+ #{args 55940}#)))))))))))))))
+ (#{opt 55934}#
+ (lambda (#{args 56177}# #{req 56178}# #{ropt 56179}#)
+ (let ((#{tmp 56181}# ($sc-dispatch #{args 56177}# '())))
+ (if #{tmp 56181}#
+ (@apply
+ (lambda ()
+ (#{check 55937}#
+ #{req 56178}#
+ (reverse #{ropt 56179}#)
+ #f
+ '()))
+ #{tmp 56181}#)
+ (let ((#{tmp 56302}#
+ ($sc-dispatch #{args 56177}# '(any . any))))
+ (if (if #{tmp 56302}#
+ (@apply
+ (lambda (#{a 56306}# #{b 56307}#)
+ (if (symbol? #{a 56306}#)
+ #t
+ (if (if (vector? #{a 56306}#)
+ (if (= (vector-length #{a 56306}#) 4)
+ (eq? (vector-ref #{a 56306}# 0)
+ 'syntax-object)
#f)
- (symbol? (vector-ref #{a 24230}# 1))
- #f)))
- #{tmp 24226}#)
- #f)
- (@apply
- (lambda (#{a 24258}# #{b 24259}#)
- (#{opt 24086}#
- #{b 24259}#
- #{req 24217}#
- (cons (cons #{a 24258}#
- '(#(syntax-object
- #f
- ((top)
- #(ribcage
- #(a b)
- #((top) (top))
- #("i2427" "i2428"))
- #(ribcage () () ())
- #(ribcage
- #(args req ropt)
- #((top) (top) (top))
- #("i2417" "i2418" "i2419"))
- #(ribcage
- (check rest key opt req)
- ((top)
- (top)
- (top)
- (top)
- (top))
- ("i2363"
- "i2361"
- "i2359"
- "i2357"
- "i2355"))
- #(ribcage
- #(orig-args)
- #((top))
- #("i2354"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))))
- #{ropt 24218}#)))
- #{tmp 24226}#)
- (let ((#{tmp 24260}#
- ($sc-dispatch
- #{args 24216}#
- '((any any) . any))))
- (if (if #{tmp 24260}#
- (@apply
- (lambda (#{a 24264}#
- #{init 24265}#
- #{b 24266}#)
- (if (symbol? #{a 24264}#)
- #t
- (if (if (vector? #{a 24264}#)
- (if (= (vector-length #{a 24264}#)
- 4)
- (eq? (vector-ref #{a 24264}# 0)
- 'syntax-object)
- #f)
+ #f)
+ (symbol? (vector-ref #{a 56306}# 1))
+ #f)))
+ #{tmp 56302}#)
+ #f)
+ (@apply
+ (lambda (#{a 56334}# #{b 56335}#)
+ (#{opt 55934}#
+ #{b 56335}#
+ #{req 56178}#
+ (cons (cons #{a 56334}#
+ '(#(syntax-object
+ #f
+ ((top)
+ #(ribcage
+ #(a b)
+ #((top) (top))
+ #("i26305" "i26306"))
+ #(ribcage () () ())
+ #(ribcage
+ #(args req ropt)
+ #((top) (top) (top))
+ #("i26295" "i26296" "i26297"))
+ #(ribcage
+ (check rest key opt req)
+ ((top) (top) (top) (top) (top))
+ ("i26241"
+ "i26239"
+ "i26237"
+ "i26235"
+ "i26233"))
+ #(ribcage
+ #(orig-args)
+ #((top))
+ #("i26232"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile))))
+ #{ropt 56179}#)))
+ #{tmp 56302}#)
+ (let ((#{tmp 56336}#
+ ($sc-dispatch
+ #{args 56177}#
+ '((any any) . any))))
+ (if (if #{tmp 56336}#
+ (@apply
+ (lambda (#{a 56340}#
+ #{init 56341}#
+ #{b 56342}#)
+ (if (symbol? #{a 56340}#)
+ #t
+ (if (if (vector? #{a 56340}#)
+ (if (= (vector-length #{a 56340}#) 4)
+ (eq? (vector-ref #{a 56340}# 0)
+ 'syntax-object)
#f)
- (symbol? (vector-ref #{a 24264}# 1))
- #f)))
- #{tmp 24260}#)
- #f)
- (@apply
- (lambda (#{a 24293}# #{init 24294}# #{b 24295}#)
- (#{opt 24086}#
- #{b 24295}#
- #{req 24217}#
- (cons (list #{a 24293}# #{init 24294}#)
- #{ropt 24218}#)))
- #{tmp 24260}#)
- (let ((#{tmp 24296}#
- ($sc-dispatch
- #{args 24216}#
- '(any . any))))
- (if (if #{tmp 24296}#
- (@apply
- (lambda (#{a 24300}# #{b 24301}#)
- (eq? (syntax->datum #{a 24300}#)
- #:key))
- #{tmp 24296}#)
- #f)
- (@apply
- (lambda (#{a 24302}# #{b 24303}#)
- (#{key 24087}#
- #{b 24303}#
- #{req 24217}#
- (reverse #{ropt 24218}#)
- '()))
- #{tmp 24296}#)
- (let ((#{tmp 24306}#
- ($sc-dispatch
- #{args 24216}#
- '(any any))))
- (if (if #{tmp 24306}#
- (@apply
- (lambda (#{a 24310}# #{b 24311}#)
- (eq? (syntax->datum #{a 24310}#)
- #:rest))
- #{tmp 24306}#)
- #f)
- (@apply
- (lambda (#{a 24312}# #{b 24313}#)
- (#{rest 24088}#
- #{b 24313}#
- #{req 24217}#
- (reverse #{ropt 24218}#)
- '()))
- #{tmp 24306}#)
- (let ((#{tmp 24316}#
- (list #{args 24216}#)))
- (if (@apply
- (lambda (#{r 24318}#)
- (if (symbol? #{r 24318}#)
- #t
- (if (if (vector? #{r 24318}#)
- (if (= (vector-length
- #{r 24318}#)
- 4)
- (eq? (vector-ref
- #{r 24318}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref #{r 24318}# 1))
- #f)))
- #{tmp 24316}#)
- (@apply
- (lambda (#{r 24348}#)
- (#{rest 24088}#
- #{r 24348}#
- #{req 24217}#
- (reverse #{ropt 24218}#)
- '()))
- #{tmp 24316}#)
- (syntax-violation
- 'lambda*
- "invalid optional argument list"
- #{orig-args 24084}#
- #{args 24216}#)))))))))))))))
- (#{key 24087}#
- (lambda (#{args 24367}#
- #{req 24368}#
- #{opt 24369}#
- #{rkey 24370}#)
- (let ((#{tmp 24372}# ($sc-dispatch #{args 24367}# '())))
- (if #{tmp 24372}#
- (@apply
- (lambda ()
- (#{check 24089}#
- #{req 24368}#
- #{opt 24369}#
- #f
- (cons #f (reverse #{rkey 24370}#))))
- #{tmp 24372}#)
- (let ((#{tmp 24378}#
- ($sc-dispatch #{args 24367}# '(any . any))))
- (if (if #{tmp 24378}#
- (@apply
- (lambda (#{a 24382}# #{b 24383}#)
- (if (symbol? #{a 24382}#)
- #t
- (if (if (vector? #{a 24382}#)
- (if (= (vector-length #{a 24382}#) 4)
- (eq? (vector-ref #{a 24382}# 0)
- 'syntax-object)
#f)
- #f)
- (symbol? (vector-ref #{a 24382}# 1))
- #f)))
- #{tmp 24378}#)
- #f)
- (@apply
- (lambda (#{a 24410}# #{b 24411}#)
- (let ((#{tmp 24412}#
- (symbol->keyword
- (syntax->datum #{a 24410}#))))
- (#{key 24087}#
- #{b 24411}#
- #{req 24368}#
- #{opt 24369}#
- (cons (cons #{tmp 24412}#
- (cons #{a 24410}#
- '(#(syntax-object
- #f
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(k)
- #((top))
- #("i2490"))
- #(ribcage
- #(a b)
- #((top) (top))
- #("i2484" "i2485"))
- #(ribcage () () ())
- #(ribcage
- #(args req opt rkey)
- #((top)
- (top)
- (top)
- (top))
- #("i2473"
- "i2474"
- "i2475"
- "i2476"))
- #(ribcage
- (check rest
- key
- opt
- req)
- ((top)
- (top)
- (top)
- (top)
- (top))
- ("i2363"
- "i2361"
- "i2359"
- "i2357"
- "i2355"))
- #(ribcage
- #(orig-args)
- #((top))
- #("i2354"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile)))))
- #{rkey 24370}#))))
- #{tmp 24378}#)
- (let ((#{tmp 24415}#
- ($sc-dispatch
- #{args 24367}#
- '((any any) . any))))
- (if (if #{tmp 24415}#
- (@apply
- (lambda (#{a 24419}#
- #{init 24420}#
- #{b 24421}#)
- (if (symbol? #{a 24419}#)
- #t
- (if (if (vector? #{a 24419}#)
- (if (= (vector-length #{a 24419}#)
- 4)
- (eq? (vector-ref #{a 24419}# 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref #{a 24419}# 1))
- #f)))
- #{tmp 24415}#)
- #f)
- (@apply
- (lambda (#{a 24448}# #{init 24449}# #{b 24450}#)
- (let ((#{tmp 24451}#
- (symbol->keyword
- (syntax->datum #{a 24448}#))))
- (#{key 24087}#
- #{b 24450}#
- #{req 24368}#
- #{opt 24369}#
- (cons (list #{tmp 24451}#
- #{a 24448}#
- #{init 24449}#)
- #{rkey 24370}#))))
- #{tmp 24415}#)
- (let ((#{tmp 24454}#
- ($sc-dispatch
- #{args 24367}#
- '((any any any) . any))))
- (if (if #{tmp 24454}#
- (@apply
- (lambda (#{a 24458}#
- #{init 24459}#
- #{k 24460}#
- #{b 24461}#)
- (if (if (symbol? #{a 24458}#)
+ (symbol? (vector-ref #{a 56340}# 1))
+ #f)))
+ #{tmp 56336}#)
+ #f)
+ (@apply
+ (lambda (#{a 56369}# #{init 56370}# #{b 56371}#)
+ (#{opt 55934}#
+ #{b 56371}#
+ #{req 56178}#
+ (cons (list #{a 56369}# #{init 56370}#)
+ #{ropt 56179}#)))
+ #{tmp 56336}#)
+ (let ((#{tmp 56372}#
+ ($sc-dispatch #{args 56177}# '(any . any))))
+ (if (if #{tmp 56372}#
+ (@apply
+ (lambda (#{a 56376}# #{b 56377}#)
+ (eq? (syntax->datum #{a 56376}#) #:key))
+ #{tmp 56372}#)
+ #f)
+ (@apply
+ (lambda (#{a 56378}# #{b 56379}#)
+ (#{key 55935}#
+ #{b 56379}#
+ #{req 56178}#
+ (reverse #{ropt 56179}#)
+ '()))
+ #{tmp 56372}#)
+ (let ((#{tmp 56382}#
+ ($sc-dispatch
+ #{args 56177}#
+ '(any any))))
+ (if (if #{tmp 56382}#
+ (@apply
+ (lambda (#{a 56386}# #{b 56387}#)
+ (eq? (syntax->datum #{a 56386}#)
+ #:rest))
+ #{tmp 56382}#)
+ #f)
+ (@apply
+ (lambda (#{a 56388}# #{b 56389}#)
+ (#{rest 55936}#
+ #{b 56389}#
+ #{req 56178}#
+ (reverse #{ropt 56179}#)
+ '()))
+ #{tmp 56382}#)
+ (let ((#{tmp 56392}# (list #{args 56177}#)))
+ (if (@apply
+ (lambda (#{r 56394}#)
+ (if (symbol? #{r 56394}#)
#t
- (if (if (vector? #{a 24458}#)
+ (if (if (vector? #{r 56394}#)
(if (= (vector-length
- #{a 24458}#)
+ #{r 56394}#)
4)
(eq? (vector-ref
- #{a 24458}#
+ #{r 56394}#
0)
'syntax-object)
#f)
#f)
(symbol?
- (vector-ref #{a 24458}# 1))
- #f))
- (keyword?
- (syntax->datum #{k 24460}#))
- #f))
- #{tmp 24454}#)
- #f)
- (@apply
- (lambda (#{a 24488}#
- #{init 24489}#
- #{k 24490}#
- #{b 24491}#)
- (#{key 24087}#
- #{b 24491}#
- #{req 24368}#
- #{opt 24369}#
- (cons (list #{k 24490}#
- #{a 24488}#
- #{init 24489}#)
- #{rkey 24370}#)))
- #{tmp 24454}#)
- (let ((#{tmp 24492}#
- ($sc-dispatch #{args 24367}# '(any))))
- (if (if #{tmp 24492}#
- (@apply
- (lambda (#{aok 24496}#)
- (eq? (syntax->datum #{aok 24496}#)
- #:allow-other-keys))
- #{tmp 24492}#)
+ (vector-ref #{r 56394}# 1))
+ #f)))
+ #{tmp 56392}#)
+ (@apply
+ (lambda (#{r 56424}#)
+ (#{rest 55936}#
+ #{r 56424}#
+ #{req 56178}#
+ (reverse #{ropt 56179}#)
+ '()))
+ #{tmp 56392}#)
+ (syntax-violation
+ 'lambda*
+ "invalid optional argument list"
+ #{orig-args 55932}#
+ #{args 56177}#)))))))))))))))
+ (#{key 55935}#
+ (lambda (#{args 56443}#
+ #{req 56444}#
+ #{opt 56445}#
+ #{rkey 56446}#)
+ (let ((#{tmp 56448}# ($sc-dispatch #{args 56443}# '())))
+ (if #{tmp 56448}#
+ (@apply
+ (lambda ()
+ (#{check 55937}#
+ #{req 56444}#
+ #{opt 56445}#
+ #f
+ (cons #f (reverse #{rkey 56446}#))))
+ #{tmp 56448}#)
+ (let ((#{tmp 56570}#
+ ($sc-dispatch #{args 56443}# '(any . any))))
+ (if (if #{tmp 56570}#
+ (@apply
+ (lambda (#{a 56574}# #{b 56575}#)
+ (if (symbol? #{a 56574}#)
+ #t
+ (if (if (vector? #{a 56574}#)
+ (if (= (vector-length #{a 56574}#) 4)
+ (eq? (vector-ref #{a 56574}# 0)
+ 'syntax-object)
#f)
- (@apply
- (lambda (#{aok 24497}#)
- (#{check 24089}#
- #{req 24368}#
- #{opt 24369}#
- #f
- (cons #t (reverse #{rkey 24370}#))))
- #{tmp 24492}#)
- (let ((#{tmp 24500}#
- ($sc-dispatch
- #{args 24367}#
- '(any any any))))
- (if (if #{tmp 24500}#
- (@apply
- (lambda (#{aok 24504}#
- #{a 24505}#
- #{b 24506}#)
- (if (eq? (syntax->datum
- #{aok 24504}#)
- #:allow-other-keys)
- (eq? (syntax->datum
- #{a 24505}#)
- #:rest)
- #f))
- #{tmp 24500}#)
+ #f)
+ (symbol? (vector-ref #{a 56574}# 1))
+ #f)))
+ #{tmp 56570}#)
+ #f)
+ (@apply
+ (lambda (#{a 56602}# #{b 56603}#)
+ (let ((#{tmp 56604}#
+ (symbol->keyword
+ (syntax->datum #{a 56602}#))))
+ (#{key 55935}#
+ #{b 56603}#
+ #{req 56444}#
+ #{opt 56445}#
+ (cons (cons #{tmp 56604}#
+ (cons #{a 56602}#
+ '(#(syntax-object
+ #f
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(k)
+ #((top))
+ #("i26368"))
+ #(ribcage
+ #(a b)
+ #((top) (top))
+ #("i26362" "i26363"))
+ #(ribcage () () ())
+ #(ribcage
+ #(args req opt rkey)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("i26351"
+ "i26352"
+ "i26353"
+ "i26354"))
+ #(ribcage
+ (check rest key opt req)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i26241"
+ "i26239"
+ "i26237"
+ "i26235"
+ "i26233"))
+ #(ribcage
+ #(orig-args)
+ #((top))
+ #("i26232"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873"
+ "i23872"
+ "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile)))))
+ #{rkey 56446}#))))
+ #{tmp 56570}#)
+ (let ((#{tmp 56607}#
+ ($sc-dispatch
+ #{args 56443}#
+ '((any any) . any))))
+ (if (if #{tmp 56607}#
+ (@apply
+ (lambda (#{a 56611}#
+ #{init 56612}#
+ #{b 56613}#)
+ (if (symbol? #{a 56611}#)
+ #t
+ (if (if (vector? #{a 56611}#)
+ (if (= (vector-length #{a 56611}#) 4)
+ (eq? (vector-ref #{a 56611}# 0)
+ 'syntax-object)
#f)
- (@apply
- (lambda (#{aok 24507}#
- #{a 24508}#
- #{b 24509}#)
- (#{rest 24088}#
- #{b 24509}#
- #{req 24368}#
- #{opt 24369}#
- (cons #t
- (reverse #{rkey 24370}#))))
- #{tmp 24500}#)
- (let ((#{tmp 24512}#
- ($sc-dispatch
- #{args 24367}#
- '(any . any))))
- (if (if #{tmp 24512}#
- (@apply
- (lambda (#{aok 24516}#
- #{r 24517}#)
- (if (eq? (syntax->datum
- #{aok 24516}#)
- #:allow-other-keys)
- (if (symbol? #{r 24517}#)
- #t
- (if (if (vector?
- #{r 24517}#)
- (if (= (vector-length
- #{r 24517}#)
- 4)
- (eq? (vector-ref
- #{r 24517}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- #{r 24517}#
- 1))
- #f))
- #f))
- #{tmp 24512}#)
- #f)
- (@apply
- (lambda (#{aok 24544}#
- #{r 24545}#)
- (#{rest 24088}#
- #{r 24545}#
- #{req 24368}#
- #{opt 24369}#
- (cons #t
- (reverse
- #{rkey 24370}#))))
- #{tmp 24512}#)
- (let ((#{tmp 24548}#
- ($sc-dispatch
- #{args 24367}#
- '(any any))))
- (if (if #{tmp 24548}#
- (@apply
- (lambda (#{a 24552}#
- #{b 24553}#)
- (eq? (syntax->datum
- #{a 24552}#)
- #:rest))
- #{tmp 24548}#)
- #f)
- (@apply
- (lambda (#{a 24554}#
- #{b 24555}#)
- (#{rest 24088}#
- #{b 24555}#
- #{req 24368}#
- #{opt 24369}#
- (cons #f
- (reverse
- #{rkey 24370}#))))
- #{tmp 24548}#)
- (let ((#{tmp 24558}#
- (list #{args 24367}#)))
- (if (@apply
- (lambda (#{r 24560}#)
- (if (symbol?
- #{r 24560}#)
- #t
- (if (if (vector?
- #{r 24560}#)
- (if (= (vector-length
- #{r 24560}#)
- 4)
- (eq? (vector-ref
- #{r 24560}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- #{r 24560}#
- 1))
- #f)))
- #{tmp 24558}#)
- (@apply
- (lambda (#{r 24590}#)
- (#{rest 24088}#
- #{r 24590}#
- #{req 24368}#
- #{opt 24369}#
- (cons #f
- (reverse
- #{rkey 24370}#))))
- #{tmp 24558}#)
- (syntax-violation
- 'lambda*
- "invalid keyword argument list"
- #{orig-args 24084}#
- #{args 24367}#)))))))))))))))))))))
- (#{rest 24088}#
- (lambda (#{args 24618}#
- #{req 24619}#
- #{opt 24620}#
- #{kw 24621}#)
- (let ((#{tmp 24623}# (list #{args 24618}#)))
- (if (@apply
- (lambda (#{r 24625}#)
- (if (symbol? #{r 24625}#)
- #t
- (if (if (vector? #{r 24625}#)
- (if (= (vector-length #{r 24625}#) 4)
- (eq? (vector-ref #{r 24625}# 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref #{r 24625}# 1))
- #f)))
- #{tmp 24623}#)
- (@apply
- (lambda (#{r 24655}#)
- (#{check 24089}#
- #{req 24619}#
- #{opt 24620}#
- #{r 24655}#
- #{kw 24621}#))
- #{tmp 24623}#)
- (syntax-violation
- 'lambda*
- "invalid rest argument"
- #{orig-args 24084}#
- #{args 24618}#)))))
- (#{check 24089}#
- (lambda (#{req 24659}#
- #{opt 24660}#
- #{rest 24661}#
- #{kw 24662}#)
- (if (#{distinct-bound-ids? 4441}#
- (append
- #{req 24659}#
- (map car #{opt 24660}#)
- (if #{rest 24661}# (list #{rest 24661}#) '())
- (if (pair? #{kw 24662}#)
- (map cadr (cdr #{kw 24662}#))
- '())))
- (values
- #{req 24659}#
- #{opt 24660}#
- #{rest 24661}#
- #{kw 24662}#)
- (syntax-violation
- 'lambda*
- "duplicate identifier in argument list"
- #{orig-args 24084}#)))))
- (#{req 24085}# #{orig-args 24084}# '()))))
- (#{expand-lambda-case 4462}#
- (lambda (#{e 24778}#
- #{r 24779}#
- #{w 24780}#
- #{s 24781}#
- #{mod 24782}#
- #{get-formals 24783}#
- #{clauses 24784}#)
- (letrec*
- ((#{parse-req 24785}#
- (lambda (#{req 24918}#
- #{opt 24919}#
- #{rest 24920}#
- #{kw 24921}#
- #{body 24922}#)
- (let ((#{vars 24923}#
- (map #{gen-var 4464}# #{req 24918}#))
- (#{labels 24924}#
- (#{gen-labels 4418}# #{req 24918}#)))
- (let ((#{r* 24925}#
- (#{extend-var-env 4410}#
- #{labels 24924}#
- #{vars 24923}#
- #{r 24779}#))
- (#{w* 24926}#
- (#{make-binding-wrap 4429}#
- #{req 24918}#
- #{labels 24924}#
- #{w 24780}#)))
- (#{parse-opt 24786}#
- (map syntax->datum #{req 24918}#)
- #{opt 24919}#
- #{rest 24920}#
- #{kw 24921}#
- #{body 24922}#
- (reverse #{vars 24923}#)
- #{r* 24925}#
- #{w* 24926}#
- '()
- '())))))
- (#{parse-opt 24786}#
- (lambda (#{req 25140}#
- #{opt 25141}#
- #{rest 25142}#
- #{kw 25143}#
- #{body 25144}#
- #{vars 25145}#
- #{r* 25146}#
- #{w* 25147}#
- #{out 25148}#
- #{inits 25149}#)
- (if (pair? #{opt 25141}#)
- (let ((#{tmp 25150}# (car #{opt 25141}#)))
- (let ((#{tmp 25151}#
- ($sc-dispatch #{tmp 25150}# '(any any))))
- (if #{tmp 25151}#
- (@apply
- (lambda (#{id 25153}# #{i 25154}#)
- (let ((#{v 25155}#
- (let ((#{id 25163}#
- (if (if (vector? #{id 25153}#)
+ #f)
+ (symbol? (vector-ref #{a 56611}# 1))
+ #f)))
+ #{tmp 56607}#)
+ #f)
+ (@apply
+ (lambda (#{a 56640}# #{init 56641}# #{b 56642}#)
+ (let ((#{tmp 56643}#
+ (symbol->keyword
+ (syntax->datum #{a 56640}#))))
+ (#{key 55935}#
+ #{b 56642}#
+ #{req 56444}#
+ #{opt 56445}#
+ (cons (list #{tmp 56643}#
+ #{a 56640}#
+ #{init 56641}#)
+ #{rkey 56446}#))))
+ #{tmp 56607}#)
+ (let ((#{tmp 56646}#
+ ($sc-dispatch
+ #{args 56443}#
+ '((any any any) . any))))
+ (if (if #{tmp 56646}#
+ (@apply
+ (lambda (#{a 56650}#
+ #{init 56651}#
+ #{k 56652}#
+ #{b 56653}#)
+ (if (if (symbol? #{a 56650}#)
+ #t
+ (if (if (vector? #{a 56650}#)
(if (= (vector-length
- #{id 25153}#)
+ #{a 56650}#)
4)
(eq? (vector-ref
- #{id 25153}#
+ #{a 56650}#
0)
'syntax-object)
#f)
#f)
- (vector-ref #{id 25153}# 1)
- #{id 25153}#)))
- (gensym
- (string-append
- (symbol->string #{id 25163}#)
- " ")))))
- (let ((#{l 25156}#
- (#{gen-labels 4418}#
- (list #{v 25155}#))))
- (let ((#{r** 25157}#
- (#{extend-var-env 4410}#
- #{l 25156}#
- (list #{v 25155}#)
- #{r* 25146}#)))
- (let ((#{w** 25158}#
- (#{make-binding-wrap 4429}#
- (list #{id 25153}#)
- #{l 25156}#
- #{w* 25147}#)))
- (#{parse-opt 24786}#
- #{req 25140}#
- (cdr #{opt 25141}#)
- #{rest 25142}#
- #{kw 25143}#
- #{body 25144}#
- (cons #{v 25155}# #{vars 25145}#)
- #{r** 25157}#
- #{w** 25158}#
- (cons (syntax->datum #{id 25153}#)
- #{out 25148}#)
- (cons (#{expand 4450}#
- #{i 25154}#
- #{r* 25146}#
- #{w* 25147}#
- #{mod 24782}#)
- #{inits 25149}#)))))))
- #{tmp 25151}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp 25150}#))))
- (if #{rest 25142}#
- (let ((#{v 25428}#
- (let ((#{id 25438}#
- (if (if (vector? #{rest 25142}#)
- (if (= (vector-length #{rest 25142}#)
- 4)
- (eq? (vector-ref #{rest 25142}# 0)
- 'syntax-object)
- #f)
+ (symbol?
+ (vector-ref #{a 56650}# 1))
+ #f))
+ (keyword? (syntax->datum #{k 56652}#))
+ #f))
+ #{tmp 56646}#)
+ #f)
+ (@apply
+ (lambda (#{a 56680}#
+ #{init 56681}#
+ #{k 56682}#
+ #{b 56683}#)
+ (#{key 55935}#
+ #{b 56683}#
+ #{req 56444}#
+ #{opt 56445}#
+ (cons (list #{k 56682}#
+ #{a 56680}#
+ #{init 56681}#)
+ #{rkey 56446}#)))
+ #{tmp 56646}#)
+ (let ((#{tmp 56684}#
+ ($sc-dispatch #{args 56443}# '(any))))
+ (if (if #{tmp 56684}#
+ (@apply
+ (lambda (#{aok 56688}#)
+ (eq? (syntax->datum #{aok 56688}#)
+ #:allow-other-keys))
+ #{tmp 56684}#)
+ #f)
+ (@apply
+ (lambda (#{aok 56689}#)
+ (#{check 55937}#
+ #{req 56444}#
+ #{opt 56445}#
+ #f
+ (cons #t (reverse #{rkey 56446}#))))
+ #{tmp 56684}#)
+ (let ((#{tmp 56808}#
+ ($sc-dispatch
+ #{args 56443}#
+ '(any any any))))
+ (if (if #{tmp 56808}#
+ (@apply
+ (lambda (#{aok 56812}#
+ #{a 56813}#
+ #{b 56814}#)
+ (if (eq? (syntax->datum
+ #{aok 56812}#)
+ #:allow-other-keys)
+ (eq? (syntax->datum
+ #{a 56813}#)
+ #:rest)
+ #f))
+ #{tmp 56808}#)
#f)
- (vector-ref #{rest 25142}# 1)
- #{rest 25142}#)))
- (gensym
- (string-append
- (symbol->string #{id 25438}#)
- " ")))))
- (let ((#{l 25429}#
- (#{gen-labels 4418}# (list #{v 25428}#))))
- (let ((#{r* 25430}#
- (#{extend-var-env 4410}#
- #{l 25429}#
- (list #{v 25428}#)
- #{r* 25146}#)))
- (let ((#{w* 25431}#
- (#{make-binding-wrap 4429}#
- (list #{rest 25142}#)
- #{l 25429}#
- #{w* 25147}#)))
- (#{parse-kw 24787}#
- #{req 25140}#
- (if (pair? #{out 25148}#)
- (reverse #{out 25148}#)
+ (@apply
+ (lambda (#{aok 56815}#
+ #{a 56816}#
+ #{b 56817}#)
+ (#{rest 55936}#
+ #{b 56817}#
+ #{req 56444}#
+ #{opt 56445}#
+ (cons #t
+ (reverse #{rkey 56446}#))))
+ #{tmp 56808}#)
+ (let ((#{tmp 56820}#
+ ($sc-dispatch
+ #{args 56443}#
+ '(any . any))))
+ (if (if #{tmp 56820}#
+ (@apply
+ (lambda (#{aok 56824}#
+ #{r 56825}#)
+ (if (eq? (syntax->datum
+ #{aok 56824}#)
+ #:allow-other-keys)
+ (if (symbol? #{r 56825}#)
+ #t
+ (if (if (vector?
+ #{r 56825}#)
+ (if (= (vector-length
+ #{r 56825}#)
+ 4)
+ (eq? (vector-ref
+ #{r 56825}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol?
+ (vector-ref
+ #{r 56825}#
+ 1))
+ #f))
+ #f))
+ #{tmp 56820}#)
+ #f)
+ (@apply
+ (lambda (#{aok 56852}# #{r 56853}#)
+ (#{rest 55936}#
+ #{r 56853}#
+ #{req 56444}#
+ #{opt 56445}#
+ (cons #t
+ (reverse
+ #{rkey 56446}#))))
+ #{tmp 56820}#)
+ (let ((#{tmp 56856}#
+ ($sc-dispatch
+ #{args 56443}#
+ '(any any))))
+ (if (if #{tmp 56856}#
+ (@apply
+ (lambda (#{a 56860}#
+ #{b 56861}#)
+ (eq? (syntax->datum
+ #{a 56860}#)
+ #:rest))
+ #{tmp 56856}#)
+ #f)
+ (@apply
+ (lambda (#{a 56862}#
+ #{b 56863}#)
+ (#{rest 55936}#
+ #{b 56863}#
+ #{req 56444}#
+ #{opt 56445}#
+ (cons #f
+ (reverse
+ #{rkey 56446}#))))
+ #{tmp 56856}#)
+ (let ((#{tmp 56866}#
+ (list #{args 56443}#)))
+ (if (@apply
+ (lambda (#{r 56868}#)
+ (if (symbol?
+ #{r 56868}#)
+ #t
+ (if (if (vector?
+ #{r 56868}#)
+ (if (= (vector-length
+ #{r 56868}#)
+ 4)
+ (eq? (vector-ref
+ #{r 56868}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol?
+ (vector-ref
+ #{r 56868}#
+ 1))
+ #f)))
+ #{tmp 56866}#)
+ (@apply
+ (lambda (#{r 56898}#)
+ (#{rest 55936}#
+ #{r 56898}#
+ #{req 56444}#
+ #{opt 56445}#
+ (cons #f
+ (reverse
+ #{rkey 56446}#))))
+ #{tmp 56866}#)
+ (syntax-violation
+ 'lambda*
+ "invalid keyword argument list"
+ #{orig-args 55932}#
+ #{args 56443}#)))))))))))))))))))))
+ (#{rest 55936}#
+ (lambda (#{args 56926}#
+ #{req 56927}#
+ #{opt 56928}#
+ #{kw 56929}#)
+ (let ((#{tmp 56931}# (list #{args 56926}#)))
+ (if (@apply
+ (lambda (#{r 56933}#)
+ (if (symbol? #{r 56933}#)
+ #t
+ (if (if (vector? #{r 56933}#)
+ (if (= (vector-length #{r 56933}#) 4)
+ (eq? (vector-ref #{r 56933}# 0)
+ 'syntax-object)
+ #f)
#f)
- (syntax->datum #{rest 25142}#)
- (if (pair? #{kw 25143}#)
- (cdr #{kw 25143}#)
- #{kw 25143}#)
- #{body 25144}#
- (cons #{v 25428}# #{vars 25145}#)
- #{r* 25430}#
- #{w* 25431}#
- (if (pair? #{kw 25143}#) (car #{kw 25143}#) #f)
- '()
- #{inits 25149}#)))))
- (#{parse-kw 24787}#
- #{req 25140}#
- (if (pair? #{out 25148}#)
- (reverse #{out 25148}#)
- #f)
- #f
- (if (pair? #{kw 25143}#)
- (cdr #{kw 25143}#)
- #{kw 25143}#)
- #{body 25144}#
- #{vars 25145}#
- #{r* 25146}#
- #{w* 25147}#
- (if (pair? #{kw 25143}#) (car #{kw 25143}#) #f)
- '()
- #{inits 25149}#)))))
- (#{parse-kw 24787}#
- (lambda (#{req 25636}#
- #{opt 25637}#
- #{rest 25638}#
- #{kw 25639}#
- #{body 25640}#
- #{vars 25641}#
- #{r* 25642}#
- #{w* 25643}#
- #{aok 25644}#
- #{out 25645}#
- #{inits 25646}#)
- (if (pair? #{kw 25639}#)
- (let ((#{tmp 25647}# (car #{kw 25639}#)))
- (let ((#{tmp 25648}#
- ($sc-dispatch #{tmp 25647}# '(any any any))))
- (if #{tmp 25648}#
- (@apply
- (lambda (#{k 25650}# #{id 25651}# #{i 25652}#)
- (let ((#{v 25653}#
- (let ((#{id 25661}#
- (if (if (vector? #{id 25651}#)
- (if (= (vector-length
- #{id 25651}#)
- 4)
- (eq? (vector-ref
- #{id 25651}#
- 0)
- 'syntax-object)
- #f)
+ (symbol? (vector-ref #{r 56933}# 1))
+ #f)))
+ #{tmp 56931}#)
+ (@apply
+ (lambda (#{r 56963}#)
+ (#{check 55937}#
+ #{req 56927}#
+ #{opt 56928}#
+ #{r 56963}#
+ #{kw 56929}#))
+ #{tmp 56931}#)
+ (syntax-violation
+ 'lambda*
+ "invalid rest argument"
+ #{orig-args 55932}#
+ #{args 56926}#)))))
+ (#{check 55937}#
+ (lambda (#{req 57091}#
+ #{opt 57092}#
+ #{rest 57093}#
+ #{kw 57094}#)
+ (if (#{distinct-bound-ids? 28262}#
+ (append
+ #{req 57091}#
+ (map car #{opt 57092}#)
+ (if #{rest 57093}# (list #{rest 57093}#) '())
+ (if (pair? #{kw 57094}#)
+ (map cadr (cdr #{kw 57094}#))
+ '())))
+ (values
+ #{req 57091}#
+ #{opt 57092}#
+ #{rest 57093}#
+ #{kw 57094}#)
+ (syntax-violation
+ 'lambda*
+ "duplicate identifier in argument list"
+ #{orig-args 55932}#)))))
+ (#{req 55933}# #{orig-args 55932}# '()))))
+ (#{expand-lambda-case 28283}#
+ (lambda (#{e 57203}#
+ #{r 57204}#
+ #{w 57205}#
+ #{s 57206}#
+ #{mod 57207}#
+ #{get-formals 57208}#
+ #{clauses 57209}#)
+ (letrec*
+ ((#{parse-req 57210}#
+ (lambda (#{req 57345}#
+ #{opt 57346}#
+ #{rest 57347}#
+ #{kw 57348}#
+ #{body 57349}#)
+ (let ((#{vars 57350}#
+ (map #{gen-var 28285}# #{req 57345}#))
+ (#{labels 57351}#
+ (#{gen-labels 28241}# #{req 57345}#)))
+ (let ((#{r* 57352}#
+ (#{extend-var-env 28234}#
+ #{labels 57351}#
+ #{vars 57350}#
+ #{r 57204}#))
+ (#{w* 57353}#
+ (#{make-binding-wrap 28252}#
+ #{req 57345}#
+ #{labels 57351}#
+ #{w 57205}#)))
+ (#{parse-opt 57211}#
+ (map syntax->datum #{req 57345}#)
+ #{opt 57346}#
+ #{rest 57347}#
+ #{kw 57348}#
+ #{body 57349}#
+ (reverse #{vars 57350}#)
+ #{r* 57352}#
+ #{w* 57353}#
+ '()
+ '())))))
+ (#{parse-opt 57211}#
+ (lambda (#{req 57587}#
+ #{opt 57588}#
+ #{rest 57589}#
+ #{kw 57590}#
+ #{body 57591}#
+ #{vars 57592}#
+ #{r* 57593}#
+ #{w* 57594}#
+ #{out 57595}#
+ #{inits 57596}#)
+ (if (pair? #{opt 57588}#)
+ (let ((#{tmp 57597}# (car #{opt 57588}#)))
+ (let ((#{tmp 57598}#
+ ($sc-dispatch #{tmp 57597}# '(any any))))
+ (if #{tmp 57598}#
+ (@apply
+ (lambda (#{id 57600}# #{i 57601}#)
+ (let ((#{v 57602}#
+ (let ((#{id 57610}#
+ (if (if (vector? #{id 57600}#)
+ (if (= (vector-length
+ #{id 57600}#)
+ 4)
+ (eq? (vector-ref
+ #{id 57600}#
+ 0)
+ 'syntax-object)
#f)
- (vector-ref #{id 25651}# 1)
- #{id 25651}#)))
- (gensym
- (string-append
- (symbol->string #{id 25661}#)
- " ")))))
- (let ((#{l 25654}#
- (#{gen-labels 4418}#
- (list #{v 25653}#))))
- (let ((#{r** 25655}#
- (#{extend-var-env 4410}#
- #{l 25654}#
- (list #{v 25653}#)
- #{r* 25642}#)))
- (let ((#{w** 25656}#
- (#{make-binding-wrap 4429}#
- (list #{id 25651}#)
- #{l 25654}#
- #{w* 25643}#)))
- (#{parse-kw 24787}#
- #{req 25636}#
- #{opt 25637}#
- #{rest 25638}#
- (cdr #{kw 25639}#)
- #{body 25640}#
- (cons #{v 25653}# #{vars 25641}#)
- #{r** 25655}#
- #{w** 25656}#
- #{aok 25644}#
- (cons (list (syntax->datum #{k 25650}#)
- (syntax->datum #{id 25651}#)
- #{v 25653}#)
- #{out 25645}#)
- (cons (#{expand 4450}#
- #{i 25652}#
- #{r* 25642}#
- #{w* 25643}#
- #{mod 24782}#)
- #{inits 25646}#)))))))
- #{tmp 25648}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{tmp 25647}#))))
- (#{parse-body 24788}#
- #{req 25636}#
- #{opt 25637}#
- #{rest 25638}#
- (if (if #{aok 25644}#
- #{aok 25644}#
- (pair? #{out 25645}#))
- (cons #{aok 25644}# (reverse #{out 25645}#))
+ #f)
+ (vector-ref #{id 57600}# 1)
+ #{id 57600}#)))
+ (gensym
+ (string-append
+ (symbol->string #{id 57610}#)
+ " ")))))
+ (let ((#{l 57603}#
+ (#{gen-labels 28241}# (list #{v 57602}#))))
+ (let ((#{r** 57604}#
+ (#{extend-var-env 28234}#
+ #{l 57603}#
+ (list #{v 57602}#)
+ #{r* 57593}#)))
+ (let ((#{w** 57605}#
+ (#{make-binding-wrap 28252}#
+ (list #{id 57600}#)
+ #{l 57603}#
+ #{w* 57594}#)))
+ (#{parse-opt 57211}#
+ #{req 57587}#
+ (cdr #{opt 57588}#)
+ #{rest 57589}#
+ #{kw 57590}#
+ #{body 57591}#
+ (cons #{v 57602}# #{vars 57592}#)
+ #{r** 57604}#
+ #{w** 57605}#
+ (cons (syntax->datum #{id 57600}#)
+ #{out 57595}#)
+ (cons (#{expand 28271}#
+ #{i 57601}#
+ #{r* 57593}#
+ #{w* 57594}#
+ #{mod 57207}#)
+ #{inits 57596}#)))))))
+ #{tmp 57598}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp 57597}#))))
+ (if #{rest 57589}#
+ (let ((#{v 57904}#
+ (let ((#{id 57914}#
+ (if (if (vector? #{rest 57589}#)
+ (if (= (vector-length #{rest 57589}#)
+ 4)
+ (eq? (vector-ref #{rest 57589}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref #{rest 57589}# 1)
+ #{rest 57589}#)))
+ (gensym
+ (string-append
+ (symbol->string #{id 57914}#)
+ " ")))))
+ (let ((#{l 57905}#
+ (#{gen-labels 28241}# (list #{v 57904}#))))
+ (let ((#{r* 57906}#
+ (#{extend-var-env 28234}#
+ #{l 57905}#
+ (list #{v 57904}#)
+ #{r* 57593}#)))
+ (let ((#{w* 57907}#
+ (#{make-binding-wrap 28252}#
+ (list #{rest 57589}#)
+ #{l 57905}#
+ #{w* 57594}#)))
+ (#{parse-kw 57212}#
+ #{req 57587}#
+ (if (pair? #{out 57595}#)
+ (reverse #{out 57595}#)
+ #f)
+ (syntax->datum #{rest 57589}#)
+ (if (pair? #{kw 57590}#)
+ (cdr #{kw 57590}#)
+ #{kw 57590}#)
+ #{body 57591}#
+ (cons #{v 57904}# #{vars 57592}#)
+ #{r* 57906}#
+ #{w* 57907}#
+ (if (pair? #{kw 57590}#) (car #{kw 57590}#) #f)
+ '()
+ #{inits 57596}#)))))
+ (#{parse-kw 57212}#
+ #{req 57587}#
+ (if (pair? #{out 57595}#)
+ (reverse #{out 57595}#)
#f)
- #{body 25640}#
- (reverse #{vars 25641}#)
- #{r* 25642}#
- #{w* 25643}#
- (reverse #{inits 25646}#)
- '()))))
- (#{parse-body 24788}#
- (lambda (#{req 25935}#
- #{opt 25936}#
- #{rest 25937}#
- #{kw 25938}#
- #{body 25939}#
- #{vars 25940}#
- #{r* 25941}#
- #{w* 25942}#
- #{inits 25943}#
- #{meta 25944}#)
- (let ((#{tmp 25946}#
- ($sc-dispatch
- #{body 25939}#
- '(any any . each-any))))
- (if (if #{tmp 25946}#
- (@apply
- (lambda (#{docstring 25950}#
- #{e1 25951}#
- #{e2 25952}#)
- (string? (syntax->datum #{docstring 25950}#)))
- #{tmp 25946}#)
- #f)
- (@apply
- (lambda (#{docstring 25953}# #{e1 25954}# #{e2 25955}#)
- (#{parse-body 24788}#
- #{req 25935}#
- #{opt 25936}#
- #{rest 25937}#
- #{kw 25938}#
- (cons #{e1 25954}# #{e2 25955}#)
- #{vars 25940}#
- #{r* 25941}#
- #{w* 25942}#
- #{inits 25943}#
- (append
- #{meta 25944}#
- (list (cons 'documentation
- (syntax->datum
- #{docstring 25953}#))))))
- #{tmp 25946}#)
- (let ((#{tmp 25956}#
- ($sc-dispatch
- #{body 25939}#
- '(#(vector #(each (any . any)))
- any
- .
- each-any))))
- (if #{tmp 25956}#
- (@apply
- (lambda (#{k 25960}#
- #{v 25961}#
- #{e1 25962}#
- #{e2 25963}#)
- (#{parse-body 24788}#
- #{req 25935}#
- #{opt 25936}#
- #{rest 25937}#
- #{kw 25938}#
- (cons #{e1 25962}# #{e2 25963}#)
- #{vars 25940}#
- #{r* 25941}#
- #{w* 25942}#
- #{inits 25943}#
- (append
- #{meta 25944}#
- (syntax->datum
- (map cons #{k 25960}# #{v 25961}#)))))
- #{tmp 25956}#)
- (let ((#{tmp 25964}#
- ($sc-dispatch
- #{body 25939}#
- '(any . each-any))))
- (if #{tmp 25964}#
- (@apply
- (lambda (#{e1 25968}# #{e2 25969}#)
- (values
- #{meta 25944}#
- #{req 25935}#
- #{opt 25936}#
- #{rest 25937}#
- #{kw 25938}#
- #{inits 25943}#
- #{vars 25940}#
- (#{expand-body 4454}#
- (cons #{e1 25968}# #{e2 25969}#)
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 24778}#)
- #{s 24781}#
+ #f
+ (if (pair? #{kw 57590}#)
+ (cdr #{kw 57590}#)
+ #{kw 57590}#)
+ #{body 57591}#
+ #{vars 57592}#
+ #{r* 57593}#
+ #{w* 57594}#
+ (if (pair? #{kw 57590}#) (car #{kw 57590}#) #f)
+ '()
+ #{inits 57596}#)))))
+ (#{parse-kw 57212}#
+ (lambda (#{req 58133}#
+ #{opt 58134}#
+ #{rest 58135}#
+ #{kw 58136}#
+ #{body 58137}#
+ #{vars 58138}#
+ #{r* 58139}#
+ #{w* 58140}#
+ #{aok 58141}#
+ #{out 58142}#
+ #{inits 58143}#)
+ (if (pair? #{kw 58136}#)
+ (let ((#{tmp 58144}# (car #{kw 58136}#)))
+ (let ((#{tmp 58145}#
+ ($sc-dispatch #{tmp 58144}# '(any any any))))
+ (if #{tmp 58145}#
+ (@apply
+ (lambda (#{k 58147}# #{id 58148}# #{i 58149}#)
+ (let ((#{v 58150}#
+ (let ((#{id 58158}#
+ (if (if (vector? #{id 58148}#)
+ (if (= (vector-length
+ #{id 58148}#)
+ 4)
+ (eq? (vector-ref
+ #{id 58148}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref #{id 58148}# 1)
+ #{id 58148}#)))
+ (gensym
+ (string-append
+ (symbol->string #{id 58158}#)
+ " ")))))
+ (let ((#{l 58151}#
+ (#{gen-labels 28241}# (list #{v 58150}#))))
+ (let ((#{r** 58152}#
+ (#{extend-var-env 28234}#
+ #{l 58151}#
+ (list #{v 58150}#)
+ #{r* 58139}#)))
+ (let ((#{w** 58153}#
+ (#{make-binding-wrap 28252}#
+ (list #{id 58148}#)
+ #{l 58151}#
+ #{w* 58140}#)))
+ (#{parse-kw 57212}#
+ #{req 58133}#
+ #{opt 58134}#
+ #{rest 58135}#
+ (cdr #{kw 58136}#)
+ #{body 58137}#
+ (cons #{v 58150}# #{vars 58138}#)
+ #{r** 58152}#
+ #{w** 58153}#
+ #{aok 58141}#
+ (cons (list (syntax->datum #{k 58147}#)
+ (syntax->datum #{id 58148}#)
+ #{v 58150}#)
+ #{out 58142}#)
+ (cons (#{expand 28271}#
+ #{i 58149}#
+ #{r* 58139}#
+ #{w* 58140}#
+ #{mod 57207}#)
+ #{inits 58143}#)))))))
+ #{tmp 58145}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{tmp 58144}#))))
+ (#{parse-body 57213}#
+ #{req 58133}#
+ #{opt 58134}#
+ #{rest 58135}#
+ (if (if #{aok 58141}#
+ #{aok 58141}#
+ (pair? #{out 58142}#))
+ (cons #{aok 58141}# (reverse #{out 58142}#))
+ #f)
+ #{body 58137}#
+ (reverse #{vars 58138}#)
+ #{r* 58139}#
+ #{w* 58140}#
+ (reverse #{inits 58143}#)
+ '()))))
+ (#{parse-body 57213}#
+ (lambda (#{req 58461}#
+ #{opt 58462}#
+ #{rest 58463}#
+ #{kw 58464}#
+ #{body 58465}#
+ #{vars 58466}#
+ #{r* 58467}#
+ #{w* 58468}#
+ #{inits 58469}#
+ #{meta 58470}#)
+ (let ((#{tmp 58472}#
+ ($sc-dispatch
+ #{body 58465}#
+ '(any any . each-any))))
+ (if (if #{tmp 58472}#
+ (@apply
+ (lambda (#{docstring 58476}# #{e1 58477}# #{e2 58478}#)
+ (string? (syntax->datum #{docstring 58476}#)))
+ #{tmp 58472}#)
+ #f)
+ (@apply
+ (lambda (#{docstring 58479}# #{e1 58480}# #{e2 58481}#)
+ (#{parse-body 57213}#
+ #{req 58461}#
+ #{opt 58462}#
+ #{rest 58463}#
+ #{kw 58464}#
+ (cons #{e1 58480}# #{e2 58481}#)
+ #{vars 58466}#
+ #{r* 58467}#
+ #{w* 58468}#
+ #{inits 58469}#
+ (append
+ #{meta 58470}#
+ (list (cons 'documentation
+ (syntax->datum #{docstring 58479}#))))))
+ #{tmp 58472}#)
+ (let ((#{tmp 58482}#
+ ($sc-dispatch
+ #{body 58465}#
+ '(#(vector #(each (any . any))) any . each-any))))
+ (if #{tmp 58482}#
+ (@apply
+ (lambda (#{k 58486}#
+ #{v 58487}#
+ #{e1 58488}#
+ #{e2 58489}#)
+ (#{parse-body 57213}#
+ #{req 58461}#
+ #{opt 58462}#
+ #{rest 58463}#
+ #{kw 58464}#
+ (cons #{e1 58488}# #{e2 58489}#)
+ #{vars 58466}#
+ #{r* 58467}#
+ #{w* 58468}#
+ #{inits 58469}#
+ (append
+ #{meta 58470}#
+ (syntax->datum
+ (map cons #{k 58486}# #{v 58487}#)))))
+ #{tmp 58482}#)
+ (let ((#{tmp 58490}#
+ ($sc-dispatch #{body 58465}# '(any . each-any))))
+ (if #{tmp 58490}#
+ (@apply
+ (lambda (#{e1 58494}# #{e2 58495}#)
+ (values
+ #{meta 58470}#
+ #{req 58461}#
+ #{opt 58462}#
+ #{rest 58463}#
+ #{kw 58464}#
+ #{inits 58469}#
+ #{vars 58466}#
+ (#{expand-body 28275}#
+ (cons #{e1 58494}# #{e2 58495}#)
+ (let ((#{x 58507}#
+ (begin
+ (if (if (pair? #{e 57203}#)
+ #{s 57206}#
+ #f)
+ (set-source-properties!
+ #{e 57203}#
+ #{s 57206}#))
+ #{e 57203}#)))
+ (if (if (null? (car #{w 57205}#))
+ (null? (cdr #{w 57205}#))
+ #f)
+ #{x 58507}#
+ (if (if (vector? #{x 58507}#)
+ (if (= (vector-length #{x 58507}#)
+ 4)
+ (eq? (vector-ref #{x 58507}# 0)
+ 'syntax-object)
#f)
- (set-source-properties!
- #{e 24778}#
- #{s 24781}#))
- #{e 24778}#)
- #{w 24780}#
- #{mod 24782}#)
- #{r* 25941}#
- #{w* 25942}#
- #{mod 24782}#)))
- #{tmp 25964}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{body 25939}#))))))))))
- (let ((#{tmp 24790}#
- ($sc-dispatch #{clauses 24784}# '())))
- (if #{tmp 24790}#
- (@apply
- (lambda () (values '() #f))
- #{tmp 24790}#)
- (let ((#{tmp 24794}#
- ($sc-dispatch
- #{clauses 24784}#
- '((any any . each-any)
- .
- #(each (any any . each-any))))))
- (if #{tmp 24794}#
- (@apply
- (lambda (#{args 24798}#
- #{e1 24799}#
- #{e2 24800}#
- #{args* 24801}#
- #{e1* 24802}#
- #{e2* 24803}#)
- (call-with-values
- (lambda ()
- (#{get-formals 24783}# #{args 24798}#))
- (lambda (#{req 24804}#
- #{opt 24805}#
- #{rest 24806}#
- #{kw 24807}#)
- (call-with-values
- (lambda ()
- (#{parse-req 24785}#
- #{req 24804}#
- #{opt 24805}#
- #{rest 24806}#
- #{kw 24807}#
- (cons #{e1 24799}# #{e2 24800}#)))
- (lambda (#{meta 24874}#
- #{req 24875}#
- #{opt 24876}#
- #{rest 24877}#
- #{kw 24878}#
- #{inits 24879}#
- #{vars 24880}#
- #{body 24881}#)
- (call-with-values
- (lambda ()
- (#{expand-lambda-case 4462}#
- #{e 24778}#
- #{r 24779}#
- #{w 24780}#
- #{s 24781}#
- #{mod 24782}#
- #{get-formals 24783}#
- (map (lambda (#{tmp 2833 24882}#
- #{tmp 2832 24883}#
- #{tmp 2831 24884}#)
- (cons #{tmp 2831 24884}#
- (cons #{tmp 2832 24883}#
- #{tmp 2833 24882}#)))
- #{e2* 24803}#
- #{e1* 24802}#
- #{args* 24801}#)))
- (lambda (#{meta* 24885}# #{else* 24886}#)
- (values
- (append #{meta 24874}# #{meta* 24885}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #{s 24781}#
- #{req 24875}#
- #{opt 24876}#
- #{rest 24877}#
- #{kw 24878}#
- #{inits 24879}#
- #{vars 24880}#
- #{body 24881}#
- #{else* 24886}#)))))))))
- #{tmp 24794}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{clauses 24784}#))))))))
- (#{strip 4463}#
- (lambda (#{x 26006}# #{w 26007}#)
- (if (memq 'top (car #{w 26007}#))
- #{x 26006}#
- (letrec*
- ((#{f 26008}#
- (lambda (#{x 26011}#)
- (if (if (vector? #{x 26011}#)
- (if (= (vector-length #{x 26011}#) 4)
- (eq? (vector-ref #{x 26011}# 0) 'syntax-object)
- #f)
+ #f)
+ (let ((#{expression 58539}#
+ (vector-ref #{x 58507}# 1))
+ (#{wrap 58540}#
+ (let ((#{w2 58548}#
+ (vector-ref
+ #{x 58507}#
+ 2)))
+ (let ((#{m1 58549}#
+ (car #{w 57205}#))
+ (#{s1 58550}#
+ (cdr #{w 57205}#)))
+ (if (null? #{m1 58549}#)
+ (if (null? #{s1 58550}#)
+ #{w2 58548}#
+ (cons (car #{w2 58548}#)
+ (let ((#{m2 58565}#
+ (cdr #{w2 58548}#)))
+ (if (null? #{m2 58565}#)
+ #{s1 58550}#
+ (append
+ #{s1 58550}#
+ #{m2 58565}#)))))
+ (cons (let ((#{m2 58573}#
+ (car #{w2 58548}#)))
+ (if (null? #{m2 58573}#)
+ #{m1 58549}#
+ (append
+ #{m1 58549}#
+ #{m2 58573}#)))
+ (let ((#{m2 58581}#
+ (cdr #{w2 58548}#)))
+ (if (null? #{m2 58581}#)
+ #{s1 58550}#
+ (append
+ #{s1 58550}#
+ #{m2 58581}#))))))))
+ (#{module 58541}#
+ (vector-ref #{x 58507}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 58539}#
+ #{wrap 58540}#
+ #{module 58541}#))
+ (if (null? #{x 58507}#)
+ #{x 58507}#
+ (vector
+ 'syntax-object
+ #{x 58507}#
+ #{w 57205}#
+ #{mod 57207}#)))))
+ #{r* 58467}#
+ #{w* 58468}#
+ #{mod 57207}#)))
+ #{tmp 58490}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{body 58465}#))))))))))
+ (let ((#{tmp 57215}#
+ ($sc-dispatch #{clauses 57209}# '())))
+ (if #{tmp 57215}#
+ (@apply
+ (lambda () (values '() #f))
+ #{tmp 57215}#)
+ (let ((#{tmp 57219}#
+ ($sc-dispatch
+ #{clauses 57209}#
+ '((any any . each-any)
+ .
+ #(each (any any . each-any))))))
+ (if #{tmp 57219}#
+ (@apply
+ (lambda (#{args 57223}#
+ #{e1 57224}#
+ #{e2 57225}#
+ #{args* 57226}#
+ #{e1* 57227}#
+ #{e2* 57228}#)
+ (call-with-values
+ (lambda ()
+ (#{get-formals 57208}# #{args 57223}#))
+ (lambda (#{req 57229}#
+ #{opt 57230}#
+ #{rest 57231}#
+ #{kw 57232}#)
+ (call-with-values
+ (lambda ()
+ (#{parse-req 57210}#
+ #{req 57229}#
+ #{opt 57230}#
+ #{rest 57231}#
+ #{kw 57232}#
+ (cons #{e1 57224}# #{e2 57225}#)))
+ (lambda (#{meta 57301}#
+ #{req 57302}#
+ #{opt 57303}#
+ #{rest 57304}#
+ #{kw 57305}#
+ #{inits 57306}#
+ #{vars 57307}#
+ #{body 57308}#)
+ (call-with-values
+ (lambda ()
+ (#{expand-lambda-case 28283}#
+ #{e 57203}#
+ #{r 57204}#
+ #{w 57205}#
+ #{s 57206}#
+ #{mod 57207}#
+ #{get-formals 57208}#
+ (map (lambda (#{tmp 26711 57309}#
+ #{tmp 26710 57310}#
+ #{tmp 26709 57311}#)
+ (cons #{tmp 26709 57311}#
+ (cons #{tmp 26710 57310}#
+ #{tmp 26711 57309}#)))
+ #{e2* 57228}#
+ #{e1* 57227}#
+ #{args* 57226}#)))
+ (lambda (#{meta* 57312}# #{else* 57313}#)
+ (values
+ (append #{meta 57301}# #{meta* 57312}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 15)
+ #{s 57206}#
+ #{req 57302}#
+ #{opt 57303}#
+ #{rest 57304}#
+ #{kw 57305}#
+ #{inits 57306}#
+ #{vars 57307}#
+ #{body 57308}#
+ #{else* 57313}#)))))))))
+ #{tmp 57219}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{clauses 57209}#))))))))
+ (#{strip 28284}#
+ (lambda (#{x 58608}# #{w 58609}#)
+ (if (memq 'top (car #{w 58609}#))
+ #{x 58608}#
+ (letrec*
+ ((#{f 58610}#
+ (lambda (#{x 58613}#)
+ (if (if (vector? #{x 58613}#)
+ (if (= (vector-length #{x 58613}#) 4)
+ (eq? (vector-ref #{x 58613}# 0) 'syntax-object)
#f)
- (#{strip 4463}#
- (vector-ref #{x 26011}# 1)
- (vector-ref #{x 26011}# 2))
- (if (pair? #{x 26011}#)
- (let ((#{a 26030}# (#{f 26008}# (car #{x 26011}#)))
- (#{d 26031}# (#{f 26008}# (cdr #{x 26011}#))))
- (if (if (eq? #{a 26030}# (car #{x 26011}#))
- (eq? #{d 26031}# (cdr #{x 26011}#))
- #f)
- #{x 26011}#
- (cons #{a 26030}# #{d 26031}#)))
- (if (vector? #{x 26011}#)
- (let ((#{old 26034}# (vector->list #{x 26011}#)))
- (let ((#{new 26035}#
- (map #{f 26008}# #{old 26034}#)))
- (letrec*
- ((#{lp 26036}#
- (lambda (#{l1 26112}# #{l2 26113}#)
- (if (null? #{l1 26112}#)
- #{x 26011}#
- (if (eq? (car #{l1 26112}#)
- (car #{l2 26113}#))
- (#{lp 26036}#
- (cdr #{l1 26112}#)
- (cdr #{l2 26113}#))
- (list->vector #{new 26035}#))))))
- (#{lp 26036}# #{old 26034}# #{new 26035}#))))
- #{x 26011}#))))))
- (#{f 26008}# #{x 26006}#)))))
- (#{gen-var 4464}#
- (lambda (#{id 24930}#)
- (let ((#{id 24931}#
- (if (if (vector? #{id 24930}#)
- (if (= (vector-length #{id 24930}#) 4)
- (eq? (vector-ref #{id 24930}# 0) 'syntax-object)
- #f)
+ #f)
+ (#{strip 28284}#
+ (vector-ref #{x 58613}# 1)
+ (vector-ref #{x 58613}# 2))
+ (if (pair? #{x 58613}#)
+ (let ((#{a 58632}# (#{f 58610}# (car #{x 58613}#)))
+ (#{d 58633}# (#{f 58610}# (cdr #{x 58613}#))))
+ (if (if (eq? #{a 58632}# (car #{x 58613}#))
+ (eq? #{d 58633}# (cdr #{x 58613}#))
+ #f)
+ #{x 58613}#
+ (cons #{a 58632}# #{d 58633}#)))
+ (if (vector? #{x 58613}#)
+ (let ((#{old 58636}# (vector->list #{x 58613}#)))
+ (let ((#{new 58637}# (map #{f 58610}# #{old 58636}#)))
+ (letrec*
+ ((#{lp 58638}#
+ (lambda (#{l1 58735}# #{l2 58736}#)
+ (if (null? #{l1 58735}#)
+ #{x 58613}#
+ (if (eq? (car #{l1 58735}#)
+ (car #{l2 58736}#))
+ (#{lp 58638}#
+ (cdr #{l1 58735}#)
+ (cdr #{l2 58736}#))
+ (list->vector #{new 58637}#))))))
+ (#{lp 58638}# #{old 58636}# #{new 58637}#))))
+ #{x 58613}#))))))
+ (#{f 58610}# #{x 58608}#)))))
+ (#{gen-var 28285}#
+ (lambda (#{id 57357}#)
+ (let ((#{id 57358}#
+ (if (if (vector? #{id 57357}#)
+ (if (= (vector-length #{id 57357}#) 4)
+ (eq? (vector-ref #{id 57357}# 0) 'syntax-object)
#f)
- (vector-ref #{id 24930}# 1)
- #{id 24930}#)))
- (gensym
- (string-append (symbol->string #{id 24931}#) " "))))))
- (begin
- (set! #{transformer-environment 4436}#
- (make-fluid
- (lambda (#{k 14155}#)
- (error "called outside the dynamic extent of a syntax transformer"))))
- (module-define!
- (current-module)
+ #f)
+ (vector-ref #{id 57357}# 1)
+ #{id 57357}#)))
+ (gensym
+ (string-append (symbol->string #{id 57358}#) " ")))))
+ (#{lambda-var-list 28286}#
+ (lambda (#{vars 58737}#)
+ (letrec*
+ ((#{lvl 58738}#
+ (lambda (#{vars 58741}# #{ls 58742}# #{w 58743}#)
+ (if (pair? #{vars 58741}#)
+ (#{lvl 58738}#
+ (cdr #{vars 58741}#)
+ (cons (let ((#{x 58747}# (car #{vars 58741}#)))
+ (if (if (null? (car #{w 58743}#))
+ (null? (cdr #{w 58743}#))
+ #f)
+ #{x 58747}#
+ (if (if (vector? #{x 58747}#)
+ (if (= (vector-length #{x 58747}#) 4)
+ (eq? (vector-ref #{x 58747}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 58765}#
+ (vector-ref #{x 58747}# 1))
+ (#{wrap 58766}#
+ (let ((#{w2 58774}#
+ (vector-ref #{x 58747}# 2)))
+ (let ((#{m1 58775}# (car #{w 58743}#))
+ (#{s1 58776}# (cdr #{w 58743}#)))
+ (if (null? #{m1 58775}#)
+ (if (null? #{s1 58776}#)
+ #{w2 58774}#
+ (cons (car #{w2 58774}#)
+ (let ((#{m2 58791}#
+ (cdr #{w2 58774}#)))
+ (if (null? #{m2 58791}#)
+ #{s1 58776}#
+ (append
+ #{s1 58776}#
+ #{m2 58791}#)))))
+ (cons (let ((#{m2 58799}#
+ (car #{w2 58774}#)))
+ (if (null? #{m2 58799}#)
+ #{m1 58775}#
+ (append
+ #{m1 58775}#
+ #{m2 58799}#)))
+ (let ((#{m2 58807}#
+ (cdr #{w2 58774}#)))
+ (if (null? #{m2 58807}#)
+ #{s1 58776}#
+ (append
+ #{s1 58776}#
+ #{m2 58807}#))))))))
+ (#{module 58767}#
+ (vector-ref #{x 58747}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 58765}#
+ #{wrap 58766}#
+ #{module 58767}#))
+ (if (null? #{x 58747}#)
+ #{x 58747}#
+ (vector
+ 'syntax-object
+ #{x 58747}#
+ #{w 58743}#
+ #f)))))
+ #{ls 58742}#)
+ #{w 58743}#)
+ (if (if (symbol? #{vars 58741}#)
+ #t
+ (if (if (vector? #{vars 58741}#)
+ (if (= (vector-length #{vars 58741}#) 4)
+ (eq? (vector-ref #{vars 58741}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref #{vars 58741}# 1))
+ #f))
+ (cons (if (if (null? (car #{w 58743}#))
+ (null? (cdr #{w 58743}#))
+ #f)
+ #{vars 58741}#
+ (if (if (vector? #{vars 58741}#)
+ (if (= (vector-length #{vars 58741}#) 4)
+ (eq? (vector-ref #{vars 58741}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 58877}#
+ (vector-ref #{vars 58741}# 1))
+ (#{wrap 58878}#
+ (let ((#{w2 58888}#
+ (vector-ref #{vars 58741}# 2)))
+ (let ((#{m1 58889}# (car #{w 58743}#))
+ (#{s1 58890}# (cdr #{w 58743}#)))
+ (if (null? #{m1 58889}#)
+ (if (null? #{s1 58890}#)
+ #{w2 58888}#
+ (cons (car #{w2 58888}#)
+ (let ((#{m2 58907}#
+ (cdr #{w2 58888}#)))
+ (if (null? #{m2 58907}#)
+ #{s1 58890}#
+ (append
+ #{s1 58890}#
+ #{m2 58907}#)))))
+ (cons (let ((#{m2 58915}#
+ (car #{w2 58888}#)))
+ (if (null? #{m2 58915}#)
+ #{m1 58889}#
+ (append
+ #{m1 58889}#
+ #{m2 58915}#)))
+ (let ((#{m2 58923}#
+ (cdr #{w2 58888}#)))
+ (if (null? #{m2 58923}#)
+ #{s1 58890}#
+ (append
+ #{s1 58890}#
+ #{m2 58923}#))))))))
+ (#{module 58879}#
+ (vector-ref #{vars 58741}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 58877}#
+ #{wrap 58878}#
+ #{module 58879}#))
+ (if (null? #{vars 58741}#)
+ #{vars 58741}#
+ (vector
+ 'syntax-object
+ #{vars 58741}#
+ #{w 58743}#
+ #f))))
+ #{ls 58742}#)
+ (if (null? #{vars 58741}#)
+ #{ls 58742}#
+ (if (if (vector? #{vars 58741}#)
+ (if (= (vector-length #{vars 58741}#) 4)
+ (eq? (vector-ref #{vars 58741}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (#{lvl 58738}#
+ (vector-ref #{vars 58741}# 1)
+ #{ls 58742}#
+ (let ((#{w2 58964}# (vector-ref #{vars 58741}# 2)))
+ (let ((#{m1 58965}# (car #{w 58743}#))
+ (#{s1 58966}# (cdr #{w 58743}#)))
+ (if (null? #{m1 58965}#)
+ (if (null? #{s1 58966}#)
+ #{w2 58964}#
+ (cons (car #{w2 58964}#)
+ (let ((#{m2 58977}# (cdr #{w2 58964}#)))
+ (if (null? #{m2 58977}#)
+ #{s1 58966}#
+ (append
+ #{s1 58966}#
+ #{m2 58977}#)))))
+ (cons (let ((#{m2 58985}# (car #{w2 58964}#)))
+ (if (null? #{m2 58985}#)
+ #{m1 58965}#
+ (append #{m1 58965}# #{m2 58985}#)))
+ (let ((#{m2 58993}# (cdr #{w2 58964}#)))
+ (if (null? #{m2 58993}#)
+ #{s1 58966}#
+ (append
+ #{s1 58966}#
+ #{m2 58993}#))))))))
+ (cons #{vars 58741}# #{ls 58742}#))))))))
+ (#{lvl 58738}# #{vars 58737}# '() '(()))))))
+ (begin
+ (module-define!
+ (current-module)
+ 'letrec-syntax
+ (make-syntax-transformer
'letrec-syntax
- (make-syntax-transformer
- 'letrec-syntax
- 'local-syntax
- #t))
- (module-define!
- (current-module)
+ 'local-syntax
+ #t))
+ (module-define!
+ (current-module)
+ 'let-syntax
+ (make-syntax-transformer
'let-syntax
- (make-syntax-transformer
- 'let-syntax
- 'local-syntax
- #f))
- (#{global-extend 4413}#
+ 'local-syntax
+ #f))
+ (#{global-extend 28236}#
+ 'core
+ 'syntax-parameterize
+ (lambda (#{e 28413}#
+ #{r 28414}#
+ #{w 28415}#
+ #{s 28416}#
+ #{mod 28417}#)
+ (let ((#{tmp 28419}#
+ ($sc-dispatch
+ #{e 28413}#
+ '(_ #(each (any any)) any . each-any))))
+ (if (if #{tmp 28419}#
+ (@apply
+ (lambda (#{var 28423}#
+ #{val 28424}#
+ #{e1 28425}#
+ #{e2 28426}#)
+ (#{valid-bound-ids? 28261}# #{var 28423}#))
+ #{tmp 28419}#)
+ #f)
+ (@apply
+ (lambda (#{var 28511}#
+ #{val 28512}#
+ #{e1 28513}#
+ #{e2 28514}#)
+ (let ((#{names 28515}#
+ (map (lambda (#{x 28855}#)
+ (call-with-values
+ (lambda ()
+ (#{resolve-identifier 28258}#
+ #{x 28855}#
+ #{w 28415}#
+ #{r 28414}#
+ #{mod 28417}#
+ #f))
+ (lambda (#{type 28858}#
+ #{value 28859}#
+ #{mod 28860}#)
+ (if (eqv? #{type 28858}# 'displaced-lexical)
+ (syntax-violation
+ 'syntax-parameterize
+ "identifier out of context"
+ #{e 28413}#
+ (let ((#{x 28873}#
+ (begin
+ (if (if (pair? #{x 28855}#)
+ #{s 28416}#
+ #f)
+ (set-source-properties!
+ #{x 28855}#
+ #{s 28416}#))
+ #{x 28855}#)))
+ (if (if (null? (car #{w 28415}#))
+ (null? (cdr #{w 28415}#))
+ #f)
+ #{x 28873}#
+ (if (if (vector? #{x 28873}#)
+ (if (= (vector-length
+ #{x 28873}#)
+ 4)
+ (eq? (vector-ref
+ #{x 28873}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 28905}#
+ (vector-ref
+ #{x 28873}#
+ 1))
+ (#{wrap 28906}#
+ (let ((#{w2 28914}#
+ (vector-ref
+ #{x 28873}#
+ 2)))
+ (let ((#{m1 28915}#
+ (car #{w 28415}#))
+ (#{s1 28916}#
+ (cdr #{w 28415}#)))
+ (if (null? #{m1 28915}#)
+ (if (null? #{s1 28916}#)
+ #{w2 28914}#
+ (cons (car #{w2 28914}#)
+ (let ((#{m2 28931}#
+ (cdr #{w2 28914}#)))
+ (if (null? #{m2 28931}#)
+ #{s1 28916}#
+ (append
+ #{s1 28916}#
+ #{m2 28931}#)))))
+ (cons (let ((#{m2 28939}#
+ (car #{w2 28914}#)))
+ (if (null? #{m2 28939}#)
+ #{m1 28915}#
+ (append
+ #{m1 28915}#
+ #{m2 28939}#)))
+ (let ((#{m2 28947}#
+ (cdr #{w2 28914}#)))
+ (if (null? #{m2 28947}#)
+ #{s1 28916}#
+ (append
+ #{s1 28916}#
+ #{m2 28947}#))))))))
+ (#{module 28907}#
+ (vector-ref
+ #{x 28873}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 28905}#
+ #{wrap 28906}#
+ #{module 28907}#))
+ (if (null? #{x 28873}#)
+ #{x 28873}#
+ (vector
+ 'syntax-object
+ #{x 28873}#
+ #{w 28415}#
+ #{mod 28860}#))))))
+ (if (eqv? #{type 28858}#
+ 'syntax-parameter)
+ #{value 28859}#
+ (syntax-violation
+ 'syntax-parameterize
+ "invalid syntax parameter"
+ #{e 28413}#
+ (let ((#{x 28974}#
+ (begin
+ (if (if (pair? #{x 28855}#)
+ #{s 28416}#
+ #f)
+ (set-source-properties!
+ #{x 28855}#
+ #{s 28416}#))
+ #{x 28855}#)))
+ (if (if (null? (car #{w 28415}#))
+ (null? (cdr #{w 28415}#))
+ #f)
+ #{x 28974}#
+ (if (if (vector? #{x 28974}#)
+ (if (= (vector-length
+ #{x 28974}#)
+ 4)
+ (eq? (vector-ref
+ #{x 28974}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 29006}#
+ (vector-ref
+ #{x 28974}#
+ 1))
+ (#{wrap 29007}#
+ (let ((#{w2 29015}#
+ (vector-ref
+ #{x 28974}#
+ 2)))
+ (let ((#{m1 29016}#
+ (car #{w 28415}#))
+ (#{s1 29017}#
+ (cdr #{w 28415}#)))
+ (if (null? #{m1 29016}#)
+ (if (null? #{s1 29017}#)
+ #{w2 29015}#
+ (cons (car #{w2 29015}#)
+ (let ((#{m2 29032}#
+ (cdr #{w2 29015}#)))
+ (if (null? #{m2 29032}#)
+ #{s1 29017}#
+ (append
+ #{s1 29017}#
+ #{m2 29032}#)))))
+ (cons (let ((#{m2 29040}#
+ (car #{w2 29015}#)))
+ (if (null? #{m2 29040}#)
+ #{m1 29016}#
+ (append
+ #{m1 29016}#
+ #{m2 29040}#)))
+ (let ((#{m2 29048}#
+ (cdr #{w2 29015}#)))
+ (if (null? #{m2 29048}#)
+ #{s1 29017}#
+ (append
+ #{s1 29017}#
+ #{m2 29048}#))))))))
+ (#{module 29008}#
+ (vector-ref
+ #{x 28974}#
+ 3)))
+ (vector
+ 'syntax-object
+ #{expression 29006}#
+ #{wrap 29007}#
+ #{module 29008}#))
+ (if (null? #{x 28974}#)
+ #{x 28974}#
+ (vector
+ 'syntax-object
+ #{x 28974}#
+ #{w 28415}#
+ #{mod 28860}#)))))))))))
+ #{var 28511}#))
+ (#{bindings 28516}#
+ (let ((#{trans-r 29063}#
+ (#{macros-only-env 28235}# #{r 28414}#)))
+ (map (lambda (#{x 29064}#)
+ (cons 'macro
+ (#{eval-local-transformer 28277}#
+ (#{expand 28271}#
+ #{x 29064}#
+ #{trans-r 29063}#
+ #{w 28415}#
+ #{mod 28417}#)
+ #{mod 28417}#)))
+ #{val 28512}#))))
+ (#{expand-body 28275}#
+ (cons #{e1 28513}# #{e2 28514}#)
+ (let ((#{x 28528}#
+ (begin
+ (if (if (pair? #{e 28413}#) #{s 28416}# #f)
+ (set-source-properties!
+ #{e 28413}#
+ #{s 28416}#))
+ #{e 28413}#)))
+ (if (if (null? (car #{w 28415}#))
+ (null? (cdr #{w 28415}#))
+ #f)
+ #{x 28528}#
+ (if (if (vector? #{x 28528}#)
+ (if (= (vector-length #{x 28528}#) 4)
+ (eq? (vector-ref #{x 28528}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 28560}#
+ (vector-ref #{x 28528}# 1))
+ (#{wrap 28561}#
+ (let ((#{w2 28569}#
+ (vector-ref #{x 28528}# 2)))
+ (let ((#{m1 28570}# (car #{w 28415}#))
+ (#{s1 28571}# (cdr #{w 28415}#)))
+ (if (null? #{m1 28570}#)
+ (if (null? #{s1 28571}#)
+ #{w2 28569}#
+ (cons (car #{w2 28569}#)
+ (let ((#{m2 28586}#
+ (cdr #{w2 28569}#)))
+ (if (null? #{m2 28586}#)
+ #{s1 28571}#
+ (append
+ #{s1 28571}#
+ #{m2 28586}#)))))
+ (cons (let ((#{m2 28594}#
+ (car #{w2 28569}#)))
+ (if (null? #{m2 28594}#)
+ #{m1 28570}#
+ (append
+ #{m1 28570}#
+ #{m2 28594}#)))
+ (let ((#{m2 28602}#
+ (cdr #{w2 28569}#)))
+ (if (null? #{m2 28602}#)
+ #{s1 28571}#
+ (append
+ #{s1 28571}#
+ #{m2 28602}#))))))))
+ (#{module 28562}# (vector-ref #{x 28528}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 28560}#
+ #{wrap 28561}#
+ #{module 28562}#))
+ (if (null? #{x 28528}#)
+ #{x 28528}#
+ (vector
+ 'syntax-object
+ #{x 28528}#
+ #{w 28415}#
+ #{mod 28417}#)))))
+ (#{extend-env 28233}#
+ #{names 28515}#
+ #{bindings 28516}#
+ #{r 28414}#)
+ #{w 28415}#
+ #{mod 28417}#)))
+ #{tmp 28419}#)
+ (syntax-violation
+ 'syntax-parameterize
+ "bad syntax"
+ (let ((#{x 29284}#
+ (begin
+ (if (if (pair? #{e 28413}#) #{s 28416}# #f)
+ (set-source-properties! #{e 28413}# #{s 28416}#))
+ #{e 28413}#)))
+ (if (if (null? (car #{w 28415}#))
+ (null? (cdr #{w 28415}#))
+ #f)
+ #{x 29284}#
+ (if (if (vector? #{x 29284}#)
+ (if (= (vector-length #{x 29284}#) 4)
+ (eq? (vector-ref #{x 29284}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 29316}# (vector-ref #{x 29284}# 1))
+ (#{wrap 29317}#
+ (let ((#{w2 29325}# (vector-ref #{x 29284}# 2)))
+ (let ((#{m1 29326}# (car #{w 28415}#))
+ (#{s1 29327}# (cdr #{w 28415}#)))
+ (if (null? #{m1 29326}#)
+ (if (null? #{s1 29327}#)
+ #{w2 29325}#
+ (cons (car #{w2 29325}#)
+ (let ((#{m2 29342}#
+ (cdr #{w2 29325}#)))
+ (if (null? #{m2 29342}#)
+ #{s1 29327}#
+ (append
+ #{s1 29327}#
+ #{m2 29342}#)))))
+ (cons (let ((#{m2 29350}#
+ (car #{w2 29325}#)))
+ (if (null? #{m2 29350}#)
+ #{m1 29326}#
+ (append
+ #{m1 29326}#
+ #{m2 29350}#)))
+ (let ((#{m2 29358}#
+ (cdr #{w2 29325}#)))
+ (if (null? #{m2 29358}#)
+ #{s1 29327}#
+ (append
+ #{s1 29327}#
+ #{m2 29358}#))))))))
+ (#{module 29318}# (vector-ref #{x 29284}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 29316}#
+ #{wrap 29317}#
+ #{module 29318}#))
+ (if (null? #{x 29284}#)
+ #{x 29284}#
+ (vector
+ 'syntax-object
+ #{x 29284}#
+ #{w 28415}#
+ #{mod 28417}#))))))))))
+ (module-define!
+ (current-module)
+ 'quote
+ (make-syntax-transformer
+ 'quote
'core
- 'syntax-parameterize
- (lambda (#{e 4585}#
- #{r 4586}#
- #{w 4587}#
- #{s 4588}#
- #{mod 4589}#)
- (let ((#{tmp 4591}#
- ($sc-dispatch
- #{e 4585}#
- '(_ #(each (any any)) any . each-any))))
- (if (if #{tmp 4591}#
- (@apply
- (lambda (#{var 4595}#
- #{val 4596}#
- #{e1 4597}#
- #{e2 4598}#)
- (#{valid-bound-ids? 4440}# #{var 4595}#))
- #{tmp 4591}#)
- #f)
+ (lambda (#{e 29386}#
+ #{r 29387}#
+ #{w 29388}#
+ #{s 29389}#
+ #{mod 29390}#)
+ (let ((#{tmp 29392}#
+ ($sc-dispatch #{e 29386}# '(_ any))))
+ (if #{tmp 29392}#
(@apply
- (lambda (#{var 4676}#
- #{val 4677}#
- #{e1 4678}#
- #{e2 4679}#)
- (let ((#{names 4680}#
- (map (lambda (#{x 4730}#)
- (#{id-var-name 4434}# #{x 4730}# #{w 4587}#))
- #{var 4676}#)))
- (begin
- (for-each
- (lambda (#{id 4681}# #{n 4682}#)
- (let ((#{atom-key 4683}#
- (car (let ((#{t 4690}#
- (assq #{n 4682}# #{r 4586}#)))
- (if #{t 4690}#
- (cdr #{t 4690}#)
- (if (symbol? #{n 4682}#)
- (let ((#{t 4695}#
- (#{get-global-definition-hook 4378}#
- #{n 4682}#
- #{mod 4589}#)))
- (if #{t 4695}#
- #{t 4695}#
- '(global)))
- '(displaced-lexical)))))))
- (if (eqv? #{atom-key 4683}# 'displaced-lexical)
- (syntax-violation
- 'syntax-parameterize
- "identifier out of context"
- #{e 4585}#
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{id 4681}#) #{s 4588}# #f)
- (set-source-properties!
- #{id 4681}#
- #{s 4588}#))
- #{id 4681}#)
- #{w 4587}#
- #{mod 4589}#)))))
- #{var 4676}#
- #{names 4680}#)
- (#{expand-body 4454}#
- (cons #{e1 4678}# #{e2 4679}#)
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 4585}#) #{s 4588}# #f)
- (set-source-properties! #{e 4585}# #{s 4588}#))
- #{e 4585}#)
- #{w 4587}#
- #{mod 4589}#)
- (#{extend-env 4409}#
- #{names 4680}#
- (let ((#{trans-r 4816}#
- (#{macros-only-env 4411}# #{r 4586}#)))
- (map (lambda (#{x 4817}#)
- (cons 'macro
- (#{eval-local-transformer 4456}#
- (#{expand 4450}#
- #{x 4817}#
- #{trans-r 4816}#
- #{w 4587}#
- #{mod 4589}#)
- #{mod 4589}#)))
- #{val 4677}#))
- #{r 4586}#)
- #{w 4587}#
- #{mod 4589}#))))
- #{tmp 4591}#)
+ (lambda (#{e 29395}#)
+ (let ((#{exp 29399}#
+ (#{strip 28284}# #{e 29395}# #{w 29388}#)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #{s 29389}#
+ #{exp 29399}#)))
+ #{tmp 29392}#)
(syntax-violation
- 'syntax-parameterize
+ 'quote
"bad syntax"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 4585}#) #{s 4588}# #f)
- (set-source-properties! #{e 4585}# #{s 4588}#))
- #{e 4585}#)
- #{w 4587}#
- #{mod 4589}#))))))
- (module-define!
- (current-module)
- 'quote
- (make-syntax-transformer
- 'quote
- 'core
- (lambda (#{e 5026}#
- #{r 5027}#
- #{w 5028}#
- #{s 5029}#
- #{mod 5030}#)
- (let ((#{tmp 5032}# ($sc-dispatch #{e 5026}# '(_ any))))
- (if #{tmp 5032}#
- (@apply
- (lambda (#{e 5035}#)
- (let ((#{exp 5039}#
- (#{strip 4463}# #{e 5035}# #{w 5028}#)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #{s 5029}#
- #{exp 5039}#)))
- #{tmp 5032}#)
- (syntax-violation
- 'quote
- "bad syntax"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 5026}#) #{s 5029}# #f)
- (set-source-properties! #{e 5026}# #{s 5029}#))
- #{e 5026}#)
- #{w 5028}#
- #{mod 5030}#)))))))
- (#{global-extend 4413}#
- 'core
- 'syntax
- (letrec*
- ((#{gen-syntax 5259}#
- (lambda (#{src 5361}#
- #{e 5362}#
- #{r 5363}#
- #{maps 5364}#
- #{ellipsis? 5365}#
- #{mod 5366}#)
- (if (if (symbol? #{e 5362}#)
- #t
- (if (if (vector? #{e 5362}#)
- (if (= (vector-length #{e 5362}#) 4)
- (eq? (vector-ref #{e 5362}# 0) 'syntax-object)
- #f)
+ (let ((#{x 29413}#
+ (begin
+ (if (if (pair? #{e 29386}#) #{s 29389}# #f)
+ (set-source-properties! #{e 29386}# #{s 29389}#))
+ #{e 29386}#)))
+ (if (if (null? (car #{w 29388}#))
+ (null? (cdr #{w 29388}#))
+ #f)
+ #{x 29413}#
+ (if (if (vector? #{x 29413}#)
+ (if (= (vector-length #{x 29413}#) 4)
+ (eq? (vector-ref #{x 29413}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 29445}# (vector-ref #{x 29413}# 1))
+ (#{wrap 29446}#
+ (let ((#{w2 29454}# (vector-ref #{x 29413}# 2)))
+ (let ((#{m1 29455}# (car #{w 29388}#))
+ (#{s1 29456}# (cdr #{w 29388}#)))
+ (if (null? #{m1 29455}#)
+ (if (null? #{s1 29456}#)
+ #{w2 29454}#
+ (cons (car #{w2 29454}#)
+ (let ((#{m2 29471}#
+ (cdr #{w2 29454}#)))
+ (if (null? #{m2 29471}#)
+ #{s1 29456}#
+ (append
+ #{s1 29456}#
+ #{m2 29471}#)))))
+ (cons (let ((#{m2 29479}#
+ (car #{w2 29454}#)))
+ (if (null? #{m2 29479}#)
+ #{m1 29455}#
+ (append
+ #{m1 29455}#
+ #{m2 29479}#)))
+ (let ((#{m2 29487}#
+ (cdr #{w2 29454}#)))
+ (if (null? #{m2 29487}#)
+ #{s1 29456}#
+ (append
+ #{s1 29456}#
+ #{m2 29487}#))))))))
+ (#{module 29447}# (vector-ref #{x 29413}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 29445}#
+ #{wrap 29446}#
+ #{module 29447}#))
+ (if (null? #{x 29413}#)
+ #{x 29413}#
+ (vector
+ 'syntax-object
+ #{x 29413}#
+ #{w 29388}#
+ #{mod 29390}#)))))))))))
+ (#{global-extend 28236}#
+ 'core
+ 'syntax
+ (letrec*
+ ((#{gen-syntax 29705}#
+ (lambda (#{src 30136}#
+ #{e 30137}#
+ #{r 30138}#
+ #{maps 30139}#
+ #{ellipsis? 30140}#
+ #{mod 30141}#)
+ (if (if (symbol? #{e 30137}#)
+ #t
+ (if (if (vector? #{e 30137}#)
+ (if (= (vector-length #{e 30137}#) 4)
+ (eq? (vector-ref #{e 30137}# 0) 'syntax-object)
#f)
- (symbol? (vector-ref #{e 5362}# 1))
- #f))
- (let ((#{label 5393}#
- (#{id-var-name 4434}# #{e 5362}# '(()))))
- (let ((#{b 5394}#
- (let ((#{t 5401}# (assq #{label 5393}# #{r 5363}#)))
- (if #{t 5401}#
- (cdr #{t 5401}#)
- (if (symbol? #{label 5393}#)
- (let ((#{t 5407}#
- (#{get-global-definition-hook 4378}#
- #{label 5393}#
- #{mod 5366}#)))
- (if #{t 5407}# #{t 5407}# '(global)))
- '(displaced-lexical))))))
- (if (eq? (car #{b 5394}#) 'syntax)
- (call-with-values
- (lambda ()
- (let ((#{var.lev 5416}# (cdr #{b 5394}#)))
- (#{gen-ref 5260}#
- #{src 5361}#
- (car #{var.lev 5416}#)
- (cdr #{var.lev 5416}#)
- #{maps 5364}#)))
- (lambda (#{var 5420}# #{maps 5421}#)
- (values (list 'ref #{var 5420}#) #{maps 5421}#)))
- (if (#{ellipsis? 5365}# #{e 5362}#)
- (syntax-violation
- 'syntax
- "misplaced ellipsis"
- #{src 5361}#)
- (values (list 'quote #{e 5362}#) #{maps 5364}#)))))
- (let ((#{tmp 5423}#
- ($sc-dispatch #{e 5362}# '(any any))))
- (if (if #{tmp 5423}#
- (@apply
- (lambda (#{dots 5427}# #{e 5428}#)
- (#{ellipsis? 5365}# #{dots 5427}#))
- #{tmp 5423}#)
#f)
- (@apply
- (lambda (#{dots 5429}# #{e 5430}#)
- (#{gen-syntax 5259}#
- #{src 5361}#
- #{e 5430}#
- #{r 5363}#
- #{maps 5364}#
- (lambda (#{x 5431}#) #f)
- #{mod 5366}#))
- #{tmp 5423}#)
- (let ((#{tmp 5432}#
- ($sc-dispatch #{e 5362}# '(any any . any))))
- (if (if #{tmp 5432}#
- (@apply
- (lambda (#{x 5436}# #{dots 5437}# #{y 5438}#)
- (#{ellipsis? 5365}# #{dots 5437}#))
- #{tmp 5432}#)
- #f)
- (@apply
- (lambda (#{x 5439}# #{dots 5440}# #{y 5441}#)
- (letrec*
- ((#{f 5442}#
- (lambda (#{y 5450}# #{k 5451}#)
- (let ((#{tmp 5453}#
- ($sc-dispatch
- #{y 5450}#
- '(any . any))))
- (if (if #{tmp 5453}#
- (@apply
- (lambda (#{dots 5457}#
- #{y 5458}#)
- (#{ellipsis? 5365}#
- #{dots 5457}#))
- #{tmp 5453}#)
- #f)
- (@apply
- (lambda (#{dots 5459}# #{y 5460}#)
- (#{f 5442}#
- #{y 5460}#
- (lambda (#{maps 5461}#)
- (call-with-values
- (lambda ()
- (#{k 5451}#
- (cons '()
- #{maps 5461}#)))
- (lambda (#{x 5462}#
- #{maps 5463}#)
- (if (null? (car #{maps 5463}#))
- (syntax-violation
- 'syntax
- "extra ellipsis"
- #{src 5361}#)
- (values
- (let ((#{map-env 5467}#
- (car #{maps 5463}#)))
- (list 'apply
- '(primitive
- append)
- (#{gen-map 5262}#
- #{x 5462}#
- #{map-env 5467}#)))
- (cdr #{maps 5463}#))))))))
- #{tmp 5453}#)
- (call-with-values
- (lambda ()
- (#{gen-syntax 5259}#
- #{src 5361}#
- #{y 5450}#
- #{r 5363}#
- #{maps 5364}#
- #{ellipsis? 5365}#
- #{mod 5366}#))
- (lambda (#{y 5470}# #{maps 5471}#)
- (call-with-values
- (lambda ()
- (#{k 5451}# #{maps 5471}#))
- (lambda (#{x 5472}#
- #{maps 5473}#)
- (values
- (if (equal? #{y 5470}# ''())
- #{x 5472}#
- (list 'append
- #{x 5472}#
- #{y 5470}#))
- #{maps 5473}#))))))))))
- (#{f 5442}#
- #{y 5441}#
- (lambda (#{maps 5445}#)
- (call-with-values
- (lambda ()
- (#{gen-syntax 5259}#
- #{src 5361}#
- #{x 5439}#
- #{r 5363}#
- (cons '() #{maps 5445}#)
- #{ellipsis? 5365}#
- #{mod 5366}#))
- (lambda (#{x 5446}# #{maps 5447}#)
- (if (null? (car #{maps 5447}#))
- (syntax-violation
- 'syntax
- "extra ellipsis"
- #{src 5361}#)
- (values
- (#{gen-map 5262}#
- #{x 5446}#
- (car #{maps 5447}#))
- (cdr #{maps 5447}#)))))))))
- #{tmp 5432}#)
- (let ((#{tmp 5489}#
- ($sc-dispatch #{e 5362}# '(any . any))))
- (if #{tmp 5489}#
- (@apply
- (lambda (#{x 5493}# #{y 5494}#)
+ (symbol? (vector-ref #{e 30137}# 1))
+ #f))
+ (call-with-values
+ (lambda ()
+ (#{resolve-identifier 28258}#
+ #{e 30137}#
+ '(())
+ #{r 30138}#
+ #{mod 30141}#
+ #f))
+ (lambda (#{type 30170}# #{value 30171}# #{mod 30172}#)
+ (if (eqv? #{type 30170}# 'syntax)
+ (call-with-values
+ (lambda ()
+ (#{gen-ref 29706}#
+ #{src 30136}#
+ (car #{value 30171}#)
+ (cdr #{value 30171}#)
+ #{maps 30139}#))
+ (lambda (#{var 30178}# #{maps 30179}#)
+ (values (list 'ref #{var 30178}#) #{maps 30179}#)))
+ (if (#{ellipsis? 30140}# #{e 30137}#)
+ (syntax-violation
+ 'syntax
+ "misplaced ellipsis"
+ #{src 30136}#)
+ (values (list 'quote #{e 30137}#) #{maps 30139}#)))))
+ (let ((#{tmp 30181}#
+ ($sc-dispatch #{e 30137}# '(any any))))
+ (if (if #{tmp 30181}#
+ (@apply
+ (lambda (#{dots 30185}# #{e 30186}#)
+ (#{ellipsis? 30140}# #{dots 30185}#))
+ #{tmp 30181}#)
+ #f)
+ (@apply
+ (lambda (#{dots 30187}# #{e 30188}#)
+ (#{gen-syntax 29705}#
+ #{src 30136}#
+ #{e 30188}#
+ #{r 30138}#
+ #{maps 30139}#
+ (lambda (#{x 30189}#) #f)
+ #{mod 30141}#))
+ #{tmp 30181}#)
+ (let ((#{tmp 30190}#
+ ($sc-dispatch #{e 30137}# '(any any . any))))
+ (if (if #{tmp 30190}#
+ (@apply
+ (lambda (#{x 30194}# #{dots 30195}# #{y 30196}#)
+ (#{ellipsis? 30140}# #{dots 30195}#))
+ #{tmp 30190}#)
+ #f)
+ (@apply
+ (lambda (#{x 30197}# #{dots 30198}# #{y 30199}#)
+ (letrec*
+ ((#{f 30200}#
+ (lambda (#{y 30208}# #{k 30209}#)
+ (let ((#{tmp 30211}#
+ ($sc-dispatch
+ #{y 30208}#
+ '(any . any))))
+ (if (if #{tmp 30211}#
+ (@apply
+ (lambda (#{dots 30215}#
+ #{y 30216}#)
+ (#{ellipsis? 30140}#
+ #{dots 30215}#))
+ #{tmp 30211}#)
+ #f)
+ (@apply
+ (lambda (#{dots 30217}# #{y 30218}#)
+ (#{f 30200}#
+ #{y 30218}#
+ (lambda (#{maps 30219}#)
+ (call-with-values
+ (lambda ()
+ (#{k 30209}#
+ (cons '() #{maps 30219}#)))
+ (lambda (#{x 30220}#
+ #{maps 30221}#)
+ (if (null? (car #{maps 30221}#))
+ (syntax-violation
+ 'syntax
+ "extra ellipsis"
+ #{src 30136}#)
+ (values
+ (let ((#{map-env 30225}#
+ (car #{maps 30221}#)))
+ (list 'apply
+ '(primitive
+ append)
+ (#{gen-map 29708}#
+ #{x 30220}#
+ #{map-env 30225}#)))
+ (cdr #{maps 30221}#))))))))
+ #{tmp 30211}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax 29705}#
+ #{src 30136}#
+ #{y 30208}#
+ #{r 30138}#
+ #{maps 30139}#
+ #{ellipsis? 30140}#
+ #{mod 30141}#))
+ (lambda (#{y 30228}# #{maps 30229}#)
+ (call-with-values
+ (lambda ()
+ (#{k 30209}# #{maps 30229}#))
+ (lambda (#{x 30230}#
+ #{maps 30231}#)
+ (values
+ (if (equal? #{y 30228}# ''())
+ #{x 30230}#
+ (list 'append
+ #{x 30230}#
+ #{y 30228}#))
+ #{maps 30231}#))))))))))
+ (#{f 30200}#
+ #{y 30199}#
+ (lambda (#{maps 30203}#)
(call-with-values
(lambda ()
- (#{gen-syntax 5259}#
- #{src 5361}#
- #{x 5493}#
- #{r 5363}#
- #{maps 5364}#
- #{ellipsis? 5365}#
- #{mod 5366}#))
- (lambda (#{x 5495}# #{maps 5496}#)
- (call-with-values
- (lambda ()
- (#{gen-syntax 5259}#
- #{src 5361}#
- #{y 5494}#
- #{r 5363}#
- #{maps 5496}#
- #{ellipsis? 5365}#
- #{mod 5366}#))
- (lambda (#{y 5497}# #{maps 5498}#)
- (values
- (let ((#{atom-key 5503}#
- (car #{y 5497}#)))
- (if (eqv? #{atom-key 5503}#
- 'quote)
- (if (eq? (car #{x 5495}#)
- 'quote)
- (list 'quote
- (cons (car (cdr #{x 5495}#))
- (car (cdr #{y 5497}#))))
- (if (eq? (car (cdr #{y 5497}#))
- '())
- (list 'list #{x 5495}#)
- (list 'cons
- #{x 5495}#
- #{y 5497}#)))
- (if (eqv? #{atom-key 5503}#
- 'list)
- (cons 'list
- (cons #{x 5495}#
- (cdr #{y 5497}#)))
- (list 'cons
- #{x 5495}#
- #{y 5497}#))))
- #{maps 5498}#))))))
- #{tmp 5489}#)
- (let ((#{tmp 5532}#
- ($sc-dispatch
- #{e 5362}#
- '#(vector (any . each-any)))))
- (if #{tmp 5532}#
- (@apply
- (lambda (#{e1 5536}# #{e2 5537}#)
- (call-with-values
- (lambda ()
- (#{gen-syntax 5259}#
- #{src 5361}#
- (cons #{e1 5536}# #{e2 5537}#)
- #{r 5363}#
- #{maps 5364}#
- #{ellipsis? 5365}#
- #{mod 5366}#))
- (lambda (#{e 5538}# #{maps 5539}#)
- (values
- (if (eq? (car #{e 5538}#) 'list)
- (cons 'vector (cdr #{e 5538}#))
- (if (eq? (car #{e 5538}#) 'quote)
+ (#{gen-syntax 29705}#
+ #{src 30136}#
+ #{x 30197}#
+ #{r 30138}#
+ (cons '() #{maps 30203}#)
+ #{ellipsis? 30140}#
+ #{mod 30141}#))
+ (lambda (#{x 30204}# #{maps 30205}#)
+ (if (null? (car #{maps 30205}#))
+ (syntax-violation
+ 'syntax
+ "extra ellipsis"
+ #{src 30136}#)
+ (values
+ (#{gen-map 29708}#
+ #{x 30204}#
+ (car #{maps 30205}#))
+ (cdr #{maps 30205}#)))))))))
+ #{tmp 30190}#)
+ (let ((#{tmp 30247}#
+ ($sc-dispatch #{e 30137}# '(any . any))))
+ (if #{tmp 30247}#
+ (@apply
+ (lambda (#{x 30251}# #{y 30252}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax 29705}#
+ #{src 30136}#
+ #{x 30251}#
+ #{r 30138}#
+ #{maps 30139}#
+ #{ellipsis? 30140}#
+ #{mod 30141}#))
+ (lambda (#{x 30253}# #{maps 30254}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax 29705}#
+ #{src 30136}#
+ #{y 30252}#
+ #{r 30138}#
+ #{maps 30254}#
+ #{ellipsis? 30140}#
+ #{mod 30141}#))
+ (lambda (#{y 30255}# #{maps 30256}#)
+ (values
+ (let ((#{atom-key 30261}#
+ (car #{y 30255}#)))
+ (if (eqv? #{atom-key 30261}# 'quote)
+ (if (eq? (car #{x 30253}#) 'quote)
(list 'quote
- (list->vector
- (car (cdr #{e 5538}#))))
- (list 'list->vector
- #{e 5538}#)))
- #{maps 5539}#))))
- #{tmp 5532}#)
- (values
- (list 'quote #{e 5362}#)
- #{maps 5364}#))))))))))))
- (#{gen-ref 5260}#
- (lambda (#{src 5566}#
- #{var 5567}#
- #{level 5568}#
- #{maps 5569}#)
- (if (= #{level 5568}# 0)
- (values #{var 5567}# #{maps 5569}#)
- (if (null? #{maps 5569}#)
- (syntax-violation
- 'syntax
- "missing ellipsis"
- #{src 5566}#)
- (call-with-values
- (lambda ()
- (#{gen-ref 5260}#
- #{src 5566}#
- #{var 5567}#
- (#{1-}# #{level 5568}#)
- (cdr #{maps 5569}#)))
- (lambda (#{outer-var 5570}# #{outer-maps 5571}#)
- (let ((#{b 5572}#
- (assq #{outer-var 5570}# (car #{maps 5569}#))))
- (if #{b 5572}#
- (values (cdr #{b 5572}#) #{maps 5569}#)
- (let ((#{inner-var 5574}#
- (gensym
- (string-append
- (symbol->string 'tmp)
- " "))))
- (values
- #{inner-var 5574}#
- (cons (cons (cons #{outer-var 5570}#
- #{inner-var 5574}#)
- (car #{maps 5569}#))
- #{outer-maps 5571}#)))))))))))
- (#{gen-map 5262}#
- (lambda (#{e 5588}# #{map-env 5589}#)
- (let ((#{formals 5590}# (map cdr #{map-env 5589}#))
- (#{actuals 5591}#
- (map (lambda (#{x 5593}#)
- (list 'ref (car #{x 5593}#)))
- #{map-env 5589}#)))
- (if (eq? (car #{e 5588}#) 'ref)
- (car #{actuals 5591}#)
- (if (and-map
- (lambda (#{x 5594}#)
- (if (eq? (car #{x 5594}#) 'ref)
- (memq (car (cdr #{x 5594}#)) #{formals 5590}#)
- #f))
- (cdr #{e 5588}#))
- (cons 'map
- (cons (list 'primitive (car #{e 5588}#))
- (map (let ((#{r 5596}#
- (map cons
- #{formals 5590}#
- #{actuals 5591}#)))
- (lambda (#{x 5597}#)
- (cdr (assq (car (cdr #{x 5597}#))
- #{r 5596}#))))
- (cdr #{e 5588}#))))
- (cons 'map
- (cons (list 'lambda #{formals 5590}# #{e 5588}#)
- #{actuals 5591}#)))))))
- (#{regen 5266}#
- (lambda (#{x 5599}#)
- (let ((#{atom-key 5600}# (car #{x 5599}#)))
- (if (eqv? #{atom-key 5600}# 'ref)
- (let ((#{name 5610}# (car (cdr #{x 5599}#)))
- (#{var 5611}# (car (cdr #{x 5599}#))))
+ (cons (car (cdr #{x 30253}#))
+ (car (cdr #{y 30255}#))))
+ (if (eq? (car (cdr #{y 30255}#))
+ '())
+ (list 'list #{x 30253}#)
+ (list 'cons
+ #{x 30253}#
+ #{y 30255}#)))
+ (if (eqv? #{atom-key 30261}#
+ 'list)
+ (cons 'list
+ (cons #{x 30253}#
+ (cdr #{y 30255}#)))
+ (list 'cons
+ #{x 30253}#
+ #{y 30255}#))))
+ #{maps 30256}#))))))
+ #{tmp 30247}#)
+ (let ((#{tmp 30290}#
+ ($sc-dispatch
+ #{e 30137}#
+ '#(vector (any . each-any)))))
+ (if #{tmp 30290}#
+ (@apply
+ (lambda (#{e1 30294}# #{e2 30295}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-syntax 29705}#
+ #{src 30136}#
+ (cons #{e1 30294}# #{e2 30295}#)
+ #{r 30138}#
+ #{maps 30139}#
+ #{ellipsis? 30140}#
+ #{mod 30141}#))
+ (lambda (#{e 30296}# #{maps 30297}#)
+ (values
+ (if (eq? (car #{e 30296}#) 'list)
+ (cons 'vector (cdr #{e 30296}#))
+ (if (eq? (car #{e 30296}#) 'quote)
+ (list 'quote
+ (list->vector
+ (car (cdr #{e 30296}#))))
+ (list 'list->vector #{e 30296}#)))
+ #{maps 30297}#))))
+ #{tmp 30290}#)
+ (values
+ (list 'quote #{e 30137}#)
+ #{maps 30139}#))))))))))))
+ (#{gen-ref 29706}#
+ (lambda (#{src 30324}#
+ #{var 30325}#
+ #{level 30326}#
+ #{maps 30327}#)
+ (if (= #{level 30326}# 0)
+ (values #{var 30325}# #{maps 30327}#)
+ (if (null? #{maps 30327}#)
+ (syntax-violation
+ 'syntax
+ "missing ellipsis"
+ #{src 30324}#)
+ (call-with-values
+ (lambda ()
+ (#{gen-ref 29706}#
+ #{src 30324}#
+ #{var 30325}#
+ (#{1-}# #{level 30326}#)
+ (cdr #{maps 30327}#)))
+ (lambda (#{outer-var 30328}# #{outer-maps 30329}#)
+ (let ((#{b 30330}#
+ (assq #{outer-var 30328}# (car #{maps 30327}#))))
+ (if #{b 30330}#
+ (values (cdr #{b 30330}#) #{maps 30327}#)
+ (let ((#{inner-var 30332}#
+ (gensym
+ (string-append (symbol->string 'tmp) " "))))
+ (values
+ #{inner-var 30332}#
+ (cons (cons (cons #{outer-var 30328}#
+ #{inner-var 30332}#)
+ (car #{maps 30327}#))
+ #{outer-maps 30329}#)))))))))))
+ (#{gen-map 29708}#
+ (lambda (#{e 30346}# #{map-env 30347}#)
+ (let ((#{formals 30348}# (map cdr #{map-env 30347}#))
+ (#{actuals 30349}#
+ (map (lambda (#{x 30351}#)
+ (list 'ref (car #{x 30351}#)))
+ #{map-env 30347}#)))
+ (if (eq? (car #{e 30346}#) 'ref)
+ (car #{actuals 30349}#)
+ (if (and-map
+ (lambda (#{x 30352}#)
+ (if (eq? (car #{x 30352}#) 'ref)
+ (memq (car (cdr #{x 30352}#)) #{formals 30348}#)
+ #f))
+ (cdr #{e 30346}#))
+ (cons 'map
+ (cons (list 'primitive (car #{e 30346}#))
+ (map (let ((#{r 30354}#
+ (map cons
+ #{formals 30348}#
+ #{actuals 30349}#)))
+ (lambda (#{x 30355}#)
+ (cdr (assq (car (cdr #{x 30355}#))
+ #{r 30354}#))))
+ (cdr #{e 30346}#))))
+ (cons 'map
+ (cons (list 'lambda #{formals 30348}# #{e 30346}#)
+ #{actuals 30349}#)))))))
+ (#{regen 29712}#
+ (lambda (#{x 30357}#)
+ (let ((#{atom-key 30358}# (car #{x 30357}#)))
+ (if (eqv? #{atom-key 30358}# 'ref)
+ (let ((#{name 30368}# (car (cdr #{x 30357}#)))
+ (#{var 30369}# (car (cdr #{x 30357}#))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 3)
+ #f
+ #{name 30368}#
+ #{var 30369}#))
+ (if (eqv? #{atom-key 30358}# 'primitive)
+ (let ((#{name 30380}# (car (cdr #{x 30357}#))))
(make-struct/no-tail
- (vector-ref %expanded-vtables 3)
+ (vector-ref %expanded-vtables 2)
#f
- #{name 5610}#
- #{var 5611}#))
- (if (eqv? #{atom-key 5600}# 'primitive)
- (let ((#{name 5623}# (car (cdr #{x 5599}#))))
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- #{name 5623}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- #{name 5623}#
- #f)))
- (if (eqv? #{atom-key 5600}# 'quote)
- (let ((#{exp 5641}# (car (cdr #{x 5599}#))))
+ #{name 30380}#))
+ (if (eqv? #{atom-key 30358}# 'quote)
+ (let ((#{exp 30391}# (car (cdr #{x 30357}#))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #f
+ #{exp 30391}#))
+ (if (eqv? #{atom-key 30358}# 'lambda)
+ (if (list? (car (cdr #{x 30357}#)))
+ (let ((#{req 30402}# (car (cdr #{x 30357}#)))
+ (#{vars 30404}# (car (cdr #{x 30357}#)))
+ (#{exp 30406}#
+ (#{regen 29712}#
+ (car (cdr (cdr #{x 30357}#))))))
+ (let ((#{body 30411}#
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 15)
+ #f
+ #{req 30402}#
+ #f
+ #f
+ #f
+ '()
+ #{vars 30404}#
+ #{exp 30406}#
+ #f)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 14)
+ #f
+ '()
+ #{body 30411}#)))
+ (error "how did we get here" #{x 30357}#))
+ (let ((#{name 30427}# (car #{x 30357}#))
+ (#{args 30428}#
+ (map #{regen 29712}# (cdr #{x 30357}#))))
(make-struct/no-tail
- (vector-ref %expanded-vtables 1)
+ (vector-ref %expanded-vtables 12)
#f
- #{exp 5641}#))
- (if (eqv? #{atom-key 5600}# 'lambda)
- (if (list? (car (cdr #{x 5599}#)))
- (let ((#{req 5652}# (car (cdr #{x 5599}#)))
- (#{vars 5654}# (car (cdr #{x 5599}#)))
- (#{exp 5656}#
- (#{regen 5266}#
- (car (cdr (cdr #{x 5599}#))))))
- (let ((#{body 5661}#
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #f
- #{req 5652}#
- #f
- #f
- #f
- '()
- #{vars 5654}#
- #{exp 5656}#
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- #f
- '()
- #{body 5661}#)))
- (error "how did we get here" #{x 5599}#))
- (let ((#{fun-exp 5677}#
- (let ((#{name 5686}# (car #{x 5599}#)))
- (if (equal?
- (module-name (current-module))
- '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- #{name 5686}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- #{name 5686}#
- #f))))
- (#{arg-exps 5678}#
- (map #{regen 5266}# (cdr #{x 5599}#))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- #{fun-exp 5677}#
- #{arg-exps 5678}#))))))))))
- (lambda (#{e 5267}#
- #{r 5268}#
- #{w 5269}#
- #{s 5270}#
- #{mod 5271}#)
- (let ((#{e 5272}#
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 5267}#) #{s 5270}# #f)
- (set-source-properties! #{e 5267}# #{s 5270}#))
- #{e 5267}#)
- #{w 5269}#
- #{mod 5271}#)))
- (let ((#{tmp 5274}# ($sc-dispatch #{e 5272}# '(_ any))))
- (if #{tmp 5274}#
+ #{name 30427}#
+ #{args 30428}#))))))))))
+ (lambda (#{e 29713}#
+ #{r 29714}#
+ #{w 29715}#
+ #{s 29716}#
+ #{mod 29717}#)
+ (let ((#{e 29718}#
+ (let ((#{x 30047}#
+ (begin
+ (if (if (pair? #{e 29713}#) #{s 29716}# #f)
+ (set-source-properties! #{e 29713}# #{s 29716}#))
+ #{e 29713}#)))
+ (if (if (null? (car #{w 29715}#))
+ (null? (cdr #{w 29715}#))
+ #f)
+ #{x 30047}#
+ (if (if (vector? #{x 30047}#)
+ (if (= (vector-length #{x 30047}#) 4)
+ (eq? (vector-ref #{x 30047}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 30079}# (vector-ref #{x 30047}# 1))
+ (#{wrap 30080}#
+ (let ((#{w2 30088}#
+ (vector-ref #{x 30047}# 2)))
+ (let ((#{m1 30089}# (car #{w 29715}#))
+ (#{s1 30090}# (cdr #{w 29715}#)))
+ (if (null? #{m1 30089}#)
+ (if (null? #{s1 30090}#)
+ #{w2 30088}#
+ (cons (car #{w2 30088}#)
+ (let ((#{m2 30105}#
+ (cdr #{w2 30088}#)))
+ (if (null? #{m2 30105}#)
+ #{s1 30090}#
+ (append
+ #{s1 30090}#
+ #{m2 30105}#)))))
+ (cons (let ((#{m2 30113}#
+ (car #{w2 30088}#)))
+ (if (null? #{m2 30113}#)
+ #{m1 30089}#
+ (append
+ #{m1 30089}#
+ #{m2 30113}#)))
+ (let ((#{m2 30121}#
+ (cdr #{w2 30088}#)))
+ (if (null? #{m2 30121}#)
+ #{s1 30090}#
+ (append
+ #{s1 30090}#
+ #{m2 30121}#))))))))
+ (#{module 30081}# (vector-ref #{x 30047}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 30079}#
+ #{wrap 30080}#
+ #{module 30081}#))
+ (if (null? #{x 30047}#)
+ #{x 30047}#
+ (vector
+ 'syntax-object
+ #{x 30047}#
+ #{w 29715}#
+ #{mod 29717}#)))))))
+ (let ((#{tmp 29719}# #{e 29718}#))
+ (let ((#{tmp 29720}#
+ ($sc-dispatch #{tmp 29719}# '(_ any))))
+ (if #{tmp 29720}#
(@apply
- (lambda (#{x 5299}#)
+ (lambda (#{x 29768}#)
(call-with-values
(lambda ()
- (#{gen-syntax 5259}#
- #{e 5272}#
- #{x 5299}#
- #{r 5268}#
+ (#{gen-syntax 29705}#
+ #{e 29718}#
+ #{x 29768}#
+ #{r 29714}#
'()
- #{ellipsis? 4458}#
- #{mod 5271}#))
- (lambda (#{e 5353}# #{maps 5354}#)
- (#{regen 5266}# #{e 5353}#))))
- #{tmp 5274}#)
+ #{ellipsis? 28279}#
+ #{mod 29717}#))
+ (lambda (#{e 29845}# #{maps 29846}#)
+ (#{regen 29712}# #{e 29845}#))))
+ #{tmp 29720}#)
(syntax-violation
'syntax
"bad `syntax' form"
- #{e 5272}#)))))))
- (#{global-extend 4413}#
- 'core
- 'lambda
- (lambda (#{e 5879}#
- #{r 5880}#
- #{w 5881}#
- #{s 5882}#
- #{mod 5883}#)
- (let ((#{tmp 5885}#
- ($sc-dispatch #{e 5879}# '(_ any any . each-any))))
- (if #{tmp 5885}#
- (@apply
- (lambda (#{args 5889}# #{e1 5890}# #{e2 5891}#)
- (call-with-values
- (lambda ()
- (#{lambda-formals 4459}# #{args 5889}#))
- (lambda (#{req 5894}#
- #{opt 5895}#
- #{rest 5896}#
- #{kw 5897}#)
- (letrec*
- ((#{lp 5898}#
- (lambda (#{body 5901}# #{meta 5902}#)
- (let ((#{tmp 5904}#
- ($sc-dispatch
- #{body 5901}#
- '(any any . each-any))))
- (if (if #{tmp 5904}#
- (@apply
- (lambda (#{docstring 5908}#
- #{e1 5909}#
- #{e2 5910}#)
- (string?
- (syntax->datum #{docstring 5908}#)))
- #{tmp 5904}#)
- #f)
- (@apply
- (lambda (#{docstring 5911}#
- #{e1 5912}#
- #{e2 5913}#)
- (#{lp 5898}#
- (cons #{e1 5912}# #{e2 5913}#)
- (append
- #{meta 5902}#
- (list (cons 'documentation
- (syntax->datum
- #{docstring 5911}#))))))
- #{tmp 5904}#)
- (let ((#{tmp 5914}#
- ($sc-dispatch
- #{body 5901}#
- '(#(vector #(each (any . any)))
- any
- .
- each-any))))
- (if #{tmp 5914}#
- (@apply
- (lambda (#{k 5918}#
- #{v 5919}#
- #{e1 5920}#
- #{e2 5921}#)
- (#{lp 5898}#
- (cons #{e1 5920}# #{e2 5921}#)
- (append
- #{meta 5902}#
- (syntax->datum
- (map cons
- #{k 5918}#
- #{v 5919}#)))))
- #{tmp 5914}#)
- (#{expand-simple-lambda 4460}#
- #{e 5879}#
- #{r 5880}#
- #{w 5881}#
- #{s 5882}#
- #{mod 5883}#
- #{req 5894}#
- #{rest 5896}#
- #{meta 5902}#
- #{body 5901}#))))))))
- (#{lp 5898}# (cons #{e1 5890}# #{e2 5891}#) '())))))
- #{tmp 5885}#)
- (syntax-violation
- 'lambda
- "bad lambda"
- #{e 5879}#)))))
- (#{global-extend 4413}#
- 'core
- 'lambda*
- (lambda (#{e 6212}#
- #{r 6213}#
- #{w 6214}#
- #{s 6215}#
- #{mod 6216}#)
- (let ((#{tmp 6218}#
- ($sc-dispatch #{e 6212}# '(_ any any . each-any))))
- (if #{tmp 6218}#
- (@apply
- (lambda (#{args 6222}# #{e1 6223}# #{e2 6224}#)
- (call-with-values
- (lambda ()
- (#{expand-lambda-case 4462}#
- #{e 6212}#
- #{r 6213}#
- #{w 6214}#
- #{s 6215}#
- #{mod 6216}#
- #{lambda*-formals 4461}#
- (list (cons #{args 6222}#
- (cons #{e1 6223}# #{e2 6224}#)))))
- (lambda (#{meta 6227}# #{lcase 6228}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- #{s 6215}#
- #{meta 6227}#
- #{lcase 6228}#))))
- #{tmp 6218}#)
- (syntax-violation
- 'lambda
- "bad lambda*"
- #{e 6212}#)))))
- (#{global-extend 4413}#
- 'core
- 'case-lambda
- (lambda (#{e 6398}#
- #{r 6399}#
- #{w 6400}#
- #{s 6401}#
- #{mod 6402}#)
- (let ((#{tmp 6404}#
- ($sc-dispatch
- #{e 6398}#
- '(_ (any any . each-any)
- .
- #(each (any any . each-any))))))
- (if #{tmp 6404}#
- (@apply
- (lambda (#{args 6408}#
- #{e1 6409}#
- #{e2 6410}#
- #{args* 6411}#
- #{e1* 6412}#
- #{e2* 6413}#)
- (call-with-values
- (lambda ()
- (#{expand-lambda-case 4462}#
- #{e 6398}#
- #{r 6399}#
- #{w 6400}#
- #{s 6401}#
- #{mod 6402}#
- #{lambda-formals 4459}#
- (cons (cons #{args 6408}#
- (cons #{e1 6409}# #{e2 6410}#))
- (map (lambda (#{tmp 3332 6416}#
- #{tmp 3331 6417}#
- #{tmp 3330 6418}#)
- (cons #{tmp 3330 6418}#
- (cons #{tmp 3331 6417}#
- #{tmp 3332 6416}#)))
- #{e2* 6413}#
- #{e1* 6412}#
- #{args* 6411}#))))
- (lambda (#{meta 6419}# #{lcase 6420}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- #{s 6401}#
- #{meta 6419}#
- #{lcase 6420}#))))
- #{tmp 6404}#)
- (syntax-violation
- 'case-lambda
- "bad case-lambda"
- #{e 6398}#)))))
- (#{global-extend 4413}#
- 'core
- 'case-lambda*
- (lambda (#{e 6582}#
- #{r 6583}#
- #{w 6584}#
- #{s 6585}#
- #{mod 6586}#)
- (let ((#{tmp 6588}#
- ($sc-dispatch
- #{e 6582}#
- '(_ (any any . each-any)
- .
- #(each (any any . each-any))))))
- (if #{tmp 6588}#
- (@apply
- (lambda (#{args 6592}#
- #{e1 6593}#
- #{e2 6594}#
- #{args* 6595}#
- #{e1* 6596}#
- #{e2* 6597}#)
- (call-with-values
- (lambda ()
- (#{expand-lambda-case 4462}#
- #{e 6582}#
- #{r 6583}#
- #{w 6584}#
- #{s 6585}#
- #{mod 6586}#
- #{lambda*-formals 4461}#
- (cons (cons #{args 6592}#
- (cons #{e1 6593}# #{e2 6594}#))
- (map (lambda (#{tmp 3367 6600}#
- #{tmp 3366 6601}#
- #{tmp 3365 6602}#)
- (cons #{tmp 3365 6602}#
- (cons #{tmp 3366 6601}#
- #{tmp 3367 6600}#)))
- #{e2* 6597}#
- #{e1* 6596}#
- #{args* 6595}#))))
- (lambda (#{meta 6603}# #{lcase 6604}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- #{s 6585}#
- #{meta 6603}#
- #{lcase 6604}#))))
- #{tmp 6588}#)
- (syntax-violation
- 'case-lambda
- "bad case-lambda*"
- #{e 6582}#)))))
- (#{global-extend 4413}#
- 'core
- 'let
- (letrec*
- ((#{expand-let 6795}#
- (lambda (#{e 6944}#
- #{r 6945}#
- #{w 6946}#
- #{s 6947}#
- #{mod 6948}#
- #{constructor 6949}#
- #{ids 6950}#
- #{vals 6951}#
- #{exps 6952}#)
- (if (not (#{valid-bound-ids? 4440}# #{ids 6950}#))
- (syntax-violation
- 'let
- "duplicate bound variable"
- #{e 6944}#)
- (let ((#{labels 7030}#
- (#{gen-labels 4418}# #{ids 6950}#))
- (#{new-vars 7031}#
- (map #{gen-var 4464}# #{ids 6950}#)))
- (let ((#{nw 7032}#
- (#{make-binding-wrap 4429}#
- #{ids 6950}#
- #{labels 7030}#
- #{w 6946}#))
- (#{nr 7033}#
- (#{extend-var-env 4410}#
- #{labels 7030}#
- #{new-vars 7031}#
- #{r 6945}#)))
- (#{constructor 6949}#
- #{s 6947}#
- (map syntax->datum #{ids 6950}#)
- #{new-vars 7031}#
- (map (lambda (#{x 7050}#)
- (#{expand 4450}#
- #{x 7050}#
- #{r 6945}#
- #{w 6946}#
- #{mod 6948}#))
- #{vals 6951}#)
- (#{expand-body 4454}#
- #{exps 6952}#
- (#{source-wrap 4444}#
- #{e 6944}#
- #{nw 7032}#
- #{s 6947}#
- #{mod 6948}#)
- #{nr 7033}#
- #{nw 7032}#
- #{mod 6948}#))))))))
- (lambda (#{e 6796}#
- #{r 6797}#
- #{w 6798}#
- #{s 6799}#
- #{mod 6800}#)
- (let ((#{tmp 6802}#
- ($sc-dispatch
- #{e 6796}#
- '(_ #(each (any any)) any . each-any))))
- (if (if #{tmp 6802}#
- (@apply
- (lambda (#{id 6806}#
- #{val 6807}#
- #{e1 6808}#
- #{e2 6809}#)
- (and-map #{id? 4415}# #{id 6806}#))
- #{tmp 6802}#)
- #f)
- (@apply
- (lambda (#{id 6825}#
- #{val 6826}#
- #{e1 6827}#
- #{e2 6828}#)
- (#{expand-let 6795}#
- #{e 6796}#
- #{r 6797}#
- #{w 6798}#
- #{s 6799}#
- #{mod 6800}#
- #{build-let 4397}#
- #{id 6825}#
- #{val 6826}#
- (cons #{e1 6827}# #{e2 6828}#)))
- #{tmp 6802}#)
- (let ((#{tmp 6858}#
- ($sc-dispatch
- #{e 6796}#
- '(_ any #(each (any any)) any . each-any))))
- (if (if #{tmp 6858}#
- (@apply
- (lambda (#{f 6862}#
- #{id 6863}#
- #{val 6864}#
- #{e1 6865}#
- #{e2 6866}#)
- (if (if (symbol? #{f 6862}#)
- #t
- (if (if (vector? #{f 6862}#)
- (if (= (vector-length #{f 6862}#) 4)
- (eq? (vector-ref #{f 6862}# 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref #{f 6862}# 1))
- #f))
- (and-map #{id? 4415}# #{id 6863}#)
- #f))
- #{tmp 6858}#)
- #f)
- (@apply
- (lambda (#{f 6908}#
- #{id 6909}#
- #{val 6910}#
- #{e1 6911}#
- #{e2 6912}#)
- (#{expand-let 6795}#
- #{e 6796}#
- #{r 6797}#
- #{w 6798}#
- #{s 6799}#
- #{mod 6800}#
- #{build-named-let 4398}#
- (cons #{f 6908}# #{id 6909}#)
- #{val 6910}#
- (cons #{e1 6911}# #{e2 6912}#)))
- #{tmp 6858}#)
- (syntax-violation
- 'let
- "bad let"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 6796}#) #{s 6799}# #f)
- (set-source-properties! #{e 6796}# #{s 6799}#))
- #{e 6796}#)
- #{w 6798}#
- #{mod 6800}#)))))))))
- (#{global-extend 4413}#
- 'core
- 'letrec
- (lambda (#{e 7492}#
- #{r 7493}#
- #{w 7494}#
- #{s 7495}#
- #{mod 7496}#)
- (let ((#{tmp 7498}#
- ($sc-dispatch
- #{e 7492}#
- '(_ #(each (any any)) any . each-any))))
- (if (if #{tmp 7498}#
- (@apply
- (lambda (#{id 7502}#
- #{val 7503}#
- #{e1 7504}#
- #{e2 7505}#)
- (and-map #{id? 4415}# #{id 7502}#))
- #{tmp 7498}#)
- #f)
- (@apply
- (lambda (#{id 7521}#
- #{val 7522}#
- #{e1 7523}#
- #{e2 7524}#)
- (if (not (#{valid-bound-ids? 4440}# #{id 7521}#))
- (syntax-violation
- 'letrec
- "duplicate bound variable"
- #{e 7492}#)
- (let ((#{labels 7614}#
- (#{gen-labels 4418}# #{id 7521}#))
- (#{new-vars 7615}#
- (map #{gen-var 4464}# #{id 7521}#)))
- (let ((#{w 7616}#
- (#{make-binding-wrap 4429}#
- #{id 7521}#
- #{labels 7614}#
- #{w 7494}#))
- (#{r 7617}#
- (#{extend-var-env 4410}#
- #{labels 7614}#
- #{new-vars 7615}#
- #{r 7493}#)))
- (#{build-letrec 4399}#
- #{s 7495}#
- #f
- (map syntax->datum #{id 7521}#)
- #{new-vars 7615}#
- (map (lambda (#{x 7704}#)
- (#{expand 4450}#
- #{x 7704}#
- #{r 7617}#
- #{w 7616}#
- #{mod 7496}#))
- #{val 7522}#)
- (#{expand-body 4454}#
- (cons #{e1 7523}# #{e2 7524}#)
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 7492}#) #{s 7495}# #f)
- (set-source-properties!
- #{e 7492}#
- #{s 7495}#))
- #{e 7492}#)
- #{w 7616}#
- #{mod 7496}#)
- #{r 7617}#
- #{w 7616}#
- #{mod 7496}#))))))
- #{tmp 7498}#)
- (syntax-violation
- 'letrec
- "bad letrec"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 7492}#) #{s 7495}# #f)
- (set-source-properties! #{e 7492}# #{s 7495}#))
- #{e 7492}#)
- #{w 7494}#
- #{mod 7496}#))))))
- (#{global-extend 4413}#
- 'core
- 'letrec*
- (lambda (#{e 8121}#
- #{r 8122}#
- #{w 8123}#
- #{s 8124}#
- #{mod 8125}#)
- (let ((#{tmp 8127}#
+ #{e 29718}#))))))))
+ (#{global-extend 28236}#
+ 'core
+ 'lambda
+ (lambda (#{e 30659}#
+ #{r 30660}#
+ #{w 30661}#
+ #{s 30662}#
+ #{mod 30663}#)
+ (let ((#{tmp 30665}#
+ ($sc-dispatch
+ #{e 30659}#
+ '(_ any any . each-any))))
+ (if #{tmp 30665}#
+ (@apply
+ (lambda (#{args 30669}# #{e1 30670}# #{e2 30671}#)
+ (call-with-values
+ (lambda ()
+ (#{lambda-formals 28280}# #{args 30669}#))
+ (lambda (#{req 30674}#
+ #{opt 30675}#
+ #{rest 30676}#
+ #{kw 30677}#)
+ (letrec*
+ ((#{lp 30678}#
+ (lambda (#{body 30681}# #{meta 30682}#)
+ (let ((#{tmp 30684}#
+ ($sc-dispatch
+ #{body 30681}#
+ '(any any . each-any))))
+ (if (if #{tmp 30684}#
+ (@apply
+ (lambda (#{docstring 30688}#
+ #{e1 30689}#
+ #{e2 30690}#)
+ (string?
+ (syntax->datum #{docstring 30688}#)))
+ #{tmp 30684}#)
+ #f)
+ (@apply
+ (lambda (#{docstring 30691}#
+ #{e1 30692}#
+ #{e2 30693}#)
+ (#{lp 30678}#
+ (cons #{e1 30692}# #{e2 30693}#)
+ (append
+ #{meta 30682}#
+ (list (cons 'documentation
+ (syntax->datum
+ #{docstring 30691}#))))))
+ #{tmp 30684}#)
+ (let ((#{tmp 30694}#
+ ($sc-dispatch
+ #{body 30681}#
+ '(#(vector #(each (any . any)))
+ any
+ .
+ each-any))))
+ (if #{tmp 30694}#
+ (@apply
+ (lambda (#{k 30698}#
+ #{v 30699}#
+ #{e1 30700}#
+ #{e2 30701}#)
+ (#{lp 30678}#
+ (cons #{e1 30700}# #{e2 30701}#)
+ (append
+ #{meta 30682}#
+ (syntax->datum
+ (map cons
+ #{k 30698}#
+ #{v 30699}#)))))
+ #{tmp 30694}#)
+ (#{expand-simple-lambda 28281}#
+ #{e 30659}#
+ #{r 30660}#
+ #{w 30661}#
+ #{s 30662}#
+ #{mod 30663}#
+ #{req 30674}#
+ #{rest 30676}#
+ #{meta 30682}#
+ #{body 30681}#))))))))
+ (#{lp 30678}#
+ (cons #{e1 30670}# #{e2 30671}#)
+ '())))))
+ #{tmp 30665}#)
+ (syntax-violation
+ 'lambda
+ "bad lambda"
+ #{e 30659}#)))))
+ (#{global-extend 28236}#
+ 'core
+ 'lambda*
+ (lambda (#{e 31081}#
+ #{r 31082}#
+ #{w 31083}#
+ #{s 31084}#
+ #{mod 31085}#)
+ (let ((#{tmp 31087}#
+ ($sc-dispatch
+ #{e 31081}#
+ '(_ any any . each-any))))
+ (if #{tmp 31087}#
+ (@apply
+ (lambda (#{args 31091}# #{e1 31092}# #{e2 31093}#)
+ (call-with-values
+ (lambda ()
+ (#{expand-lambda-case 28283}#
+ #{e 31081}#
+ #{r 31082}#
+ #{w 31083}#
+ #{s 31084}#
+ #{mod 31085}#
+ #{lambda*-formals 28282}#
+ (list (cons #{args 31091}#
+ (cons #{e1 31092}# #{e2 31093}#)))))
+ (lambda (#{meta 31096}# #{lcase 31097}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 14)
+ #{s 31084}#
+ #{meta 31096}#
+ #{lcase 31097}#))))
+ #{tmp 31087}#)
+ (syntax-violation
+ 'lambda
+ "bad lambda*"
+ #{e 31081}#)))))
+ (#{global-extend 28236}#
+ 'core
+ 'case-lambda
+ (lambda (#{e 31260}#
+ #{r 31261}#
+ #{w 31262}#
+ #{s 31263}#
+ #{mod 31264}#)
+ (let ((#{tmp 31266}#
+ ($sc-dispatch
+ #{e 31260}#
+ '(_ (any any . each-any)
+ .
+ #(each (any any . each-any))))))
+ (if #{tmp 31266}#
+ (@apply
+ (lambda (#{args 31270}#
+ #{e1 31271}#
+ #{e2 31272}#
+ #{args* 31273}#
+ #{e1* 31274}#
+ #{e2* 31275}#)
+ (call-with-values
+ (lambda ()
+ (#{expand-lambda-case 28283}#
+ #{e 31260}#
+ #{r 31261}#
+ #{w 31262}#
+ #{s 31263}#
+ #{mod 31264}#
+ #{lambda-formals 28280}#
+ (cons (cons #{args 31270}#
+ (cons #{e1 31271}# #{e2 31272}#))
+ (map (lambda (#{tmp 27210 31278}#
+ #{tmp 27209 31279}#
+ #{tmp 27208 31280}#)
+ (cons #{tmp 27208 31280}#
+ (cons #{tmp 27209 31279}#
+ #{tmp 27210 31278}#)))
+ #{e2* 31275}#
+ #{e1* 31274}#
+ #{args* 31273}#))))
+ (lambda (#{meta 31281}# #{lcase 31282}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 14)
+ #{s 31263}#
+ #{meta 31281}#
+ #{lcase 31282}#))))
+ #{tmp 31266}#)
+ (syntax-violation
+ 'case-lambda
+ "bad case-lambda"
+ #{e 31260}#)))))
+ (#{global-extend 28236}#
+ 'core
+ 'case-lambda*
+ (lambda (#{e 31451}#
+ #{r 31452}#
+ #{w 31453}#
+ #{s 31454}#
+ #{mod 31455}#)
+ (let ((#{tmp 31457}#
+ ($sc-dispatch
+ #{e 31451}#
+ '(_ (any any . each-any)
+ .
+ #(each (any any . each-any))))))
+ (if #{tmp 31457}#
+ (@apply
+ (lambda (#{args 31461}#
+ #{e1 31462}#
+ #{e2 31463}#
+ #{args* 31464}#
+ #{e1* 31465}#
+ #{e2* 31466}#)
+ (call-with-values
+ (lambda ()
+ (#{expand-lambda-case 28283}#
+ #{e 31451}#
+ #{r 31452}#
+ #{w 31453}#
+ #{s 31454}#
+ #{mod 31455}#
+ #{lambda*-formals 28282}#
+ (cons (cons #{args 31461}#
+ (cons #{e1 31462}# #{e2 31463}#))
+ (map (lambda (#{tmp 27245 31469}#
+ #{tmp 27244 31470}#
+ #{tmp 27243 31471}#)
+ (cons #{tmp 27243 31471}#
+ (cons #{tmp 27244 31470}#
+ #{tmp 27245 31469}#)))
+ #{e2* 31466}#
+ #{e1* 31465}#
+ #{args* 31464}#))))
+ (lambda (#{meta 31472}# #{lcase 31473}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 14)
+ #{s 31454}#
+ #{meta 31472}#
+ #{lcase 31473}#))))
+ #{tmp 31457}#)
+ (syntax-violation
+ 'case-lambda
+ "bad case-lambda*"
+ #{e 31451}#)))))
+ (#{global-extend 28236}#
+ 'core
+ 'let
+ (letrec*
+ ((#{expand-let 31681}#
+ (lambda (#{e 31891}#
+ #{r 31892}#
+ #{w 31893}#
+ #{s 31894}#
+ #{mod 31895}#
+ #{constructor 31896}#
+ #{ids 31897}#
+ #{vals 31898}#
+ #{exps 31899}#)
+ (if (not (#{valid-bound-ids? 28261}# #{ids 31897}#))
+ (syntax-violation
+ 'let
+ "duplicate bound variable"
+ #{e 31891}#)
+ (let ((#{labels 31984}#
+ (#{gen-labels 28241}# #{ids 31897}#))
+ (#{new-vars 31985}#
+ (map #{gen-var 28285}# #{ids 31897}#)))
+ (let ((#{nw 31986}#
+ (#{make-binding-wrap 28252}#
+ #{ids 31897}#
+ #{labels 31984}#
+ #{w 31893}#))
+ (#{nr 31987}#
+ (#{extend-var-env 28234}#
+ #{labels 31984}#
+ #{new-vars 31985}#
+ #{r 31892}#)))
+ (#{constructor 31896}#
+ #{s 31894}#
+ (map syntax->datum #{ids 31897}#)
+ #{new-vars 31985}#
+ (map (lambda (#{x 32004}#)
+ (#{expand 28271}#
+ #{x 32004}#
+ #{r 31892}#
+ #{w 31893}#
+ #{mod 31895}#))
+ #{vals 31898}#)
+ (#{expand-body 28275}#
+ #{exps 31899}#
+ (#{source-wrap 28265}#
+ #{e 31891}#
+ #{nw 31986}#
+ #{s 31894}#
+ #{mod 31895}#)
+ #{nr 31987}#
+ #{nw 31986}#
+ #{mod 31895}#))))))))
+ (lambda (#{e 31682}#
+ #{r 31683}#
+ #{w 31684}#
+ #{s 31685}#
+ #{mod 31686}#)
+ (let ((#{tmp 31688}#
($sc-dispatch
- #{e 8121}#
+ #{e 31682}#
'(_ #(each (any any)) any . each-any))))
- (if (if #{tmp 8127}#
+ (if (if #{tmp 31688}#
(@apply
- (lambda (#{id 8131}#
- #{val 8132}#
- #{e1 8133}#
- #{e2 8134}#)
- (and-map #{id? 4415}# #{id 8131}#))
- #{tmp 8127}#)
+ (lambda (#{id 31692}#
+ #{val 31693}#
+ #{e1 31694}#
+ #{e2 31695}#)
+ (and-map #{id? 28238}# #{id 31692}#))
+ #{tmp 31688}#)
#f)
(@apply
- (lambda (#{id 8150}#
- #{val 8151}#
- #{e1 8152}#
- #{e2 8153}#)
- (if (not (#{valid-bound-ids? 4440}# #{id 8150}#))
- (syntax-violation
- 'letrec*
- "duplicate bound variable"
- #{e 8121}#)
- (let ((#{labels 8243}#
- (#{gen-labels 4418}# #{id 8150}#))
- (#{new-vars 8244}#
- (map #{gen-var 4464}# #{id 8150}#)))
- (let ((#{w 8245}#
- (#{make-binding-wrap 4429}#
- #{id 8150}#
- #{labels 8243}#
- #{w 8123}#))
- (#{r 8246}#
- (#{extend-var-env 4410}#
- #{labels 8243}#
- #{new-vars 8244}#
- #{r 8122}#)))
- (#{build-letrec 4399}#
- #{s 8124}#
- #t
- (map syntax->datum #{id 8150}#)
- #{new-vars 8244}#
- (map (lambda (#{x 8333}#)
- (#{expand 4450}#
- #{x 8333}#
- #{r 8246}#
- #{w 8245}#
- #{mod 8125}#))
- #{val 8151}#)
- (#{expand-body 4454}#
- (cons #{e1 8152}# #{e2 8153}#)
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 8121}#) #{s 8124}# #f)
- (set-source-properties!
- #{e 8121}#
- #{s 8124}#))
- #{e 8121}#)
- #{w 8245}#
- #{mod 8125}#)
- #{r 8246}#
- #{w 8245}#
- #{mod 8125}#))))))
- #{tmp 8127}#)
- (syntax-violation
- 'letrec*
- "bad letrec*"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 8121}#) #{s 8124}# #f)
- (set-source-properties! #{e 8121}# #{s 8124}#))
- #{e 8121}#)
- #{w 8123}#
- #{mod 8125}#))))))
- (#{global-extend 4413}#
- 'core
- 'set!
- (lambda (#{e 8789}#
- #{r 8790}#
- #{w 8791}#
- #{s 8792}#
- #{mod 8793}#)
- (let ((#{tmp 8795}#
- ($sc-dispatch #{e 8789}# '(_ any any))))
- (if (if #{tmp 8795}#
+ (lambda (#{id 31711}#
+ #{val 31712}#
+ #{e1 31713}#
+ #{e2 31714}#)
+ (#{expand-let 31681}#
+ #{e 31682}#
+ #{r 31683}#
+ #{w 31684}#
+ #{s 31685}#
+ #{mod 31686}#
+ (lambda (#{src 31718}#
+ #{ids 31719}#
+ #{vars 31720}#
+ #{val-exps 31721}#
+ #{body-exp 31722}#)
+ (begin
+ (for-each
+ #{maybe-name-value! 28203}#
+ #{ids 31719}#
+ #{val-exps 31721}#)
+ (if (null? #{vars 31720}#)
+ #{body-exp 31722}#
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 16)
+ #{src 31718}#
+ #{ids 31719}#
+ #{vars 31720}#
+ #{val-exps 31721}#
+ #{body-exp 31722}#))))
+ #{id 31711}#
+ #{val 31712}#
+ (cons #{e1 31713}# #{e2 31714}#)))
+ #{tmp 31688}#)
+ (let ((#{tmp 31729}#
+ ($sc-dispatch
+ #{e 31682}#
+ '(_ any #(each (any any)) any . each-any))))
+ (if (if #{tmp 31729}#
+ (@apply
+ (lambda (#{f 31733}#
+ #{id 31734}#
+ #{val 31735}#
+ #{e1 31736}#
+ #{e2 31737}#)
+ (if (if (symbol? #{f 31733}#)
+ #t
+ (if (if (vector? #{f 31733}#)
+ (if (= (vector-length #{f 31733}#) 4)
+ (eq? (vector-ref #{f 31733}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref #{f 31733}# 1))
+ #f))
+ (and-map #{id? 28238}# #{id 31734}#)
+ #f))
+ #{tmp 31729}#)
+ #f)
(@apply
- (lambda (#{id 8799}# #{val 8800}#)
- (if (symbol? #{id 8799}#)
- #t
- (if (if (vector? #{id 8799}#)
- (if (= (vector-length #{id 8799}#) 4)
- (eq? (vector-ref #{id 8799}# 0) 'syntax-object)
+ (lambda (#{f 31779}#
+ #{id 31780}#
+ #{val 31781}#
+ #{e1 31782}#
+ #{e2 31783}#)
+ (#{expand-let 31681}#
+ #{e 31682}#
+ #{r 31683}#
+ #{w 31684}#
+ #{s 31685}#
+ #{mod 31686}#
+ #{build-named-let 28222}#
+ (cons #{f 31779}# #{id 31780}#)
+ #{val 31781}#
+ (cons #{e1 31782}# #{e2 31783}#)))
+ #{tmp 31729}#)
+ (syntax-violation
+ 'let
+ "bad let"
+ (let ((#{x 31796}#
+ (begin
+ (if (if (pair? #{e 31682}#) #{s 31685}# #f)
+ (set-source-properties!
+ #{e 31682}#
+ #{s 31685}#))
+ #{e 31682}#)))
+ (if (if (null? (car #{w 31684}#))
+ (null? (cdr #{w 31684}#))
+ #f)
+ #{x 31796}#
+ (if (if (vector? #{x 31796}#)
+ (if (= (vector-length #{x 31796}#) 4)
+ (eq? (vector-ref #{x 31796}# 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref #{id 8799}# 1))
- #f)))
- #{tmp 8795}#)
- #f)
- (@apply
- (lambda (#{id 8827}# #{val 8828}#)
- (let ((#{n 8829}#
- (#{id-var-name 4434}# #{id 8827}# #{w 8791}#))
- (#{id-mod 8830}#
- (if (if (vector? #{id 8827}#)
- (if (= (vector-length #{id 8827}#) 4)
- (eq? (vector-ref #{id 8827}# 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref #{id 8827}# 3)
- #{mod 8793}#)))
- (let ((#{b 8831}#
- (let ((#{t 8872}# (assq #{n 8829}# #{r 8790}#)))
- (if #{t 8872}#
- (cdr #{t 8872}#)
- (if (symbol? #{n 8829}#)
- (let ((#{t 8877}#
- (#{get-global-definition-hook 4378}#
- #{n 8829}#
- #{id-mod 8830}#)))
- (if #{t 8877}# #{t 8877}# '(global)))
- '(displaced-lexical))))))
- (let ((#{atom-key 8832}# (car #{b 8831}#)))
- (if (eqv? #{atom-key 8832}# 'lexical)
- (#{build-lexical-assignment 4386}#
- #{s 8792}#
- (syntax->datum #{id 8827}#)
- (cdr #{b 8831}#)
- (#{expand 4450}#
- #{val 8828}#
- #{r 8790}#
- #{w 8791}#
- #{mod 8793}#))
- (if (eqv? #{atom-key 8832}# 'global)
- (#{build-global-assignment 4389}#
- #{s 8792}#
- #{n 8829}#
- (#{expand 4450}#
- #{val 8828}#
- #{r 8790}#
- #{w 8791}#
- #{mod 8793}#)
- #{id-mod 8830}#)
- (if (eqv? #{atom-key 8832}# 'macro)
- (let ((#{p 9191}# (cdr #{b 8831}#)))
- (if (procedure-property
- #{p 9191}#
- 'variable-transformer)
- (#{expand 4450}#
- (#{expand-macro 4453}#
- #{p 9191}#
- #{e 8789}#
- #{r 8790}#
- #{w 8791}#
- #{s 8792}#
- #f
- #{mod 8793}#)
- #{r 8790}#
- '(())
- #{mod 8793}#)
- (syntax-violation
- 'set!
- "not a variable transformer"
- (#{wrap 4443}#
- #{e 8789}#
- #{w 8791}#
- #{mod 8793}#)
- (#{wrap 4443}#
- #{id 8827}#
- #{w 8791}#
- #{id-mod 8830}#))))
- (if (eqv? #{atom-key 8832}# 'displaced-lexical)
- (syntax-violation
- 'set!
- "identifier out of context"
- (#{wrap 4443}#
- #{id 8827}#
- #{w 8791}#
- #{mod 8793}#))
- (syntax-violation
- 'set!
- "bad set!"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 8789}#) #{s 8792}# #f)
- (set-source-properties!
- #{e 8789}#
- #{s 8792}#))
- #{e 8789}#)
- #{w 8791}#
- #{mod 8793}#))))))))))
- #{tmp 8795}#)
- (let ((#{tmp 9286}#
- ($sc-dispatch
- #{e 8789}#
- '(_ (any . each-any) any))))
- (if #{tmp 9286}#
- (@apply
- (lambda (#{head 9290}# #{tail 9291}# #{val 9292}#)
- (call-with-values
- (lambda ()
- (#{syntax-type 4449}#
- #{head 9290}#
- #{r 8790}#
- '(())
- #f
- #f
- #{mod 8793}#
- #t))
- (lambda (#{type 9295}#
- #{value 9296}#
- #{ee 9297}#
- #{ww 9298}#
- #{ss 9299}#
- #{modmod 9300}#)
- (if (eqv? #{type 9295}# 'module-ref)
- (let ((#{val 9304}#
- (#{expand 4450}#
- #{val 9292}#
- #{r 8790}#
- #{w 8791}#
- #{mod 8793}#)))
- (call-with-values
- (lambda ()
- (#{value 9296}#
- (cons #{head 9290}# #{tail 9291}#)
- #{r 8790}#
- #{w 8791}#))
- (lambda (#{e 9305}#
- #{r 9306}#
- #{w 9307}#
- #{s* 9308}#
- #{mod 9309}#)
- (let ((#{tmp 9311}# (list #{e 9305}#)))
- (if (@apply
- (lambda (#{e 9313}#)
- (if (symbol? #{e 9313}#)
- #t
- (if (if (vector? #{e 9313}#)
- (if (= (vector-length
- #{e 9313}#)
- 4)
- (eq? (vector-ref
- #{e 9313}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref #{e 9313}# 1))
- #f)))
- #{tmp 9311}#)
- (@apply
- (lambda (#{e 9343}#)
- (#{build-global-assignment 4389}#
- #{s 8792}#
- (syntax->datum #{e 9343}#)
- #{val 9304}#
- #{mod 9309}#))
- #{tmp 9311}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{e 9305}#))))))
- (#{build-application 4382}#
- #{s 8792}#
- (let ((#{e 9568}#
- (list '#(syntax-object
- setter
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(type value ee ww ss modmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("i3613"
- "i3614"
- "i3615"
- "i3616"
- "i3617"
- "i3618"))
- #(ribcage
- #(head tail val)
- #((top) (top) (top))
- #("i3599" "i3600" "i3601"))
- #(ribcage () () ())
- #(ribcage
- #(e r w s mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i3563"
- "i3564"
- "i3565"
- "i3566"
- "i3567"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))
- #{head 9290}#)))
- (call-with-values
- (lambda ()
- (#{syntax-type 4449}#
- #{e 9568}#
- #{r 8790}#
- #{w 8791}#
- (#{source-annotation 4408}# #{e 9568}#)
- #f
- #{mod 8793}#
- #f))
- (lambda (#{type 9575}#
- #{value 9576}#
- #{e 9577}#
- #{w 9578}#
- #{s 9579}#
- #{mod 9580}#)
- (#{expand-expr 4451}#
- #{type 9575}#
- #{value 9576}#
- #{e 9577}#
- #{r 8790}#
- #{w 9578}#
- #{s 9579}#
- #{mod 9580}#))))
- (map (lambda (#{e 9584}#)
- (call-with-values
- (lambda ()
- (#{syntax-type 4449}#
- #{e 9584}#
- #{r 8790}#
- #{w 8791}#
- (#{source-annotation 4408}#
- #{e 9584}#)
- #f
- #{mod 8793}#
- #f))
- (lambda (#{type 9599}#
- #{value 9600}#
- #{e 9601}#
- #{w 9602}#
- #{s 9603}#
- #{mod 9604}#)
- (#{expand-expr 4451}#
- #{type 9599}#
- #{value 9600}#
- #{e 9601}#
- #{r 8790}#
- #{w 9602}#
- #{s 9603}#
- #{mod 9604}#))))
- (append
- #{tail 9291}#
- (list #{val 9292}#))))))))
- #{tmp 9286}#)
+ (let ((#{expression 31828}#
+ (vector-ref #{x 31796}# 1))
+ (#{wrap 31829}#
+ (let ((#{w2 31837}#
+ (vector-ref #{x 31796}# 2)))
+ (let ((#{m1 31838}# (car #{w 31684}#))
+ (#{s1 31839}# (cdr #{w 31684}#)))
+ (if (null? #{m1 31838}#)
+ (if (null? #{s1 31839}#)
+ #{w2 31837}#
+ (cons (car #{w2 31837}#)
+ (let ((#{m2 31854}#
+ (cdr #{w2 31837}#)))
+ (if (null? #{m2 31854}#)
+ #{s1 31839}#
+ (append
+ #{s1 31839}#
+ #{m2 31854}#)))))
+ (cons (let ((#{m2 31862}#
+ (car #{w2 31837}#)))
+ (if (null? #{m2 31862}#)
+ #{m1 31838}#
+ (append
+ #{m1 31838}#
+ #{m2 31862}#)))
+ (let ((#{m2 31870}#
+ (cdr #{w2 31837}#)))
+ (if (null? #{m2 31870}#)
+ #{s1 31839}#
+ (append
+ #{s1 31839}#
+ #{m2 31870}#))))))))
+ (#{module 31830}# (vector-ref #{x 31796}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 31828}#
+ #{wrap 31829}#
+ #{module 31830}#))
+ (if (null? #{x 31796}#)
+ #{x 31796}#
+ (vector
+ 'syntax-object
+ #{x 31796}#
+ #{w 31684}#
+ #{mod 31686}#)))))))))))))
+ (#{global-extend 28236}#
+ 'core
+ 'letrec
+ (lambda (#{e 32475}#
+ #{r 32476}#
+ #{w 32477}#
+ #{s 32478}#
+ #{mod 32479}#)
+ (let ((#{tmp 32481}#
+ ($sc-dispatch
+ #{e 32475}#
+ '(_ #(each (any any)) any . each-any))))
+ (if (if #{tmp 32481}#
+ (@apply
+ (lambda (#{id 32485}#
+ #{val 32486}#
+ #{e1 32487}#
+ #{e2 32488}#)
+ (and-map #{id? 28238}# #{id 32485}#))
+ #{tmp 32481}#)
+ #f)
+ (@apply
+ (lambda (#{id 32504}#
+ #{val 32505}#
+ #{e1 32506}#
+ #{e2 32507}#)
+ (if (not (#{valid-bound-ids? 28261}# #{id 32504}#))
(syntax-violation
- 'set!
- "bad set!"
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 8789}#) #{s 8792}# #f)
- (set-source-properties! #{e 8789}# #{s 8792}#))
- #{e 8789}#)
- #{w 8791}#
- #{mod 8793}#))))))))
- (module-define!
- (current-module)
- '@
- (make-syntax-transformer
- '@
- 'module-ref
- (lambda (#{e 9647}# #{r 9648}# #{w 9649}#)
- (let ((#{tmp 9651}#
- ($sc-dispatch #{e 9647}# '(_ each-any any))))
- (if (if #{tmp 9651}#
- (@apply
- (lambda (#{mod 9654}# #{id 9655}#)
- (if (and-map #{id? 4415}# #{mod 9654}#)
- (if (symbol? #{id 9655}#)
- #t
- (if (if (vector? #{id 9655}#)
- (if (= (vector-length #{id 9655}#) 4)
- (eq? (vector-ref #{id 9655}# 0)
- 'syntax-object)
+ 'letrec
+ "duplicate bound variable"
+ #{e 32475}#)
+ (let ((#{labels 32604}#
+ (#{gen-labels 28241}# #{id 32504}#))
+ (#{new-vars 32605}#
+ (map #{gen-var 28285}# #{id 32504}#)))
+ (let ((#{w 32606}#
+ (#{make-binding-wrap 28252}#
+ #{id 32504}#
+ #{labels 32604}#
+ #{w 32477}#))
+ (#{r 32607}#
+ (#{extend-var-env 28234}#
+ #{labels 32604}#
+ #{new-vars 32605}#
+ #{r 32476}#)))
+ (#{build-letrec 28223}#
+ #{s 32478}#
+ #f
+ (map syntax->datum #{id 32504}#)
+ #{new-vars 32605}#
+ (map (lambda (#{x 32686}#)
+ (#{expand 28271}#
+ #{x 32686}#
+ #{r 32607}#
+ #{w 32606}#
+ #{mod 32479}#))
+ #{val 32505}#)
+ (#{expand-body 28275}#
+ (cons #{e1 32506}# #{e2 32507}#)
+ (let ((#{x 32748}#
+ (begin
+ (if (if (pair? #{e 32475}#) #{s 32478}# #f)
+ (set-source-properties!
+ #{e 32475}#
+ #{s 32478}#))
+ #{e 32475}#)))
+ (if (if (null? (car #{w 32606}#))
+ (null? (cdr #{w 32606}#))
+ #f)
+ #{x 32748}#
+ (if (if (vector? #{x 32748}#)
+ (if (= (vector-length #{x 32748}#) 4)
+ (eq? (vector-ref #{x 32748}# 0)
+ 'syntax-object)
+ #f)
#f)
+ (let ((#{expression 32780}#
+ (vector-ref #{x 32748}# 1))
+ (#{wrap 32781}#
+ (let ((#{w2 32789}#
+ (vector-ref #{x 32748}# 2)))
+ (let ((#{m1 32790}#
+ (car #{w 32606}#))
+ (#{s1 32791}#
+ (cdr #{w 32606}#)))
+ (if (null? #{m1 32790}#)
+ (if (null? #{s1 32791}#)
+ #{w2 32789}#
+ (cons (car #{w2 32789}#)
+ (let ((#{m2 32806}#
+ (cdr #{w2 32789}#)))
+ (if (null? #{m2 32806}#)
+ #{s1 32791}#
+ (append
+ #{s1 32791}#
+ #{m2 32806}#)))))
+ (cons (let ((#{m2 32814}#
+ (car #{w2 32789}#)))
+ (if (null? #{m2 32814}#)
+ #{m1 32790}#
+ (append
+ #{m1 32790}#
+ #{m2 32814}#)))
+ (let ((#{m2 32822}#
+ (cdr #{w2 32789}#)))
+ (if (null? #{m2 32822}#)
+ #{s1 32791}#
+ (append
+ #{s1 32791}#
+ #{m2 32822}#))))))))
+ (#{module 32782}#
+ (vector-ref #{x 32748}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 32780}#
+ #{wrap 32781}#
+ #{module 32782}#))
+ (if (null? #{x 32748}#)
+ #{x 32748}#
+ (vector
+ 'syntax-object
+ #{x 32748}#
+ #{w 32606}#
+ #{mod 32479}#)))))
+ #{r 32607}#
+ #{w 32606}#
+ #{mod 32479}#))))))
+ #{tmp 32481}#)
+ (syntax-violation
+ 'letrec
+ "bad letrec"
+ (let ((#{x 33061}#
+ (begin
+ (if (if (pair? #{e 32475}#) #{s 32478}# #f)
+ (set-source-properties! #{e 32475}# #{s 32478}#))
+ #{e 32475}#)))
+ (if (if (null? (car #{w 32477}#))
+ (null? (cdr #{w 32477}#))
+ #f)
+ #{x 33061}#
+ (if (if (vector? #{x 33061}#)
+ (if (= (vector-length #{x 33061}#) 4)
+ (eq? (vector-ref #{x 33061}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 33093}# (vector-ref #{x 33061}# 1))
+ (#{wrap 33094}#
+ (let ((#{w2 33102}# (vector-ref #{x 33061}# 2)))
+ (let ((#{m1 33103}# (car #{w 32477}#))
+ (#{s1 33104}# (cdr #{w 32477}#)))
+ (if (null? #{m1 33103}#)
+ (if (null? #{s1 33104}#)
+ #{w2 33102}#
+ (cons (car #{w2 33102}#)
+ (let ((#{m2 33119}#
+ (cdr #{w2 33102}#)))
+ (if (null? #{m2 33119}#)
+ #{s1 33104}#
+ (append
+ #{s1 33104}#
+ #{m2 33119}#)))))
+ (cons (let ((#{m2 33127}#
+ (car #{w2 33102}#)))
+ (if (null? #{m2 33127}#)
+ #{m1 33103}#
+ (append
+ #{m1 33103}#
+ #{m2 33127}#)))
+ (let ((#{m2 33135}#
+ (cdr #{w2 33102}#)))
+ (if (null? #{m2 33135}#)
+ #{s1 33104}#
+ (append
+ #{s1 33104}#
+ #{m2 33135}#))))))))
+ (#{module 33095}# (vector-ref #{x 33061}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 33093}#
+ #{wrap 33094}#
+ #{module 33095}#))
+ (if (null? #{x 33061}#)
+ #{x 33061}#
+ (vector
+ 'syntax-object
+ #{x 33061}#
+ #{w 32477}#
+ #{mod 32479}#))))))))))
+ (#{global-extend 28236}#
+ 'core
+ 'letrec*
+ (lambda (#{e 33286}#
+ #{r 33287}#
+ #{w 33288}#
+ #{s 33289}#
+ #{mod 33290}#)
+ (let ((#{tmp 33292}#
+ ($sc-dispatch
+ #{e 33286}#
+ '(_ #(each (any any)) any . each-any))))
+ (if (if #{tmp 33292}#
+ (@apply
+ (lambda (#{id 33296}#
+ #{val 33297}#
+ #{e1 33298}#
+ #{e2 33299}#)
+ (and-map #{id? 28238}# #{id 33296}#))
+ #{tmp 33292}#)
+ #f)
+ (@apply
+ (lambda (#{id 33315}#
+ #{val 33316}#
+ #{e1 33317}#
+ #{e2 33318}#)
+ (if (not (#{valid-bound-ids? 28261}# #{id 33315}#))
+ (syntax-violation
+ 'letrec*
+ "duplicate bound variable"
+ #{e 33286}#)
+ (let ((#{labels 33415}#
+ (#{gen-labels 28241}# #{id 33315}#))
+ (#{new-vars 33416}#
+ (map #{gen-var 28285}# #{id 33315}#)))
+ (let ((#{w 33417}#
+ (#{make-binding-wrap 28252}#
+ #{id 33315}#
+ #{labels 33415}#
+ #{w 33288}#))
+ (#{r 33418}#
+ (#{extend-var-env 28234}#
+ #{labels 33415}#
+ #{new-vars 33416}#
+ #{r 33287}#)))
+ (#{build-letrec 28223}#
+ #{s 33289}#
+ #t
+ (map syntax->datum #{id 33315}#)
+ #{new-vars 33416}#
+ (map (lambda (#{x 33497}#)
+ (#{expand 28271}#
+ #{x 33497}#
+ #{r 33418}#
+ #{w 33417}#
+ #{mod 33290}#))
+ #{val 33316}#)
+ (#{expand-body 28275}#
+ (cons #{e1 33317}# #{e2 33318}#)
+ (let ((#{x 33559}#
+ (begin
+ (if (if (pair? #{e 33286}#) #{s 33289}# #f)
+ (set-source-properties!
+ #{e 33286}#
+ #{s 33289}#))
+ #{e 33286}#)))
+ (if (if (null? (car #{w 33417}#))
+ (null? (cdr #{w 33417}#))
#f)
- (symbol? (vector-ref #{id 9655}# 1))
- #f))
- #f))
- #{tmp 9651}#)
- #f)
+ #{x 33559}#
+ (if (if (vector? #{x 33559}#)
+ (if (= (vector-length #{x 33559}#) 4)
+ (eq? (vector-ref #{x 33559}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 33591}#
+ (vector-ref #{x 33559}# 1))
+ (#{wrap 33592}#
+ (let ((#{w2 33600}#
+ (vector-ref #{x 33559}# 2)))
+ (let ((#{m1 33601}#
+ (car #{w 33417}#))
+ (#{s1 33602}#
+ (cdr #{w 33417}#)))
+ (if (null? #{m1 33601}#)
+ (if (null? #{s1 33602}#)
+ #{w2 33600}#
+ (cons (car #{w2 33600}#)
+ (let ((#{m2 33617}#
+ (cdr #{w2 33600}#)))
+ (if (null? #{m2 33617}#)
+ #{s1 33602}#
+ (append
+ #{s1 33602}#
+ #{m2 33617}#)))))
+ (cons (let ((#{m2 33625}#
+ (car #{w2 33600}#)))
+ (if (null? #{m2 33625}#)
+ #{m1 33601}#
+ (append
+ #{m1 33601}#
+ #{m2 33625}#)))
+ (let ((#{m2 33633}#
+ (cdr #{w2 33600}#)))
+ (if (null? #{m2 33633}#)
+ #{s1 33602}#
+ (append
+ #{s1 33602}#
+ #{m2 33633}#))))))))
+ (#{module 33593}#
+ (vector-ref #{x 33559}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 33591}#
+ #{wrap 33592}#
+ #{module 33593}#))
+ (if (null? #{x 33559}#)
+ #{x 33559}#
+ (vector
+ 'syntax-object
+ #{x 33559}#
+ #{w 33417}#
+ #{mod 33290}#)))))
+ #{r 33418}#
+ #{w 33417}#
+ #{mod 33290}#))))))
+ #{tmp 33292}#)
+ (syntax-violation
+ 'letrec*
+ "bad letrec*"
+ (let ((#{x 33872}#
+ (begin
+ (if (if (pair? #{e 33286}#) #{s 33289}# #f)
+ (set-source-properties! #{e 33286}# #{s 33289}#))
+ #{e 33286}#)))
+ (if (if (null? (car #{w 33288}#))
+ (null? (cdr #{w 33288}#))
+ #f)
+ #{x 33872}#
+ (if (if (vector? #{x 33872}#)
+ (if (= (vector-length #{x 33872}#) 4)
+ (eq? (vector-ref #{x 33872}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 33904}# (vector-ref #{x 33872}# 1))
+ (#{wrap 33905}#
+ (let ((#{w2 33913}# (vector-ref #{x 33872}# 2)))
+ (let ((#{m1 33914}# (car #{w 33288}#))
+ (#{s1 33915}# (cdr #{w 33288}#)))
+ (if (null? #{m1 33914}#)
+ (if (null? #{s1 33915}#)
+ #{w2 33913}#
+ (cons (car #{w2 33913}#)
+ (let ((#{m2 33930}#
+ (cdr #{w2 33913}#)))
+ (if (null? #{m2 33930}#)
+ #{s1 33915}#
+ (append
+ #{s1 33915}#
+ #{m2 33930}#)))))
+ (cons (let ((#{m2 33938}#
+ (car #{w2 33913}#)))
+ (if (null? #{m2 33938}#)
+ #{m1 33914}#
+ (append
+ #{m1 33914}#
+ #{m2 33938}#)))
+ (let ((#{m2 33946}#
+ (cdr #{w2 33913}#)))
+ (if (null? #{m2 33946}#)
+ #{s1 33915}#
+ (append
+ #{s1 33915}#
+ #{m2 33946}#))))))))
+ (#{module 33906}# (vector-ref #{x 33872}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 33904}#
+ #{wrap 33905}#
+ #{module 33906}#))
+ (if (null? #{x 33872}#)
+ #{x 33872}#
+ (vector
+ 'syntax-object
+ #{x 33872}#
+ #{w 33288}#
+ #{mod 33290}#))))))))))
+ (#{global-extend 28236}#
+ 'core
+ 'set!
+ (lambda (#{e 34105}#
+ #{r 34106}#
+ #{w 34107}#
+ #{s 34108}#
+ #{mod 34109}#)
+ (let ((#{tmp 34111}#
+ ($sc-dispatch #{e 34105}# '(_ any any))))
+ (if (if #{tmp 34111}#
(@apply
- (lambda (#{mod 9695}# #{id 9696}#)
- (values
- (syntax->datum #{id 9696}#)
- #{r 9648}#
- #{w 9649}#
- #f
- (syntax->datum
- (cons '#(syntax-object
- public
- ((top)
- #(ribcage
- #(mod id)
- #((top) (top))
- #("i3660" "i3661"))
- #(ribcage () () ())
- #(ribcage
- #(e r w)
- #((top) (top) (top))
- #("i3648" "i3649" "i3650"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))
- #{mod 9695}#))))
- #{tmp 9651}#)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- #{e 9647}#))))))
- (#{global-extend 4413}#
- 'module-ref
- '@@
- (lambda (#{e 9788}# #{r 9789}# #{w 9790}#)
- (letrec*
- ((#{remodulate 9791}#
- (lambda (#{x 9826}# #{mod 9827}#)
- (if (pair? #{x 9826}#)
- (cons (#{remodulate 9791}#
- (car #{x 9826}#)
- #{mod 9827}#)
- (#{remodulate 9791}#
- (cdr #{x 9826}#)
- #{mod 9827}#))
- (if (if (vector? #{x 9826}#)
- (if (= (vector-length #{x 9826}#) 4)
- (eq? (vector-ref #{x 9826}# 0) 'syntax-object)
- #f)
- #f)
- (let ((#{expression 9841}#
- (#{remodulate 9791}#
- (vector-ref #{x 9826}# 1)
- #{mod 9827}#))
- (#{wrap 9842}# (vector-ref #{x 9826}# 2)))
- (vector
- 'syntax-object
- #{expression 9841}#
- #{wrap 9842}#
- #{mod 9827}#))
- (if (vector? #{x 9826}#)
- (let ((#{n 9850}# (vector-length #{x 9826}#)))
- (let ((#{v 9851}# (make-vector #{n 9850}#)))
- (letrec*
- ((#{loop 9852}#
- (lambda (#{i 9899}#)
- (if (= #{i 9899}# #{n 9850}#)
- #{v 9851}#
- (begin
- (vector-set!
- #{v 9851}#
- #{i 9899}#
- (#{remodulate 9791}#
- (vector-ref #{x 9826}# #{i 9899}#)
- #{mod 9827}#))
- (#{loop 9852}# (#{1+}# #{i 9899}#)))))))
- (#{loop 9852}# 0))))
- #{x 9826}#))))))
- (let ((#{tmp 9793}#
- ($sc-dispatch #{e 9788}# '(_ each-any any))))
- (if (if #{tmp 9793}#
- (@apply
- (lambda (#{mod 9797}# #{exp 9798}#)
- (and-map #{id? 4415}# #{mod 9797}#))
- #{tmp 9793}#)
- #f)
+ (lambda (#{id 34115}# #{val 34116}#)
+ (if (symbol? #{id 34115}#)
+ #t
+ (if (if (vector? #{id 34115}#)
+ (if (= (vector-length #{id 34115}#) 4)
+ (eq? (vector-ref #{id 34115}# 0) 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref #{id 34115}# 1))
+ #f)))
+ #{tmp 34111}#)
+ #f)
+ (@apply
+ (lambda (#{id 34143}# #{val 34144}#)
+ (call-with-values
+ (lambda ()
+ (#{resolve-identifier 28258}#
+ #{id 34143}#
+ #{w 34107}#
+ #{r 34106}#
+ #{mod 34109}#
+ #t))
+ (lambda (#{type 34147}# #{value 34148}# #{id-mod 34149}#)
+ (if (eqv? #{type 34147}# 'lexical)
+ (#{build-lexical-assignment 28209}#
+ #{s 34108}#
+ (syntax->datum #{id 34143}#)
+ #{value 34148}#
+ (#{expand 28271}#
+ #{val 34144}#
+ #{r 34106}#
+ #{w 34107}#
+ #{mod 34109}#))
+ (if (eqv? #{type 34147}# 'global)
+ (#{build-global-assignment 28212}#
+ #{s 34108}#
+ #{value 34148}#
+ (#{expand 28271}#
+ #{val 34144}#
+ #{r 34106}#
+ #{w 34107}#
+ #{mod 34109}#)
+ #{id-mod 34149}#)
+ (if (eqv? #{type 34147}# 'macro)
+ (if (procedure-property
+ #{value 34148}#
+ 'variable-transformer)
+ (#{expand 28271}#
+ (#{expand-macro 28274}#
+ #{value 34148}#
+ #{e 34105}#
+ #{r 34106}#
+ #{w 34107}#
+ #{s 34108}#
+ #f
+ #{mod 34109}#)
+ #{r 34106}#
+ '(())
+ #{mod 34109}#)
+ (syntax-violation
+ 'set!
+ "not a variable transformer"
+ (if (if (null? (car #{w 34107}#))
+ (null? (cdr #{w 34107}#))
+ #f)
+ #{e 34105}#
+ (if (if (vector? #{e 34105}#)
+ (if (= (vector-length #{e 34105}#) 4)
+ (eq? (vector-ref #{e 34105}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 34589}#
+ (vector-ref #{e 34105}# 1))
+ (#{wrap 34590}#
+ (let ((#{w2 34600}#
+ (vector-ref #{e 34105}# 2)))
+ (let ((#{m1 34601}#
+ (car #{w 34107}#))
+ (#{s1 34602}#
+ (cdr #{w 34107}#)))
+ (if (null? #{m1 34601}#)
+ (if (null? #{s1 34602}#)
+ #{w2 34600}#
+ (cons (car #{w2 34600}#)
+ (let ((#{m2 34619}#
+ (cdr #{w2 34600}#)))
+ (if (null? #{m2 34619}#)
+ #{s1 34602}#
+ (append
+ #{s1 34602}#
+ #{m2 34619}#)))))
+ (cons (let ((#{m2 34627}#
+ (car #{w2 34600}#)))
+ (if (null? #{m2 34627}#)
+ #{m1 34601}#
+ (append
+ #{m1 34601}#
+ #{m2 34627}#)))
+ (let ((#{m2 34635}#
+ (cdr #{w2 34600}#)))
+ (if (null? #{m2 34635}#)
+ #{s1 34602}#
+ (append
+ #{s1 34602}#
+ #{m2 34635}#))))))))
+ (#{module 34591}#
+ (vector-ref #{e 34105}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 34589}#
+ #{wrap 34590}#
+ #{module 34591}#))
+ (if (null? #{e 34105}#)
+ #{e 34105}#
+ (vector
+ 'syntax-object
+ #{e 34105}#
+ #{w 34107}#
+ #{mod 34109}#))))
+ (if (if (null? (car #{w 34107}#))
+ (null? (cdr #{w 34107}#))
+ #f)
+ #{id 34143}#
+ (if (if (vector? #{id 34143}#)
+ (if (= (vector-length #{id 34143}#) 4)
+ (eq? (vector-ref #{id 34143}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 34687}#
+ (vector-ref #{id 34143}# 1))
+ (#{wrap 34688}#
+ (let ((#{w2 34698}#
+ (vector-ref #{id 34143}# 2)))
+ (let ((#{m1 34699}#
+ (car #{w 34107}#))
+ (#{s1 34700}#
+ (cdr #{w 34107}#)))
+ (if (null? #{m1 34699}#)
+ (if (null? #{s1 34700}#)
+ #{w2 34698}#
+ (cons (car #{w2 34698}#)
+ (let ((#{m2 34717}#
+ (cdr #{w2 34698}#)))
+ (if (null? #{m2 34717}#)
+ #{s1 34700}#
+ (append
+ #{s1 34700}#
+ #{m2 34717}#)))))
+ (cons (let ((#{m2 34725}#
+ (car #{w2 34698}#)))
+ (if (null? #{m2 34725}#)
+ #{m1 34699}#
+ (append
+ #{m1 34699}#
+ #{m2 34725}#)))
+ (let ((#{m2 34733}#
+ (cdr #{w2 34698}#)))
+ (if (null? #{m2 34733}#)
+ #{s1 34700}#
+ (append
+ #{s1 34700}#
+ #{m2 34733}#))))))))
+ (#{module 34689}#
+ (vector-ref #{id 34143}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 34687}#
+ #{wrap 34688}#
+ #{module 34689}#))
+ (if (null? #{id 34143}#)
+ #{id 34143}#
+ (vector
+ 'syntax-object
+ #{id 34143}#
+ #{w 34107}#
+ #{id-mod 34149}#))))))
+ (if (eqv? #{type 34147}# 'displaced-lexical)
+ (syntax-violation
+ 'set!
+ "identifier out of context"
+ (if (if (null? (car #{w 34107}#))
+ (null? (cdr #{w 34107}#))
+ #f)
+ #{id 34143}#
+ (if (if (vector? #{id 34143}#)
+ (if (= (vector-length #{id 34143}#) 4)
+ (eq? (vector-ref #{id 34143}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 34788}#
+ (vector-ref #{id 34143}# 1))
+ (#{wrap 34789}#
+ (let ((#{w2 34799}#
+ (vector-ref #{id 34143}# 2)))
+ (let ((#{m1 34800}#
+ (car #{w 34107}#))
+ (#{s1 34801}#
+ (cdr #{w 34107}#)))
+ (if (null? #{m1 34800}#)
+ (if (null? #{s1 34801}#)
+ #{w2 34799}#
+ (cons (car #{w2 34799}#)
+ (let ((#{m2 34818}#
+ (cdr #{w2 34799}#)))
+ (if (null? #{m2 34818}#)
+ #{s1 34801}#
+ (append
+ #{s1 34801}#
+ #{m2 34818}#)))))
+ (cons (let ((#{m2 34826}#
+ (car #{w2 34799}#)))
+ (if (null? #{m2 34826}#)
+ #{m1 34800}#
+ (append
+ #{m1 34800}#
+ #{m2 34826}#)))
+ (let ((#{m2 34834}#
+ (cdr #{w2 34799}#)))
+ (if (null? #{m2 34834}#)
+ #{s1 34801}#
+ (append
+ #{s1 34801}#
+ #{m2 34834}#))))))))
+ (#{module 34790}#
+ (vector-ref #{id 34143}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 34788}#
+ #{wrap 34789}#
+ #{module 34790}#))
+ (if (null? #{id 34143}#)
+ #{id 34143}#
+ (vector
+ 'syntax-object
+ #{id 34143}#
+ #{w 34107}#
+ #{mod 34109}#)))))
+ (syntax-violation
+ 'set!
+ "bad set!"
+ (let ((#{x 34866}#
+ (begin
+ (if (if (pair? #{e 34105}#)
+ #{s 34108}#
+ #f)
+ (set-source-properties!
+ #{e 34105}#
+ #{s 34108}#))
+ #{e 34105}#)))
+ (if (if (null? (car #{w 34107}#))
+ (null? (cdr #{w 34107}#))
+ #f)
+ #{x 34866}#
+ (if (if (vector? #{x 34866}#)
+ (if (= (vector-length #{x 34866}#) 4)
+ (eq? (vector-ref #{x 34866}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 34898}#
+ (vector-ref #{x 34866}# 1))
+ (#{wrap 34899}#
+ (let ((#{w2 34907}#
+ (vector-ref
+ #{x 34866}#
+ 2)))
+ (let ((#{m1 34908}#
+ (car #{w 34107}#))
+ (#{s1 34909}#
+ (cdr #{w 34107}#)))
+ (if (null? #{m1 34908}#)
+ (if (null? #{s1 34909}#)
+ #{w2 34907}#
+ (cons (car #{w2 34907}#)
+ (let ((#{m2 34924}#
+ (cdr #{w2 34907}#)))
+ (if (null? #{m2 34924}#)
+ #{s1 34909}#
+ (append
+ #{s1 34909}#
+ #{m2 34924}#)))))
+ (cons (let ((#{m2 34932}#
+ (car #{w2 34907}#)))
+ (if (null? #{m2 34932}#)
+ #{m1 34908}#
+ (append
+ #{m1 34908}#
+ #{m2 34932}#)))
+ (let ((#{m2 34940}#
+ (cdr #{w2 34907}#)))
+ (if (null? #{m2 34940}#)
+ #{s1 34909}#
+ (append
+ #{s1 34909}#
+ #{m2 34940}#))))))))
+ (#{module 34900}#
+ (vector-ref #{x 34866}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 34898}#
+ #{wrap 34899}#
+ #{module 34900}#))
+ (if (null? #{x 34866}#)
+ #{x 34866}#
+ (vector
+ 'syntax-object
+ #{x 34866}#
+ #{w 34107}#
+ #{mod 34109}#)))))))))))))
+ #{tmp 34111}#)
+ (let ((#{tmp 34955}#
+ ($sc-dispatch
+ #{e 34105}#
+ '(_ (any . each-any) any))))
+ (if #{tmp 34955}#
(@apply
- (lambda (#{mod 9814}# #{exp 9815}#)
- (let ((#{mod 9816}#
- (syntax->datum
- (cons '#(syntax-object
- private
+ (lambda (#{head 34959}# #{tail 34960}# #{val 34961}#)
+ (call-with-values
+ (lambda ()
+ (#{syntax-type 28270}#
+ #{head 34959}#
+ #{r 34106}#
+ '(())
+ #f
+ #f
+ #{mod 34109}#
+ #t))
+ (lambda (#{type 34964}#
+ #{value 34965}#
+ #{ee 34966}#
+ #{ww 34967}#
+ #{ss 34968}#
+ #{modmod 34969}#)
+ (if (eqv? #{type 34964}# 'module-ref)
+ (let ((#{val 34973}#
+ (#{expand 28271}#
+ #{val 34961}#
+ #{r 34106}#
+ #{w 34107}#
+ #{mod 34109}#)))
+ (call-with-values
+ (lambda ()
+ (#{value 34965}#
+ (cons #{head 34959}# #{tail 34960}#)
+ #{r 34106}#
+ #{w 34107}#))
+ (lambda (#{e 34974}#
+ #{r 34975}#
+ #{w 34976}#
+ #{s* 34977}#
+ #{mod 34978}#)
+ (let ((#{tmp 34980}# (list #{e 34974}#)))
+ (if (@apply
+ (lambda (#{e 34982}#)
+ (if (symbol? #{e 34982}#)
+ #t
+ (if (if (vector? #{e 34982}#)
+ (if (= (vector-length
+ #{e 34982}#)
+ 4)
+ (eq? (vector-ref
+ #{e 34982}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol?
+ (vector-ref #{e 34982}# 1))
+ #f)))
+ #{tmp 34980}#)
+ (@apply
+ (lambda (#{e 35012}#)
+ (#{build-global-assignment 28212}#
+ #{s 34108}#
+ (syntax->datum #{e 35012}#)
+ #{val 34973}#
+ #{mod 34978}#))
+ #{tmp 34980}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 34974}#))))))
+ (#{build-call 28205}#
+ #{s 34108}#
+ (#{expand 28271}#
+ (list '#(syntax-object
+ setter
((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
#(ribcage
- #(mod exp)
- #((top) (top))
- #("i3704" "i3705"))
- #(ribcage
- (remodulate)
- ((top))
- ("i3671"))
+ #(type value ee ww ss modmod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("i27483"
+ "i27484"
+ "i27485"
+ "i27486"
+ "i27487"
+ "i27488"))
#(ribcage
- #(e r w)
+ #(head tail val)
#((top) (top) (top))
- #("i3668" "i3669" "i3670"))
+ #("i27469" "i27470" "i27471"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e r w s mod)
+ #((top) (top) (top) (top) (top))
+ #("i27441"
+ "i27442"
+ "i27443"
+ "i27444"
+ "i27445"))
#(ribcage
(lambda-var-list
gen-var
@@ -10623,7 +11186,7 @@
expand-local-syntax
expand-body
expand-macro
- expand-application
+ expand-call
expand-expr
expand
syntax-type
@@ -10638,8 +11201,6 @@
valid-bound-ids?
bound-id=?
free-id=?
- with-transformer-environment
- transformer-environment
resolve-identifier
id-var-name
same-marks?
@@ -10678,7 +11239,6 @@
id?
nonsymbol-id?
global-extend
- lookup
macros-only-env
extend-var-env
extend-env
@@ -10704,6 +11264,7 @@
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
@@ -10715,7 +11276,7 @@
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
@@ -10736,8 +11297,9 @@
make-let
make-lambda-case
make-lambda
- make-sequence
- make-application
+ make-seq
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
@@ -10886,1310 +11448,3625 @@
(top)
(top)
(top)
- (top)
(top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
#(ribcage
(define-structure
define-expansion-accessors
define-expansion-constructors)
((top) (top) (top))
- ("i46" "i45" "i44")))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
(hygiene guile))
- #{mod 9814}#))))
- (values
- (#{remodulate 9791}# #{exp 9815}# #{mod 9816}#)
- #{r 9789}#
- #{w 9790}#
- (#{source-annotation 4408}# #{exp 9815}#)
- #{mod 9816}#)))
- #{tmp 9793}#)
+ #{head 34959}#)
+ #{r 34106}#
+ #{w 34107}#
+ #{mod 34109}#)
+ (map (lambda (#{e 35325}#)
+ (#{expand 28271}#
+ #{e 35325}#
+ #{r 34106}#
+ #{w 34107}#
+ #{mod 34109}#))
+ (append
+ #{tail 34960}#
+ (list #{val 34961}#))))))))
+ #{tmp 34955}#)
(syntax-violation
- #f
- "source expression failed to match any pattern"
- #{e 9788}#))))))
- (#{global-extend 4413}#
- 'core
- 'if
- (lambda (#{e 10000}#
- #{r 10001}#
- #{w 10002}#
- #{s 10003}#
- #{mod 10004}#)
- (let ((#{tmp 10006}#
- ($sc-dispatch #{e 10000}# '(_ any any))))
- (if #{tmp 10006}#
- (@apply
- (lambda (#{test 10010}# #{then 10011}#)
- (#{build-conditional 4383}#
- #{s 10003}#
- (#{expand 4450}#
- #{test 10010}#
- #{r 10001}#
- #{w 10002}#
- #{mod 10004}#)
- (#{expand 4450}#
- #{then 10011}#
- #{r 10001}#
- #{w 10002}#
- #{mod 10004}#)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- #f)))
- #{tmp 10006}#)
- (let ((#{tmp 10236}#
- ($sc-dispatch #{e 10000}# '(_ any any any))))
- (if #{tmp 10236}#
+ 'set!
+ "bad set!"
+ (let ((#{x 35413}#
+ (begin
+ (if (if (pair? #{e 34105}#) #{s 34108}# #f)
+ (set-source-properties! #{e 34105}# #{s 34108}#))
+ #{e 34105}#)))
+ (if (if (null? (car #{w 34107}#))
+ (null? (cdr #{w 34107}#))
+ #f)
+ #{x 35413}#
+ (if (if (vector? #{x 35413}#)
+ (if (= (vector-length #{x 35413}#) 4)
+ (eq? (vector-ref #{x 35413}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 35445}# (vector-ref #{x 35413}# 1))
+ (#{wrap 35446}#
+ (let ((#{w2 35454}#
+ (vector-ref #{x 35413}# 2)))
+ (let ((#{m1 35455}# (car #{w 34107}#))
+ (#{s1 35456}# (cdr #{w 34107}#)))
+ (if (null? #{m1 35455}#)
+ (if (null? #{s1 35456}#)
+ #{w2 35454}#
+ (cons (car #{w2 35454}#)
+ (let ((#{m2 35471}#
+ (cdr #{w2 35454}#)))
+ (if (null? #{m2 35471}#)
+ #{s1 35456}#
+ (append
+ #{s1 35456}#
+ #{m2 35471}#)))))
+ (cons (let ((#{m2 35479}#
+ (car #{w2 35454}#)))
+ (if (null? #{m2 35479}#)
+ #{m1 35455}#
+ (append
+ #{m1 35455}#
+ #{m2 35479}#)))
+ (let ((#{m2 35487}#
+ (cdr #{w2 35454}#)))
+ (if (null? #{m2 35487}#)
+ #{s1 35456}#
+ (append
+ #{s1 35456}#
+ #{m2 35487}#))))))))
+ (#{module 35447}# (vector-ref #{x 35413}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 35445}#
+ #{wrap 35446}#
+ #{module 35447}#))
+ (if (null? #{x 35413}#)
+ #{x 35413}#
+ (vector
+ 'syntax-object
+ #{x 35413}#
+ #{w 34107}#
+ #{mod 34109}#))))))))))))
+ (module-define!
+ (current-module)
+ '@
+ (make-syntax-transformer
+ '@
+ 'module-ref
+ (lambda (#{e 35518}# #{r 35519}# #{w 35520}#)
+ (let ((#{tmp 35522}#
+ ($sc-dispatch #{e 35518}# '(_ each-any any))))
+ (if (if #{tmp 35522}#
(@apply
- (lambda (#{test 10240}# #{then 10241}# #{else 10242}#)
- (#{build-conditional 4383}#
- #{s 10003}#
- (#{expand 4450}#
- #{test 10240}#
- #{r 10001}#
- #{w 10002}#
- #{mod 10004}#)
- (#{expand 4450}#
- #{then 10241}#
- #{r 10001}#
- #{w 10002}#
- #{mod 10004}#)
- (#{expand 4450}#
- #{else 10242}#
- #{r 10001}#
- #{w 10002}#
- #{mod 10004}#)))
- #{tmp 10236}#)
- (syntax-violation
+ (lambda (#{mod 35525}# #{id 35526}#)
+ (if (and-map #{id? 28238}# #{mod 35525}#)
+ (if (symbol? #{id 35526}#)
+ #t
+ (if (if (vector? #{id 35526}#)
+ (if (= (vector-length #{id 35526}#) 4)
+ (eq? (vector-ref #{id 35526}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref #{id 35526}# 1))
+ #f))
+ #f))
+ #{tmp 35522}#)
+ #f)
+ (@apply
+ (lambda (#{mod 35566}# #{id 35567}#)
+ (values
+ (syntax->datum #{id 35567}#)
+ #{r 35519}#
+ #{w 35520}#
#f
- "source expression failed to match any pattern"
- #{e 10000}#)))))))
- (#{global-extend 4413}#
- 'core
- 'with-fluids
- (lambda (#{e 10641}#
- #{r 10642}#
- #{w 10643}#
- #{s 10644}#
- #{mod 10645}#)
- (let ((#{tmp 10647}#
- ($sc-dispatch
- #{e 10641}#
- '(_ #(each (any any)) any . each-any))))
- (if #{tmp 10647}#
+ (syntax->datum
+ (cons '#(syntax-object
+ public
+ ((top)
+ #(ribcage
+ #(mod id)
+ #((top) (top))
+ #("i27530" "i27531"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e r w)
+ #((top) (top) (top))
+ #("i27518" "i27519" "i27520"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile))
+ #{mod 35566}#))))
+ #{tmp 35522}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 35518}#))))))
+ (#{global-extend 28236}#
+ 'module-ref
+ '@@
+ (lambda (#{e 35667}# #{r 35668}# #{w 35669}#)
+ (letrec*
+ ((#{remodulate 35670}#
+ (lambda (#{x 35888}# #{mod 35889}#)
+ (if (pair? #{x 35888}#)
+ (cons (#{remodulate 35670}#
+ (car #{x 35888}#)
+ #{mod 35889}#)
+ (#{remodulate 35670}#
+ (cdr #{x 35888}#)
+ #{mod 35889}#))
+ (if (if (vector? #{x 35888}#)
+ (if (= (vector-length #{x 35888}#) 4)
+ (eq? (vector-ref #{x 35888}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 35903}#
+ (#{remodulate 35670}#
+ (vector-ref #{x 35888}# 1)
+ #{mod 35889}#))
+ (#{wrap 35904}# (vector-ref #{x 35888}# 2)))
+ (vector
+ 'syntax-object
+ #{expression 35903}#
+ #{wrap 35904}#
+ #{mod 35889}#))
+ (if (vector? #{x 35888}#)
+ (let ((#{n 35912}# (vector-length #{x 35888}#)))
+ (let ((#{v 35913}# (make-vector #{n 35912}#)))
+ (letrec*
+ ((#{loop 35914}#
+ (lambda (#{i 35969}#)
+ (if (= #{i 35969}# #{n 35912}#)
+ #{v 35913}#
+ (begin
+ (vector-set!
+ #{v 35913}#
+ #{i 35969}#
+ (#{remodulate 35670}#
+ (vector-ref #{x 35888}# #{i 35969}#)
+ #{mod 35889}#))
+ (#{loop 35914}# (#{1+}# #{i 35969}#)))))))
+ (#{loop 35914}# 0))))
+ #{x 35888}#))))))
+ (let ((#{tmp 35672}#
+ ($sc-dispatch #{e 35667}# '(_ each-any any))))
+ (if (if #{tmp 35672}#
+ (@apply
+ (lambda (#{mod 35676}# #{exp 35677}#)
+ (and-map #{id? 28238}# #{mod 35676}#))
+ #{tmp 35672}#)
+ #f)
(@apply
- (lambda (#{fluid 10651}#
- #{val 10652}#
- #{b 10653}#
- #{b* 10654}#)
- (#{build-dynlet 4384}#
- #{s 10644}#
- (map (lambda (#{x 10735}#)
- (#{expand 4450}#
- #{x 10735}#
- #{r 10642}#
- #{w 10643}#
- #{mod 10645}#))
- #{fluid 10651}#)
- (map (lambda (#{x 10805}#)
- (#{expand 4450}#
- #{x 10805}#
- #{r 10642}#
- #{w 10643}#
- #{mod 10645}#))
- #{val 10652}#)
- (#{expand-body 4454}#
- (cons #{b 10653}# #{b* 10654}#)
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 10641}#) #{s 10644}# #f)
- (set-source-properties! #{e 10641}# #{s 10644}#))
- #{e 10641}#)
- #{w 10643}#
- #{mod 10645}#)
- #{r 10642}#
- #{w 10643}#
- #{mod 10645}#)))
- #{tmp 10647}#)
+ (lambda (#{mod 35693}# #{exp 35694}#)
+ (let ((#{mod 35695}#
+ (syntax->datum
+ (cons '#(syntax-object
+ private
+ ((top)
+ #(ribcage
+ #(mod exp)
+ #((top) (top))
+ #("i27574" "i27575"))
+ #(ribcage
+ (remodulate)
+ ((top))
+ ("i27541"))
+ #(ribcage
+ #(e r w)
+ #((top) (top) (top))
+ #("i27538" "i27539" "i27540"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile))
+ #{mod 35693}#))))
+ (values
+ (#{remodulate 35670}#
+ #{exp 35694}#
+ #{mod 35695}#)
+ #{r 35668}#
+ #{w 35669}#
+ (#{source-annotation 28232}# #{exp 35694}#)
+ #{mod 35695}#)))
+ #{tmp 35672}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{e 10641}#)))))
- (module-define!
- (current-module)
- 'begin
- (make-syntax-transformer 'begin 'begin '()))
- (module-define!
- (current-module)
- 'define
- (make-syntax-transformer 'define 'define '()))
- (module-define!
- (current-module)
+ #{e 35667}#))))))
+ (#{global-extend 28236}#
+ 'core
+ 'if
+ (lambda (#{e 36078}#
+ #{r 36079}#
+ #{w 36080}#
+ #{s 36081}#
+ #{mod 36082}#)
+ (let ((#{tmp 36084}#
+ ($sc-dispatch #{e 36078}# '(_ any any))))
+ (if #{tmp 36084}#
+ (@apply
+ (lambda (#{test 36088}# #{then 36089}#)
+ (#{build-conditional 28206}#
+ #{s 36081}#
+ (#{expand 28271}#
+ #{test 36088}#
+ #{r 36079}#
+ #{w 36080}#
+ #{mod 36082}#)
+ (#{expand 28271}#
+ #{then 36089}#
+ #{r 36079}#
+ #{w 36080}#
+ #{mod 36082}#)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 0)
+ #f)))
+ #{tmp 36084}#)
+ (let ((#{tmp 36338}#
+ ($sc-dispatch #{e 36078}# '(_ any any any))))
+ (if #{tmp 36338}#
+ (@apply
+ (lambda (#{test 36342}# #{then 36343}# #{else 36344}#)
+ (#{build-conditional 28206}#
+ #{s 36081}#
+ (#{expand 28271}#
+ #{test 36342}#
+ #{r 36079}#
+ #{w 36080}#
+ #{mod 36082}#)
+ (#{expand 28271}#
+ #{then 36343}#
+ #{r 36079}#
+ #{w 36080}#
+ #{mod 36082}#)
+ (#{expand 28271}#
+ #{else 36344}#
+ #{r 36079}#
+ #{w 36080}#
+ #{mod 36082}#)))
+ #{tmp 36338}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 36078}#)))))))
+ (#{global-extend 28236}#
+ 'core
+ 'with-fluids
+ (lambda (#{e 36783}#
+ #{r 36784}#
+ #{w 36785}#
+ #{s 36786}#
+ #{mod 36787}#)
+ (let ((#{tmp 36789}#
+ ($sc-dispatch
+ #{e 36783}#
+ '(_ #(each (any any)) any . each-any))))
+ (if #{tmp 36789}#
+ (@apply
+ (lambda (#{fluid 36793}#
+ #{val 36794}#
+ #{b 36795}#
+ #{b* 36796}#)
+ (#{build-dynlet 28207}#
+ #{s 36786}#
+ (map (lambda (#{x 36885}#)
+ (#{expand 28271}#
+ #{x 36885}#
+ #{r 36784}#
+ #{w 36785}#
+ #{mod 36787}#))
+ #{fluid 36793}#)
+ (map (lambda (#{x 36963}#)
+ (#{expand 28271}#
+ #{x 36963}#
+ #{r 36784}#
+ #{w 36785}#
+ #{mod 36787}#))
+ #{val 36794}#)
+ (#{expand-body 28275}#
+ (cons #{b 36795}# #{b* 36796}#)
+ (let ((#{x 37052}#
+ (begin
+ (if (if (pair? #{e 36783}#) #{s 36786}# #f)
+ (set-source-properties!
+ #{e 36783}#
+ #{s 36786}#))
+ #{e 36783}#)))
+ (if (if (null? (car #{w 36785}#))
+ (null? (cdr #{w 36785}#))
+ #f)
+ #{x 37052}#
+ (if (if (vector? #{x 37052}#)
+ (if (= (vector-length #{x 37052}#) 4)
+ (eq? (vector-ref #{x 37052}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 37084}#
+ (vector-ref #{x 37052}# 1))
+ (#{wrap 37085}#
+ (let ((#{w2 37093}#
+ (vector-ref #{x 37052}# 2)))
+ (let ((#{m1 37094}# (car #{w 36785}#))
+ (#{s1 37095}# (cdr #{w 36785}#)))
+ (if (null? #{m1 37094}#)
+ (if (null? #{s1 37095}#)
+ #{w2 37093}#
+ (cons (car #{w2 37093}#)
+ (let ((#{m2 37110}#
+ (cdr #{w2 37093}#)))
+ (if (null? #{m2 37110}#)
+ #{s1 37095}#
+ (append
+ #{s1 37095}#
+ #{m2 37110}#)))))
+ (cons (let ((#{m2 37118}#
+ (car #{w2 37093}#)))
+ (if (null? #{m2 37118}#)
+ #{m1 37094}#
+ (append
+ #{m1 37094}#
+ #{m2 37118}#)))
+ (let ((#{m2 37126}#
+ (cdr #{w2 37093}#)))
+ (if (null? #{m2 37126}#)
+ #{s1 37095}#
+ (append
+ #{s1 37095}#
+ #{m2 37126}#))))))))
+ (#{module 37086}# (vector-ref #{x 37052}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 37084}#
+ #{wrap 37085}#
+ #{module 37086}#))
+ (if (null? #{x 37052}#)
+ #{x 37052}#
+ (vector
+ 'syntax-object
+ #{x 37052}#
+ #{w 36785}#
+ #{mod 36787}#)))))
+ #{r 36784}#
+ #{w 36785}#
+ #{mod 36787}#)))
+ #{tmp 36789}#)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ #{e 36783}#)))))
+ (module-define!
+ (current-module)
+ 'begin
+ (make-syntax-transformer 'begin 'begin '()))
+ (module-define!
+ (current-module)
+ 'define
+ (make-syntax-transformer 'define 'define '()))
+ (module-define!
+ (current-module)
+ 'define-syntax
+ (make-syntax-transformer
'define-syntax
- (make-syntax-transformer
- 'define-syntax
- 'define-syntax
- '()))
- (module-define!
- (current-module)
+ 'define-syntax
+ '()))
+ (module-define!
+ (current-module)
+ 'define-syntax-parameter
+ (make-syntax-transformer
+ 'define-syntax-parameter
'define-syntax-parameter
- (make-syntax-transformer
- 'define-syntax-parameter
- 'define-syntax-parameter
- '()))
- (module-define!
- (current-module)
+ '()))
+ (module-define!
+ (current-module)
+ 'eval-when
+ (make-syntax-transformer
'eval-when
- (make-syntax-transformer
- 'eval-when
- 'eval-when
- '()))
- (#{global-extend 4413}#
- 'core
- 'syntax-case
- (letrec*
- ((#{convert-pattern 11173}#
- (lambda (#{pattern 12770}# #{keys 12771}#)
- (letrec*
- ((#{cvt* 12772}#
- (lambda (#{p* 13396}# #{n 13397}# #{ids 13398}#)
- (if (not (pair? #{p* 13396}#))
- (#{cvt 12774}#
- #{p* 13396}#
- #{n 13397}#
- #{ids 13398}#)
- (call-with-values
- (lambda ()
- (#{cvt* 12772}#
- (cdr #{p* 13396}#)
- #{n 13397}#
- #{ids 13398}#))
- (lambda (#{y 13401}# #{ids 13402}#)
- (call-with-values
- (lambda ()
- (#{cvt 12774}#
- (car #{p* 13396}#)
- #{n 13397}#
- #{ids 13402}#))
- (lambda (#{x 13405}# #{ids 13406}#)
- (values
- (cons #{x 13405}# #{y 13401}#)
- #{ids 13406}#))))))))
- (#{v-reverse 12773}#
- (lambda (#{x 13407}#)
- (letrec*
- ((#{loop 13408}#
- (lambda (#{r 13488}# #{x 13489}#)
- (if (not (pair? #{x 13489}#))
- (values #{r 13488}# #{x 13489}#)
- (#{loop 13408}#
- (cons (car #{x 13489}#) #{r 13488}#)
- (cdr #{x 13489}#))))))
- (#{loop 13408}# '() #{x 13407}#))))
- (#{cvt 12774}#
- (lambda (#{p 12777}# #{n 12778}# #{ids 12779}#)
- (if (if (symbol? #{p 12777}#)
- #t
- (if (if (vector? #{p 12777}#)
- (if (= (vector-length #{p 12777}#) 4)
- (eq? (vector-ref #{p 12777}# 0)
- 'syntax-object)
- #f)
+ 'eval-when
+ '()))
+ (#{global-extend 28236}#
+ 'core
+ 'syntax-case
+ (letrec*
+ ((#{convert-pattern 37426}#
+ (lambda (#{pattern 39048}# #{keys 39049}#)
+ (letrec*
+ ((#{cvt* 39050}#
+ (lambda (#{p* 39849}# #{n 39850}# #{ids 39851}#)
+ (if (not (pair? #{p* 39849}#))
+ (#{cvt 39052}#
+ #{p* 39849}#
+ #{n 39850}#
+ #{ids 39851}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt* 39050}#
+ (cdr #{p* 39849}#)
+ #{n 39850}#
+ #{ids 39851}#))
+ (lambda (#{y 39854}# #{ids 39855}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt 39052}#
+ (car #{p* 39849}#)
+ #{n 39850}#
+ #{ids 39855}#))
+ (lambda (#{x 39858}# #{ids 39859}#)
+ (values
+ (cons #{x 39858}# #{y 39854}#)
+ #{ids 39859}#))))))))
+ (#{v-reverse 39051}#
+ (lambda (#{x 39860}#)
+ (letrec*
+ ((#{loop 39861}#
+ (lambda (#{r 39962}# #{x 39963}#)
+ (if (not (pair? #{x 39963}#))
+ (values #{r 39962}# #{x 39963}#)
+ (#{loop 39861}#
+ (cons (car #{x 39963}#) #{r 39962}#)
+ (cdr #{x 39963}#))))))
+ (#{loop 39861}# '() #{x 39860}#))))
+ (#{cvt 39052}#
+ (lambda (#{p 39055}# #{n 39056}# #{ids 39057}#)
+ (if (if (symbol? #{p 39055}#)
+ #t
+ (if (if (vector? #{p 39055}#)
+ (if (= (vector-length #{p 39055}#) 4)
+ (eq? (vector-ref #{p 39055}# 0)
+ 'syntax-object)
#f)
- (symbol? (vector-ref #{p 12777}# 1))
- #f))
- (if (#{bound-id-member? 4442}#
- #{p 12777}#
- #{keys 12771}#)
+ #f)
+ (symbol? (vector-ref #{p 39055}# 1))
+ #f))
+ (if (#{bound-id-member? 28263}#
+ #{p 39055}#
+ #{keys 39049}#)
+ (values
+ (vector 'free-id #{p 39055}#)
+ #{ids 39057}#)
+ (if (#{free-id=? 28259}#
+ #{p 39055}#
+ '#(syntax-object
+ _
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p n ids)
+ #((top) (top) (top))
+ #("i27675" "i27676" "i27677"))
+ #(ribcage
+ (cvt v-reverse cvt*)
+ ((top) (top) (top))
+ ("i27648" "i27646" "i27644"))
+ #(ribcage
+ #(pattern keys)
+ #((top) (top))
+ #("i27642" "i27643"))
+ #(ribcage
+ (gen-syntax-case
+ gen-clause
+ build-dispatch-call
+ convert-pattern)
+ ((top) (top) (top) (top))
+ ("i27638" "i27636" "i27634" "i27632"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ (values '_ #{ids 39057}#)
(values
- (vector 'free-id #{p 12777}#)
- #{ids 12779}#)
- (if (if (eq? (if (if (vector? #{p 12777}#)
- (if (= (vector-length #{p 12777}#)
- 4)
- (eq? (vector-ref #{p 12777}# 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref #{p 12777}# 1)
- #{p 12777}#)
- (if (if (= (vector-length
- '#(syntax-object
- _
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p n ids)
- #((top) (top) (top))
- #("i3805"
- "i3806"
- "i3807"))
- #(ribcage
- (cvt v-reverse cvt*)
- ((top) (top) (top))
- ("i3778"
- "i3776"
- "i3774"))
- #(ribcage
- #(pattern keys)
- #((top) (top))
- #("i3772" "i3773"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top)
- (top)
- (top)
- (top))
- ("i3768"
- "i3766"
- "i3764"
- "i3762"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile)))
- 4)
- #t
- #f)
- '_
- '#(syntax-object
- _
+ 'any
+ (cons (cons #{p 39055}# #{n 39056}#)
+ #{ids 39057}#))))
+ (let ((#{tmp 39189}#
+ ($sc-dispatch #{p 39055}# '(any any))))
+ (if (if #{tmp 39189}#
+ (@apply
+ (lambda (#{x 39193}# #{dots 39194}#)
+ (if (if (if (vector? #{dots 39194}#)
+ (if (= (vector-length
+ #{dots 39194}#)
+ 4)
+ (eq? (vector-ref
+ #{dots 39194}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref #{dots 39194}# 1))
+ #f)
+ (#{free-id=? 28259}#
+ #{dots 39194}#
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i26166"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
((top)
- #(ribcage () () ())
- #(ribcage
- #(p n ids)
- #((top) (top) (top))
- #("i3805" "i3806" "i3807"))
- #(ribcage
- (cvt v-reverse cvt*)
- ((top) (top) (top))
- ("i3778" "i3776" "i3774"))
- #(ribcage
- #(pattern keys)
- #((top) (top))
- #("i3772" "i3773"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("i3768"
- "i3766"
- "i3764"
- "i3762"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))))
- (eq? (#{id-var-name 4434}# #{p 12777}# '(()))
- (#{id-var-name 4434}#
- '#(syntax-object
- _
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ #f))
+ #{tmp 39189}#)
+ #f)
+ (@apply
+ (lambda (#{x 39233}# #{dots 39234}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt 39052}#
+ #{x 39233}#
+ (#{1+}# #{n 39056}#)
+ #{ids 39057}#))
+ (lambda (#{p 39235}# #{ids 39236}#)
+ (values
+ (if (eq? #{p 39235}# 'any)
+ 'each-any
+ (vector 'each #{p 39235}#))
+ #{ids 39236}#))))
+ #{tmp 39189}#)
+ (let ((#{tmp 39237}#
+ ($sc-dispatch #{p 39055}# '(any any . any))))
+ (if (if #{tmp 39237}#
+ (@apply
+ (lambda (#{x 39241}#
+ #{dots 39242}#
+ #{ys 39243}#)
+ (if (if (if (vector? #{dots 39242}#)
+ (if (= (vector-length
+ #{dots 39242}#)
+ 4)
+ (eq? (vector-ref
+ #{dots 39242}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol?
+ (vector-ref #{dots 39242}# 1))
+ #f)
+ (#{free-id=? 28259}#
+ #{dots 39242}#
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i26166"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ #f))
+ #{tmp 39237}#)
+ #f)
+ (@apply
+ (lambda (#{x 39282}#
+ #{dots 39283}#
+ #{ys 39284}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt* 39050}#
+ #{ys 39284}#
+ #{n 39056}#
+ #{ids 39057}#))
+ (lambda (#{ys 39769}# #{ids 39770}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt 39052}#
+ #{x 39282}#
+ (#{1+}# #{n 39056}#)
+ #{ids 39770}#))
+ (lambda (#{x 39771}# #{ids 39772}#)
+ (call-with-values
+ (lambda ()
+ (#{v-reverse 39051}#
+ #{ys 39769}#))
+ (lambda (#{ys 39808}# #{e 39809}#)
+ (values
+ (vector
+ 'each+
+ #{x 39771}#
+ #{ys 39808}#
+ #{e 39809}#)
+ #{ids 39772}#))))))))
+ #{tmp 39237}#)
+ (let ((#{tmp 39810}#
+ ($sc-dispatch #{p 39055}# '(any . any))))
+ (if #{tmp 39810}#
+ (@apply
+ (lambda (#{x 39814}# #{y 39815}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt 39052}#
+ #{y 39815}#
+ #{n 39056}#
+ #{ids 39057}#))
+ (lambda (#{y 39816}# #{ids 39817}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt 39052}#
+ #{x 39814}#
+ #{n 39056}#
+ #{ids 39817}#))
+ (lambda (#{x 39818}# #{ids 39819}#)
+ (values
+ (cons #{x 39818}# #{y 39816}#)
+ #{ids 39819}#))))))
+ #{tmp 39810}#)
+ (let ((#{tmp 39820}#
+ ($sc-dispatch #{p 39055}# '())))
+ (if #{tmp 39820}#
+ (@apply
+ (lambda () (values '() #{ids 39057}#))
+ #{tmp 39820}#)
+ (let ((#{tmp 39824}#
+ ($sc-dispatch
+ #{p 39055}#
+ '#(vector each-any))))
+ (if #{tmp 39824}#
+ (@apply
+ (lambda (#{x 39828}#)
+ (call-with-values
+ (lambda ()
+ (#{cvt 39052}#
+ #{x 39828}#
+ #{n 39056}#
+ #{ids 39057}#))
+ (lambda (#{p 39829}#
+ #{ids 39830}#)
+ (values
+ (vector
+ 'vector
+ #{p 39829}#)
+ #{ids 39830}#))))
+ #{tmp 39824}#)
+ (values
+ (vector
+ 'atom
+ (#{strip 28284}#
+ #{p 39055}#
+ '(())))
+ #{ids 39057}#)))))))))))))))
+ (#{cvt 39052}# #{pattern 39048}# 0 '()))))
+ (#{build-dispatch-call 37427}#
+ (lambda (#{pvars 39964}#
+ #{exp 39965}#
+ #{y 39966}#
+ #{r 39967}#
+ #{mod 39968}#)
+ (let ((#{ids 39969}# (map car #{pvars 39964}#)))
+ (begin
+ (map cdr #{pvars 39964}#)
+ (let ((#{labels 39971}#
+ (#{gen-labels 28241}# #{ids 39969}#))
+ (#{new-vars 39972}#
+ (map #{gen-var 28285}# #{ids 39969}#)))
+ (#{build-primcall 28217}#
+ #f
+ 'apply
+ (list (#{build-simple-lambda 28214}#
+ #f
+ (map syntax->datum #{ids 39969}#)
+ #f
+ #{new-vars 39972}#
+ '()
+ (#{expand 28271}#
+ #{exp 39965}#
+ (#{extend-env 28233}#
+ #{labels 39971}#
+ (map (lambda (#{var 40304}# #{level 40305}#)
+ (cons 'syntax
+ (cons #{var 40304}#
+ #{level 40305}#)))
+ #{new-vars 39972}#
+ (map cdr #{pvars 39964}#))
+ #{r 39967}#)
+ (#{make-binding-wrap 28252}#
+ #{ids 39969}#
+ #{labels 39971}#
+ '(()))
+ #{mod 39968}#))
+ #{y 39966}#)))))))
+ (#{gen-clause 37428}#
+ (lambda (#{x 38632}#
+ #{keys 38633}#
+ #{clauses 38634}#
+ #{r 38635}#
+ #{pat 38636}#
+ #{fender 38637}#
+ #{exp 38638}#
+ #{mod 38639}#)
+ (call-with-values
+ (lambda ()
+ (#{convert-pattern 37426}#
+ #{pat 38636}#
+ #{keys 38633}#))
+ (lambda (#{p 38777}# #{pvars 38778}#)
+ (if (not (#{distinct-bound-ids? 28262}#
+ (map car #{pvars 38778}#)))
+ (syntax-violation
+ 'syntax-case
+ "duplicate pattern variable"
+ #{pat 38636}#)
+ (if (not (and-map
+ (lambda (#{x 38887}#)
+ (not (let ((#{x 38891}# (car #{x 38887}#)))
+ (if (if (if (vector? #{x 38891}#)
+ (if (= (vector-length
+ #{x 38891}#)
+ 4)
+ (eq? (vector-ref
+ #{x 38891}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol?
+ (vector-ref #{x 38891}# 1))
+ #f)
+ (#{free-id=? 28259}#
+ #{x 38891}#
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("i26166"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ #f))))
+ #{pvars 38778}#))
+ (syntax-violation
+ 'syntax-case
+ "misplaced ellipsis"
+ #{pat 38636}#)
+ (let ((#{y 38916}#
+ (gensym
+ (string-append (symbol->string 'tmp) " "))))
+ (let ((#{fun-exp 38921}#
+ (let ((#{req 38930}# (list 'tmp))
+ (#{vars 38932}# (list #{y 38916}#))
+ (#{exp 38934}#
+ (let ((#{y 38963}#
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 3)
+ #f
+ 'tmp
+ #{y 38916}#)))
+ (let ((#{test-exp 38967}#
+ (let ((#{tmp 38976}#
+ ($sc-dispatch
+ #{fender 38637}#
+ '#(atom #t))))
+ (if #{tmp 38976}#
+ (@apply
+ (lambda () #{y 38963}#)
+ #{tmp 38976}#)
+ (let ((#{then-exp 38994}#
+ (#{build-dispatch-call 37427}#
+ #{pvars 38778}#
+ #{fender 38637}#
+ #{y 38963}#
+ #{r 38635}#
+ #{mod 38639}#))
+ (#{else-exp 38995}#
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 1)
+ #f
+ #f)))
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 10)
+ #f
+ #{y 38963}#
+ #{then-exp 38994}#
+ #{else-exp 38995}#)))))
+ (#{then-exp 38968}#
+ (#{build-dispatch-call 37427}#
+ #{pvars 38778}#
+ #{exp 38638}#
+ #{y 38963}#
+ #{r 38635}#
+ #{mod 38639}#))
+ (#{else-exp 38969}#
+ (#{gen-syntax-case 37429}#
+ #{x 38632}#
+ #{keys 38633}#
+ #{clauses 38634}#
+ #{r 38635}#
+ #{mod 38639}#)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 10)
+ #f
+ #{test-exp 38967}#
+ #{then-exp 38968}#
+ #{else-exp 38969}#)))))
+ (let ((#{body 38939}#
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 15)
+ #f
+ #{req 38930}#
+ #f
+ #f
+ #f
+ '()
+ #{vars 38932}#
+ #{exp 38934}#
+ #f)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 14)
+ #f
+ '()
+ #{body 38939}#))))
+ (#{arg-exps 38922}#
+ (list (if (eq? #{p 38777}# 'any)
+ (let ((#{args 39027}#
+ (list #{x 38632}#)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 12)
+ #f
+ 'list
+ #{args 39027}#))
+ (let ((#{args 39036}#
+ (list #{x 38632}#
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 1)
+ #f
+ #{p 38777}#))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 12)
+ #f
+ '$sc-dispatch
+ #{args 39036}#))))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 11)
+ #f
+ #{fun-exp 38921}#
+ #{arg-exps 38922}#)))))))))
+ (#{gen-syntax-case 37429}#
+ (lambda (#{x 38133}#
+ #{keys 38134}#
+ #{clauses 38135}#
+ #{r 38136}#
+ #{mod 38137}#)
+ (if (null? #{clauses 38135}#)
+ (let ((#{args 38143}#
+ (list (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #f
+ #f)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #f
+ "source expression failed to match any pattern")
+ #{x 38133}#)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 12)
+ #f
+ 'syntax-violation
+ #{args 38143}#))
+ (let ((#{tmp 38162}# (car #{clauses 38135}#)))
+ (let ((#{tmp 38163}#
+ ($sc-dispatch #{tmp 38162}# '(any any))))
+ (if #{tmp 38163}#
+ (@apply
+ (lambda (#{pat 38165}# #{exp 38166}#)
+ (if (if (if (symbol? #{pat 38165}#)
+ #t
+ (if (if (vector? #{pat 38165}#)
+ (if (= (vector-length #{pat 38165}#)
+ 4)
+ (eq? (vector-ref #{pat 38165}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref #{pat 38165}# 1))
+ #f))
+ (and-map
+ (lambda (#{x 38193}#)
+ (not (#{free-id=? 28259}#
+ #{pat 38165}#
+ #{x 38193}#)))
+ (cons '#(syntax-object
+ ...
((top)
- #(ribcage () () ())
- #(ribcage
- #(p n ids)
- #((top) (top) (top))
- #("i3805" "i3806" "i3807"))
- #(ribcage
- (cvt v-reverse cvt*)
- ((top) (top) (top))
- ("i3778" "i3776" "i3774"))
#(ribcage
- #(pattern keys)
+ #(pat exp)
#((top) (top))
- #("i3772" "i3773"))
+ #("i27835" "i27836"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x keys clauses r mod)
+ #((top) (top) (top) (top) (top))
+ #("i27825"
+ "i27826"
+ "i27827"
+ "i27828"
+ "i27829"))
#(ribcage
(gen-syntax-case
gen-clause
build-dispatch-call
convert-pattern)
((top) (top) (top) (top))
- ("i3768" "i3766" "i3764" "i3762"))
+ ("i27638"
+ "i27636"
+ "i27634"
+ "i27632"))
#(ribcage
(lambda-var-list
gen-var
@@ -12204,7 +15081,7 @@
expand-local-syntax
expand-body
expand-macro
- expand-application
+ expand-call
expand-expr
expand
syntax-type
@@ -12219,8 +15096,6 @@
valid-bound-ids?
bound-id=?
free-id=?
- with-transformer-environment
- transformer-environment
resolve-identifier
id-var-name
same-marks?
@@ -12259,7 +15134,6 @@
id?
nonsymbol-id?
global-extend
- lookup
macros-only-env
extend-var-env
extend-env
@@ -12285,6 +15159,7 @@
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
@@ -12296,7 +15171,7 @@
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
@@ -12317,8 +15192,9 @@
make-let
make-lambda-case
make-lambda
- make-sequence
- make-application
+ make-seq
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
@@ -12467,4672 +15343,1232 @@
(top)
(top)
(top)
- (top)
(top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
#(ribcage
(define-structure
define-expansion-accessors
define-expansion-constructors)
((top) (top) (top))
- ("i46" "i45" "i44")))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
(hygiene guile))
- '(())))
- #f)
- (values '_ #{ids 12779}#)
- (values
- 'any
- (cons (cons #{p 12777}# #{n 12778}#)
- #{ids 12779}#))))
- (let ((#{tmp 13099}#
- ($sc-dispatch #{p 12777}# '(any any))))
- (if (if #{tmp 13099}#
- (@apply
- (lambda (#{x 13103}# #{dots 13104}#)
- (if (if (if (vector? #{dots 13104}#)
- (if (= (vector-length
- #{dots 13104}#)
- 4)
- (eq? (vector-ref
- #{dots 13104}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref #{dots 13104}# 1))
- #f)
- (if (eq? (if (if (vector? #{dots 13104}#)
- (if (= (vector-length
- #{dots 13104}#)
- 4)
- (eq? (vector-ref
- #{dots 13104}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref #{dots 13104}# 1)
- #{dots 13104}#)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))))
- (eq? (#{id-var-name 4434}#
- #{dots 13104}#
- '(()))
- (#{id-var-name 4434}#
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))
- '(())))
- #f)
- #f))
- #{tmp 13099}#)
- #f)
- (@apply
- (lambda (#{x 13204}# #{dots 13205}#)
- (call-with-values
- (lambda ()
- (#{cvt 12774}#
- #{x 13204}#
- (#{1+}# #{n 12778}#)
- #{ids 12779}#))
- (lambda (#{p 13206}# #{ids 13207}#)
- (values
- (if (eq? #{p 13206}# 'any)
- 'each-any
- (vector 'each #{p 13206}#))
- #{ids 13207}#))))
- #{tmp 13099}#)
- (let ((#{tmp 13208}#
- ($sc-dispatch
- #{p 12777}#
- '(any any . any))))
- (if (if #{tmp 13208}#
- (@apply
- (lambda (#{x 13212}#
- #{dots 13213}#
- #{ys 13214}#)
- (if (if (if (vector? #{dots 13213}#)
- (if (= (vector-length
- #{dots 13213}#)
- 4)
- (eq? (vector-ref
- #{dots 13213}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref #{dots 13213}# 1))
- #f)
- (if (eq? (if (if (vector?
- #{dots 13213}#)
- (if (= (vector-length
- #{dots 13213}#)
- 4)
- (eq? (vector-ref
- #{dots 13213}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- #{dots 13213}#
- 1)
- #{dots 13213}#)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene guile))))
- (eq? (#{id-var-name 4434}#
- #{dots 13213}#
- '(()))
- (#{id-var-name 4434}#
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))
- '(())))
- #f)
- #f))
- #{tmp 13208}#)
- #f)
- (@apply
- (lambda (#{x 13314}#
- #{dots 13315}#
- #{ys 13316}#)
- (call-with-values
- (lambda ()
- (#{cvt* 12772}#
- #{ys 13316}#
- #{n 12778}#
- #{ids 12779}#))
- (lambda (#{ys 13319}# #{ids 13320}#)
- (call-with-values
- (lambda ()
- (#{cvt 12774}#
- #{x 13314}#
- (#{1+}# #{n 12778}#)
- #{ids 13320}#))
- (lambda (#{x 13321}# #{ids 13322}#)
- (call-with-values
- (lambda ()
- (#{v-reverse 12773}#
- #{ys 13319}#))
- (lambda (#{ys 13355}#
- #{e 13356}#)
- (values
- (vector
- 'each+
- #{x 13321}#
- #{ys 13355}#
- #{e 13356}#)
- #{ids 13322}#))))))))
- #{tmp 13208}#)
- (let ((#{tmp 13357}#
- ($sc-dispatch
- #{p 12777}#
- '(any . any))))
- (if #{tmp 13357}#
- (@apply
- (lambda (#{x 13361}# #{y 13362}#)
- (call-with-values
- (lambda ()
- (#{cvt 12774}#
- #{y 13362}#
- #{n 12778}#
- #{ids 12779}#))
- (lambda (#{y 13363}# #{ids 13364}#)
- (call-with-values
- (lambda ()
- (#{cvt 12774}#
- #{x 13361}#
- #{n 12778}#
- #{ids 13364}#))
- (lambda (#{x 13365}#
- #{ids 13366}#)
- (values
- (cons #{x 13365}#
- #{y 13363}#)
- #{ids 13366}#))))))
- #{tmp 13357}#)
- (let ((#{tmp 13367}#
- ($sc-dispatch #{p 12777}# '())))
- (if #{tmp 13367}#
- (@apply
- (lambda ()
- (values '() #{ids 12779}#))
- #{tmp 13367}#)
- (let ((#{tmp 13371}#
- ($sc-dispatch
- #{p 12777}#
- '#(vector each-any))))
- (if #{tmp 13371}#
- (@apply
- (lambda (#{x 13375}#)
- (call-with-values
- (lambda ()
- (#{cvt 12774}#
- #{x 13375}#
- #{n 12778}#
- #{ids 12779}#))
- (lambda (#{p 13376}#
- #{ids 13377}#)
- (values
- (vector
- 'vector
- #{p 13376}#)
- #{ids 13377}#))))
- #{tmp 13371}#)
- (values
- (vector
- 'atom
- (#{strip 4463}#
- #{p 12777}#
- '(())))
- #{ids 12779}#)))))))))))))))
- (#{cvt 12774}# #{pattern 12770}# 0 '()))))
- (#{build-dispatch-call 11174}#
- (lambda (#{pvars 13490}#
- #{exp 13491}#
- #{y 13492}#
- #{r 13493}#
- #{mod 13494}#)
- (let ((#{ids 13495}# (map car #{pvars 13490}#)))
- (begin
- (map cdr #{pvars 13490}#)
- (let ((#{labels 13497}#
- (#{gen-labels 4418}# #{ids 13495}#))
- (#{new-vars 13498}#
- (map #{gen-var 4464}# #{ids 13495}#)))
- (#{build-application 4382}#
- #f
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- 'apply)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- 'apply
- #f))
- (list (#{build-simple-lambda 4391}#
- #f
- (map syntax->datum #{ids 13495}#)
- #f
- #{new-vars 13498}#
- '()
- (#{expand 4450}#
- #{exp 13491}#
- (#{extend-env 4409}#
- #{labels 13497}#
- (map (lambda (#{var 13823}# #{level 13824}#)
- (cons 'syntax
- (cons #{var 13823}#
- #{level 13824}#)))
- #{new-vars 13498}#
- (map cdr #{pvars 13490}#))
- #{r 13493}#)
- (#{make-binding-wrap 4429}#
- #{ids 13495}#
- #{labels 13497}#
- '(()))
- #{mod 13494}#))
- #{y 13492}#)))))))
- (#{gen-clause 11175}#
- (lambda (#{x 12142}#
- #{keys 12143}#
- #{clauses 12144}#
- #{r 12145}#
- #{pat 12146}#
- #{fender 12147}#
- #{exp 12148}#
- #{mod 12149}#)
- (call-with-values
- (lambda ()
- (#{convert-pattern 11173}#
- #{pat 12146}#
- #{keys 12143}#))
- (lambda (#{p 12304}# #{pvars 12305}#)
- (if (not (#{distinct-bound-ids? 4441}#
- (map car #{pvars 12305}#)))
- (syntax-violation
- 'syntax-case
- "duplicate pattern variable"
- #{pat 12146}#)
- (if (not (and-map
- (lambda (#{x 12421}#)
- (not (let ((#{x 12425}# (car #{x 12421}#)))
- (if (if (if (vector? #{x 12425}#)
+ #{keys 38134}#))
+ #f)
+ (if (#{free-id=? 28259}#
+ '#(syntax-object
+ pad
+ ((top)
+ #(ribcage
+ #(pat exp)
+ #((top) (top))
+ #("i27835" "i27836"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x keys clauses r mod)
+ #((top) (top) (top) (top) (top))
+ #("i27825"
+ "i27826"
+ "i27827"
+ "i27828"
+ "i27829"))
+ #(ribcage
+ (gen-syntax-case
+ gen-clause
+ build-dispatch-call
+ convert-pattern)
+ ((top) (top) (top) (top))
+ ("i27638" "i27636" "i27634" "i27632"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile))
+ '#(syntax-object
+ _
+ ((top)
+ #(ribcage
+ #(pat exp)
+ #((top) (top))
+ #("i27835" "i27836"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x keys clauses r mod)
+ #((top) (top) (top) (top) (top))
+ #("i27825"
+ "i27826"
+ "i27827"
+ "i27828"
+ "i27829"))
+ #(ribcage
+ (gen-syntax-case
+ gen-clause
+ build-dispatch-call
+ convert-pattern)
+ ((top) (top) (top) (top))
+ ("i27638" "i27636" "i27634" "i27632"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ resolve-identifier
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ gensym-hook
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ (#{expand 28271}#
+ #{exp 38166}#
+ #{r 38136}#
+ '(())
+ #{mod 38137}#)
+ (let ((#{labels 38275}#
+ (list (symbol->string (gensym "i"))))
+ (#{var 38276}#
+ (let ((#{id 38314}#
+ (if (if (vector? #{pat 38165}#)
(if (= (vector-length
- #{x 12425}#)
+ #{pat 38165}#)
4)
(eq? (vector-ref
- #{x 12425}#
+ #{pat 38165}#
0)
'syntax-object)
#f)
#f)
- (symbol?
- (vector-ref #{x 12425}# 1))
- #f)
- (if (eq? (if (if (vector?
- #{x 12425}#)
- (if (= (vector-length
- #{x 12425}#)
- 4)
- (eq? (vector-ref
- #{x 12425}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- #{x 12425}#
- 1)
- #{x 12425}#)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene guile))))
- (eq? (#{id-var-name 4434}#
- #{x 12425}#
- '(()))
- (#{id-var-name 4434}#
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))
- '(())))
- #f)
- #f))))
- #{pvars 12305}#))
- (syntax-violation
- 'syntax-case
- "misplaced ellipsis"
- #{pat 12146}#)
- (let ((#{y 12501}#
- (gensym
- (string-append (symbol->string 'tmp) " "))))
- (#{build-application 4382}#
- #f
- (let ((#{req 12644}# (list 'tmp))
- (#{vars 12646}# (list #{y 12501}#))
- (#{exp 12648}#
- (let ((#{y 12665}#
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- #f
- 'tmp
- #{y 12501}#)))
- (let ((#{test-exp 12669}#
- (let ((#{tmp 12678}#
- ($sc-dispatch
- #{fender 12147}#
- '#(atom #t))))
- (if #{tmp 12678}#
- (@apply
- (lambda () #{y 12665}#)
- #{tmp 12678}#)
- (let ((#{then-exp 12696}#
- (#{build-dispatch-call 11174}#
- #{pvars 12305}#
- #{fender 12147}#
- #{y 12665}#
- #{r 12145}#
- #{mod 12149}#))
- (#{else-exp 12697}#
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 1)
- #f
- #f)))
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 10)
- #f
- #{y 12665}#
- #{then-exp 12696}#
- #{else-exp 12697}#)))))
- (#{then-exp 12670}#
- (#{build-dispatch-call 11174}#
- #{pvars 12305}#
- #{exp 12148}#
- #{y 12665}#
- #{r 12145}#
- #{mod 12149}#))
- (#{else-exp 12671}#
- (#{gen-syntax-case 11176}#
- #{x 12142}#
- #{keys 12143}#
- #{clauses 12144}#
- #{r 12145}#
- #{mod 12149}#)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 10)
- #f
- #{test-exp 12669}#
- #{then-exp 12670}#
- #{else-exp 12671}#)))))
- (let ((#{body 12653}#
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #f
- #{req 12644}#
- #f
- #f
- #f
- '()
- #{vars 12646}#
- #{exp 12648}#
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- #f
- '()
- #{body 12653}#)))
- (list (if (eq? #{p 12304}# 'any)
- (let ((#{fun-exp 12719}#
- (if (equal?
- (module-name (current-module))
- '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- 'list)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- 'list
- #f)))
- (#{arg-exps 12720}#
- (list #{x 12142}#)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- #{fun-exp 12719}#
- #{arg-exps 12720}#))
- (let ((#{fun-exp 12743}#
- (if (equal?
- (module-name (current-module))
- '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- '$sc-dispatch)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- '$sc-dispatch
- #f)))
- (#{arg-exps 12744}#
- (list #{x 12142}#
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 1)
- #f
- #{p 12304}#))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- #{fun-exp 12743}#
- #{arg-exps 12744}#))))))))))))
- (#{gen-syntax-case 11176}#
- (lambda (#{x 11575}#
- #{keys 11576}#
- #{clauses 11577}#
- #{r 11578}#
- #{mod 11579}#)
- (if (null? #{clauses 11577}#)
- (let ((#{fun-exp 11584}#
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- 'syntax-violation)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- 'syntax-violation
- #f)))
- (#{arg-exps 11585}#
- (list (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
+ (vector-ref #{pat 38165}# 1)
+ #{pat 38165}#)))
+ (gensym
+ (string-append
+ (symbol->string #{id 38314}#)
+ " ")))))
+ (#{build-call 28205}#
#f
- #f)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- "source expression failed to match any pattern")
- #{x 11575}#)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- #{fun-exp 11584}#
- #{arg-exps 11585}#))
- (let ((#{tmp 11618}# (car #{clauses 11577}#)))
- (let ((#{tmp 11619}#
- ($sc-dispatch #{tmp 11618}# '(any any))))
- (if #{tmp 11619}#
- (@apply
- (lambda (#{pat 11621}# #{exp 11622}#)
- (if (if (if (symbol? #{pat 11621}#)
- #t
- (if (if (vector? #{pat 11621}#)
- (if (= (vector-length #{pat 11621}#)
- 4)
- (eq? (vector-ref #{pat 11621}# 0)
- 'syntax-object)
- #f)
+ (#{build-simple-lambda 28214}#
+ #f
+ (list (syntax->datum #{pat 38165}#))
+ #f
+ (list #{var 38276}#)
+ '()
+ (#{expand 28271}#
+ #{exp 38166}#
+ (#{extend-env 28233}#
+ #{labels 38275}#
+ (list (cons 'syntax
+ (cons #{var 38276}# 0)))
+ #{r 38136}#)
+ (#{make-binding-wrap 28252}#
+ (list #{pat 38165}#)
+ #{labels 38275}#
+ '(()))
+ #{mod 38137}#))
+ (list #{x 38133}#))))
+ (#{gen-clause 37428}#
+ #{x 38133}#
+ #{keys 38134}#
+ (cdr #{clauses 38135}#)
+ #{r 38136}#
+ #{pat 38165}#
+ #t
+ #{exp 38166}#
+ #{mod 38137}#)))
+ #{tmp 38163}#)
+ (let ((#{tmp 38624}#
+ ($sc-dispatch #{tmp 38162}# '(any any any))))
+ (if #{tmp 38624}#
+ (@apply
+ (lambda (#{pat 38626}#
+ #{fender 38627}#
+ #{exp 38628}#)
+ (#{gen-clause 37428}#
+ #{x 38133}#
+ #{keys 38134}#
+ (cdr #{clauses 38135}#)
+ #{r 38136}#
+ #{pat 38626}#
+ #{fender 38627}#
+ #{exp 38628}#
+ #{mod 38137}#))
+ #{tmp 38624}#)
+ (syntax-violation
+ 'syntax-case
+ "invalid clause"
+ (car #{clauses 38135}#)))))))))))
+ (lambda (#{e 37430}#
+ #{r 37431}#
+ #{w 37432}#
+ #{s 37433}#
+ #{mod 37434}#)
+ (let ((#{e 37435}#
+ (let ((#{x 38044}#
+ (begin
+ (if (if (pair? #{e 37430}#) #{s 37433}# #f)
+ (set-source-properties! #{e 37430}# #{s 37433}#))
+ #{e 37430}#)))
+ (if (if (null? (car #{w 37432}#))
+ (null? (cdr #{w 37432}#))
+ #f)
+ #{x 38044}#
+ (if (if (vector? #{x 38044}#)
+ (if (= (vector-length #{x 38044}#) 4)
+ (eq? (vector-ref #{x 38044}# 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 38076}# (vector-ref #{x 38044}# 1))
+ (#{wrap 38077}#
+ (let ((#{w2 38085}#
+ (vector-ref #{x 38044}# 2)))
+ (let ((#{m1 38086}# (car #{w 37432}#))
+ (#{s1 38087}# (cdr #{w 37432}#)))
+ (if (null? #{m1 38086}#)
+ (if (null? #{s1 38087}#)
+ #{w2 38085}#
+ (cons (car #{w2 38085}#)
+ (let ((#{m2 38102}#
+ (cdr #{w2 38085}#)))
+ (if (null? #{m2 38102}#)
+ #{s1 38087}#
+ (append
+ #{s1 38087}#
+ #{m2 38102}#)))))
+ (cons (let ((#{m2 38110}#
+ (car #{w2 38085}#)))
+ (if (null? #{m2 38110}#)
+ #{m1 38086}#
+ (append
+ #{m1 38086}#
+ #{m2 38110}#)))
+ (let ((#{m2 38118}#
+ (cdr #{w2 38085}#)))
+ (if (null? #{m2 38118}#)
+ #{s1 38087}#
+ (append
+ #{s1 38087}#
+ #{m2 38118}#))))))))
+ (#{module 38078}# (vector-ref #{x 38044}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 38076}#
+ #{wrap 38077}#
+ #{module 38078}#))
+ (if (null? #{x 38044}#)
+ #{x 38044}#
+ (vector
+ 'syntax-object
+ #{x 38044}#
+ #{w 37432}#
+ #{mod 37434}#)))))))
+ (let ((#{tmp 37436}# #{e 37435}#))
+ (let ((#{tmp 37437}#
+ ($sc-dispatch
+ #{tmp 37436}#
+ '(_ any each-any . each-any))))
+ (if #{tmp 37437}#
+ (@apply
+ (lambda (#{val 37485}# #{key 37486}# #{m 37487}#)
+ (if (and-map
+ (lambda (#{x 37488}#)
+ (if (if (symbol? #{x 37488}#)
+ #t
+ (if (if (vector? #{x 37488}#)
+ (if (= (vector-length #{x 37488}#) 4)
+ (eq? (vector-ref #{x 37488}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref #{x 37488}# 1))
+ #f))
+ (not (if (if (if (vector? #{x 37488}#)
+ (if (= (vector-length
+ #{x 37488}#)
+ 4)
+ (eq? (vector-ref
+ #{x 37488}#
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref #{x 37488}# 1))
#f)
- (symbol? (vector-ref #{pat 11621}# 1))
- #f))
- (and-map
- (lambda (#{x 11649}#)
- (not (if (eq? (if (if (vector?
- #{pat 11621}#)
- (if (= (vector-length
- #{pat 11621}#)
- 4)
- (eq? (vector-ref
- #{pat 11621}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref
- #{pat 11621}#
- 1)
- #{pat 11621}#)
- (if (if (vector?
- #{x 11649}#)
- (if (= (vector-length
- #{x 11649}#)
- 4)
- (eq? (vector-ref
- #{x 11649}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref #{x 11649}# 1)
- #{x 11649}#))
- (eq? (#{id-var-name 4434}#
- #{pat 11621}#
- '(()))
- (#{id-var-name 4434}#
- #{x 11649}#
- '(())))
- #f)))
- (cons '#(syntax-object
+ (#{free-id=? 28259}#
+ #{x 37488}#
+ '#(syntax-object
...
((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("i3969" "i3970"))
+ #(ribcage () () ())
#(ribcage () () ())
#(ribcage
- #(x keys clauses r mod)
- #((top) (top) (top) (top) (top))
- #("i3958"
- "i3959"
- "i3960"
- "i3961"
- "i3962"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("i3768"
- "i3766"
- "i3764"
- "i3762"))
+ #(x)
+ #((top))
+ #("i26166"))
#(ribcage
(lambda-var-list
gen-var
@@ -17147,7 +16583,7 @@
expand-local-syntax
expand-body
expand-macro
- expand-application
+ expand-call
expand-expr
expand
syntax-type
@@ -17162,8 +16598,6 @@
valid-bound-ids?
bound-id=?
free-id=?
- with-transformer-environment
- transformer-environment
resolve-identifier
id-var-name
same-marks?
@@ -17202,7 +16636,6 @@
id?
nonsymbol-id?
global-extend
- lookup
macros-only-env
extend-var-env
extend-env
@@ -17228,6 +16661,7 @@
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
@@ -17239,7 +16673,7 @@
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
@@ -17260,8 +16694,9 @@
make-let
make-lambda-case
make-lambda
- make-sequence
- make-application
+ make-seq
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
@@ -17410,5162 +16845,1059 @@
(top)
(top)
(top)
- (top)
(top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
+ ("i24298"
+ "i24296"
+ "i24294"
+ "i24292"
+ "i24290"
+ "i24288"
+ "i24286"
+ "i24284"
+ "i24282"
+ "i24280"
+ "i24278"
+ "i24276"
+ "i24274"
+ "i24272"
+ "i24270"
+ "i24268"
+ "i24266"
+ "i24264"
+ "i24262"
+ "i24260"
+ "i24258"
+ "i24256"
+ "i24254"
+ "i24252"
+ "i24250"
+ "i24248"
+ "i24246"
+ "i24244"
+ "i24242"
+ "i24240"
+ "i24238"
+ "i24236"
+ "i24234"
+ "i24232"
+ "i24230"
+ "i24228"
+ "i24227"
+ "i24225"
+ "i24222"
+ "i24221"
+ "i24220"
+ "i24218"
+ "i24217"
+ "i24215"
+ "i24213"
+ "i24211"
+ "i24209"
+ "i24207"
+ "i24205"
+ "i24203"
+ "i24201"
+ "i24198"
+ "i24196"
+ "i24195"
+ "i24193"
+ "i24191"
+ "i24189"
+ "i24187"
+ "i24186"
+ "i24185"
+ "i24184"
+ "i24182"
+ "i24181"
+ "i24178"
+ "i24176"
+ "i24174"
+ "i24172"
+ "i24170"
+ "i24168"
+ "i24167"
+ "i24166"
+ "i24164"
+ "i24162"
+ "i24161"
+ "i24158"
+ "i24157"
+ "i24155"
+ "i24153"
+ "i24151"
+ "i24149"
+ "i24147"
+ "i24145"
+ "i24143"
+ "i24141"
+ "i24139"
+ "i24136"
+ "i24134"
+ "i24132"
+ "i24130"
+ "i24128"
+ "i24126"
+ "i24124"
+ "i24122"
+ "i24120"
+ "i24118"
+ "i24116"
+ "i24114"
+ "i24112"
+ "i24110"
+ "i24108"
+ "i24106"
+ "i24104"
+ "i24102"
+ "i24100"
+ "i24098"
+ "i24096"
+ "i24094"
+ "i24092"
+ "i24090"
+ "i24089"
+ "i24086"
+ "i24084"
+ "i24083"
+ "i24082"
+ "i24081"
+ "i24080"
+ "i24078"
+ "i24076"
+ "i24074"
+ "i24071"
+ "i24069"
+ "i24067"
+ "i24065"
+ "i24063"
+ "i24061"
+ "i24059"
+ "i24057"
+ "i24055"
+ "i24053"
+ "i24051"
+ "i24049"
+ "i24047"
+ "i24045"
+ "i24043"
+ "i24041"
+ "i24039"
+ "i24037"
+ "i24035"))
#(ribcage
(define-structure
define-expansion-accessors
define-expansion-constructors)
((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))
- #{keys 11576}#))
- #f)
- (if (if (eq? (if (if (= (vector-length
- '#(syntax-object
- pad
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("i3969"
- "i3970"))
- #(ribcage () () ())
- #(ribcage
- #(x
- keys
- clauses
- r
- mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i3958"
- "i3959"
- "i3960"
- "i3961"
- "i3962"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top)
- (top)
- (top)
- (top))
- ("i3768"
- "i3766"
- "i3764"
- "i3762"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene guile)))
- 4)
- #t
- #f)
- 'pad
- '#(syntax-object
- pad
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("i3969" "i3970"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i3958"
- "i3959"
- "i3960"
- "i3961"
- "i3962"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("i3768"
- "i3766"
- "i3764"
- "i3762"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile)))
- (if (if (= (vector-length
- '#(syntax-object
- _
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("i3969"
- "i3970"))
- #(ribcage () () ())
- #(ribcage
- #(x
- keys
- clauses
- r
- mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i3958"
- "i3959"
- "i3960"
- "i3961"
- "i3962"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top)
- (top)
- (top)
- (top))
- ("i3768"
- "i3766"
- "i3764"
- "i3762"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene guile)))
- 4)
- #t
- #f)
- '_
- '#(syntax-object
- _
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("i3969" "i3970"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i3958"
- "i3959"
- "i3960"
- "i3961"
- "i3962"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("i3768"
- "i3766"
- "i3764"
- "i3762"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))))
- (eq? (#{id-var-name 4434}#
- '#(syntax-object
- pad
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("i3969" "i3970"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i3958"
- "i3959"
- "i3960"
- "i3961"
- "i3962"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("i3768"
- "i3766"
- "i3764"
- "i3762"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))
- '(()))
- (#{id-var-name 4434}#
- '#(syntax-object
- _
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("i3969" "i3970"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("i3958"
- "i3959"
- "i3960"
- "i3961"
- "i3962"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("i3768"
- "i3766"
- "i3764"
- "i3762"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))
- '(())))
- #f)
- (#{expand 4450}#
- #{exp 11622}#
- #{r 11578}#
- '(())
- #{mod 11579}#)
- (let ((#{labels 11825}#
- (list (symbol->string (gensym "i"))))
- (#{var 11826}#
- (let ((#{id 11864}#
- (if (if (vector? #{pat 11621}#)
- (if (= (vector-length
- #{pat 11621}#)
- 4)
- (eq? (vector-ref
- #{pat 11621}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref #{pat 11621}# 1)
- #{pat 11621}#)))
- (gensym
- (string-append
- (symbol->string #{id 11864}#)
- " ")))))
- (#{build-application 4382}#
- #f
- (#{build-simple-lambda 4391}#
- #f
- (list (syntax->datum #{pat 11621}#))
- #f
- (list #{var 11826}#)
- '()
- (#{expand 4450}#
- #{exp 11622}#
- (#{extend-env 4409}#
- #{labels 11825}#
- (list (cons 'syntax
- (cons #{var 11826}# 0)))
- #{r 11578}#)
- (#{make-binding-wrap 4429}#
- (list #{pat 11621}#)
- #{labels 11825}#
- '(()))
- #{mod 11579}#))
- (list #{x 11575}#))))
- (#{gen-clause 11175}#
- #{x 11575}#
- #{keys 11576}#
- (cdr #{clauses 11577}#)
- #{r 11578}#
- #{pat 11621}#
- #t
- #{exp 11622}#
- #{mod 11579}#)))
- #{tmp 11619}#)
- (let ((#{tmp 12134}#
- ($sc-dispatch #{tmp 11618}# '(any any any))))
- (if #{tmp 12134}#
- (@apply
- (lambda (#{pat 12136}#
- #{fender 12137}#
- #{exp 12138}#)
- (#{gen-clause 11175}#
- #{x 11575}#
- #{keys 11576}#
- (cdr #{clauses 11577}#)
- #{r 11578}#
- #{pat 12136}#
- #{fender 12137}#
- #{exp 12138}#
- #{mod 11579}#))
- #{tmp 12134}#)
- (syntax-violation
- 'syntax-case
- "invalid clause"
- (car #{clauses 11577}#)))))))))))
- (lambda (#{e 11177}#
- #{r 11178}#
- #{w 11179}#
- #{s 11180}#
- #{mod 11181}#)
- (let ((#{e 11182}#
- (#{wrap 4443}#
- (begin
- (if (if (pair? #{e 11177}#) #{s 11180}# #f)
- (set-source-properties! #{e 11177}# #{s 11180}#))
- #{e 11177}#)
- #{w 11179}#
- #{mod 11181}#)))
- (let ((#{tmp 11184}#
- ($sc-dispatch
- #{e 11182}#
- '(_ any each-any . each-any))))
- (if #{tmp 11184}#
- (@apply
- (lambda (#{val 11209}# #{key 11210}# #{m 11211}#)
- (if (and-map
- (lambda (#{x 11212}#)
- (if (if (symbol? #{x 11212}#)
- #t
- (if (if (vector? #{x 11212}#)
- (if (= (vector-length #{x 11212}#) 4)
- (eq? (vector-ref #{x 11212}# 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref #{x 11212}# 1))
- #f))
- (not (if (if (if (vector? #{x 11212}#)
- (if (= (vector-length
- #{x 11212}#)
- 4)
- (eq? (vector-ref
- #{x 11212}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref #{x 11212}# 1))
- #f)
- (if (eq? (if (if (vector? #{x 11212}#)
- (if (= (vector-length
- #{x 11212}#)
- 4)
- (eq? (vector-ref
- #{x 11212}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref #{x 11212}# 1)
- #{x 11212}#)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("i46"
- "i45"
- "i44")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))))
- (eq? (#{id-var-name 4434}#
- #{x 11212}#
- '(()))
- (#{id-var-name 4434}#
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("i2288"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- gensym-hook
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("i473"
- "i471"
- "i469"
- "i467"
- "i465"
- "i463"
- "i461"
- "i459"
- "i457"
- "i455"
- "i453"
- "i451"
- "i449"
- "i447"
- "i445"
- "i443"
- "i441"
- "i439"
- "i437"
- "i435"
- "i433"
- "i431"
- "i429"
- "i427"
- "i425"
- "i423"
- "i421"
- "i419"
- "i417"
- "i415"
- "i413"
- "i411"
- "i409"
- "i407"
- "i405"
- "i403"
- "i401"
- "i399"
- "i398"
- "i396"
- "i393"
- "i392"
- "i391"
- "i389"
- "i388"
- "i386"
- "i384"
- "i382"
- "i380"
- "i378"
- "i376"
- "i374"
- "i372"
- "i369"
- "i367"
- "i366"
- "i364"
- "i362"
- "i360"
- "i358"
- "i357"
- "i356"
- "i355"
- "i353"
- "i352"
- "i349"
- "i347"
- "i345"
- "i343"
- "i341"
- "i339"
- "i337"
- "i336"
- "i335"
- "i333"
- "i331"
- "i330"
- "i327"
- "i326"
- "i324"
- "i322"
- "i320"
- "i318"
- "i316"
- "i314"
- "i312"
- "i310"
- "i308"
- "i305"
- "i303"
- "i301"
- "i299"
- "i297"
- "i295"
- "i293"
- "i291"
- "i289"
- "i287"
- "i285"
- "i283"
- "i281"
- "i279"
- "i277"
- "i275"
- "i273"
- "i271"
- "i269"
- "i267"
- "i265"
- "i263"
- "i261"
- "i260"
- "i257"
- "i255"
- "i254"
- "i253"
- "i252"
- "i251"
- "i249"
- "i247"
- "i245"
- "i242"
- "i240"
- "i238"
- "i236"
- "i234"
- "i232"
- "i230"
- "i228"
- "i226"
- "i224"
- "i222"
- "i220"
- "i218"
- "i216"
- "i214"
- "i212"
- "i210"
- "i208"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("i46" "i45" "i44")))
- (hygiene guile))
- '(())))
- #f)
+ ("i23873" "i23872" "i23871"))
+ #(ribcage () () ()))
+ (hygiene guile)))
#f))
#f))
- #{key 11210}#)
- (let ((#{x 11338}#
+ #{key 37486}#)
+ (let ((#{x 37553}#
(gensym
(string-append (symbol->string 'tmp) " "))))
- (#{build-application 4382}#
- #{s 11180}#
- (let ((#{req 11468}# (list 'tmp))
- (#{vars 11470}# (list #{x 11338}#))
- (#{exp 11472}#
- (#{gen-syntax-case 11176}#
+ (#{build-call 28205}#
+ #{s 37433}#
+ (let ((#{req 37691}# (list 'tmp))
+ (#{vars 37693}# (list #{x 37553}#))
+ (#{exp 37695}#
+ (#{gen-syntax-case 37429}#
(make-struct/no-tail
(vector-ref %expanded-vtables 3)
#f
'tmp
- #{x 11338}#)
- #{key 11210}#
- #{m 11211}#
- #{r 11178}#
- #{mod 11181}#)))
- (let ((#{body 11477}#
+ #{x 37553}#)
+ #{key 37486}#
+ #{m 37487}#
+ #{r 37431}#
+ #{mod 37434}#)))
+ (let ((#{body 37700}#
(make-struct/no-tail
- (vector-ref %expanded-vtables 14)
+ (vector-ref %expanded-vtables 15)
#f
- #{req 11468}#
+ #{req 37691}#
#f
#f
#f
'()
- #{vars 11470}#
- #{exp 11472}#
+ #{vars 37693}#
+ #{exp 37695}#
#f)))
(make-struct/no-tail
- (vector-ref %expanded-vtables 13)
+ (vector-ref %expanded-vtables 14)
#f
'()
- #{body 11477}#)))
- (list (#{expand 4450}#
- #{val 11209}#
- #{r 11178}#
+ #{body 37700}#)))
+ (list (#{expand 28271}#
+ #{val 37485}#
+ #{r 37431}#
'(())
- #{mod 11181}#))))
+ #{mod 37434}#))))
(syntax-violation
'syntax-case
"invalid literals list"
- #{e 11182}#)))
- #{tmp 11184}#)
+ #{e 37435}#)))
+ #{tmp 37437}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{e 11182}#)))))))
- (set! macroexpand
- (lambda*
- (#{x 13915}#
- #:optional
- (#{m 13916}# 'e)
- (#{esew 13917}# '(eval)))
- (#{expand-top-sequence 4446}#
- (list #{x 13915}#)
- '()
- '((top))
- #f
- #{m 13916}#
- #{esew 13917}#
- (cons 'hygiene (module-name (current-module))))))
- (set! identifier?
- (lambda (#{x 13920}#)
- (if (if (vector? #{x 13920}#)
- (if (= (vector-length #{x 13920}#) 4)
- (eq? (vector-ref #{x 13920}# 0) 'syntax-object)
- #f)
+ #{tmp 37436}#))))))))
+ (set! macroexpand
+ (lambda*
+ (#{x 40406}#
+ #:optional
+ (#{m 40407}# 'e)
+ (#{esew 40408}# '(eval)))
+ (#{expand-top-sequence 28267}#
+ (list #{x 40406}#)
+ '()
+ '((top))
+ #f
+ #{m 40407}#
+ #{esew 40408}#
+ (cons 'hygiene (module-name (current-module))))))
+ (set! identifier?
+ (lambda (#{x 40411}#)
+ (if (if (vector? #{x 40411}#)
+ (if (= (vector-length #{x 40411}#) 4)
+ (eq? (vector-ref #{x 40411}# 0) 'syntax-object)
#f)
- (symbol? (vector-ref #{x 13920}# 1))
- #f)))
- (set! datum->syntax
- (lambda (#{id 13945}# #{datum 13946}#)
- (let ((#{wrap 13951}# (vector-ref #{id 13945}# 2))
- (#{module 13952}# (vector-ref #{id 13945}# 3)))
- (vector
- 'syntax-object
- #{datum 13946}#
- #{wrap 13951}#
- #{module 13952}#))))
- (set! syntax->datum
- (lambda (#{x 13959}#)
- (#{strip 4463}# #{x 13959}# '(()))))
- (set! syntax-source
- (lambda (#{x 13962}#)
- (#{source-annotation 4408}# #{x 13962}#)))
- (set! syntax-local-binding
- (lambda (#{id 14115}#)
- (begin
- (if (not (if (if (vector? #{id 14115}#)
- (if (= (vector-length #{id 14115}#) 4)
- (eq? (vector-ref #{id 14115}# 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref #{id 14115}# 1))
- #f))
- (syntax-violation
- 'syntax-local-value
- "invalid argument"
- #{id 14115}#))
- ((fluid-ref #{transformer-environment 4436}#)
- (lambda (#{e 14156}#
- #{r 14157}#
- #{w 14158}#
- #{s 14159}#
- #{rib 14160}#
- #{mod 14161}#)
- (call-with-values
- (lambda ()
- (let ((#{id 14164}# (vector-ref #{id 14115}# 1))
- (#{w 14165}#
- (let ((#{w 14176}# (vector-ref #{id 14115}# 2)))
- (let ((#{ms 14177}# (car #{w 14176}#))
- (#{s 14178}# (cdr #{w 14176}#)))
- (if (if (pair? #{ms 14177}#)
- (eq? (car #{ms 14177}#) #f)
- #f)
- (cons (cdr #{ms 14177}#)
- (if #{rib 14160}#
- (cons #{rib 14160}# (cdr #{s 14178}#))
- (cdr #{s 14178}#)))
- (cons #{ms 14177}#
- (if #{rib 14160}#
- (cons #{rib 14160}# #{s 14178}#)
- #{s 14178}#))))))
- (#{mod 14167}# (vector-ref #{id 14115}# 3)))
- (let ((#{n 14170}#
- (#{id-var-name 4434}# #{id 14164}# #{w 14165}#)))
- (if (symbol? #{n 14170}#)
- (let ((#{mod 14184}#
- (if (if (vector? #{id 14164}#)
- (if (= (vector-length #{id 14164}#) 4)
- (eq? (vector-ref #{id 14164}# 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref #{id 14164}# 3)
- #{mod 14167}#)))
- (let ((#{b 14185}#
- (let ((#{t 14186}#
- (#{get-global-definition-hook 4378}#
- #{n 14170}#
- #{mod 14184}#)))
- (if #{t 14186}# #{t 14186}# '(global)))))
- (if (eq? (car #{b 14185}#) 'global)
- (values 'global #{n 14170}# #{mod 14184}#)
- (values
- (car #{b 14185}#)
- (cdr #{b 14185}#)
- #{mod 14184}#))))
- (if (string? #{n 14170}#)
- (let ((#{mod 14212}#
- (if (if (vector? #{id 14164}#)
- (if (= (vector-length #{id 14164}#) 4)
- (eq? (vector-ref #{id 14164}# 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref #{id 14164}# 3)
- #{mod 14167}#)))
- (let ((#{b 14213}#
- (let ((#{t 14214}#
- (assq-ref
- #{r 14157}#
- #{n 14170}#)))
- (if #{t 14214}#
- #{t 14214}#
- '(displaced-lexical)))))
- (values
- (car #{b 14213}#)
- (cdr #{b 14213}#)
- #{mod 14212}#)))
- (error "unexpected id-var-name"
- #{id 14164}#
- #{w 14165}#
- #{n 14170}#))))))
- (lambda (#{type 14227}# #{value 14228}# #{mod 14229}#)
- (if (eqv? #{type 14227}# 'lexical)
- (values 'lexical #{value 14228}#)
- (if (eqv? #{type 14227}# 'macro)
- (values 'macro #{value 14228}#)
- (if (eqv? #{type 14227}# 'syntax)
- (values 'pattern-variable #{value 14228}#)
- (if (eqv? #{type 14227}# 'displaced-lexical)
- (values 'displaced-lexical #f)
- (if (eqv? #{type 14227}# 'global)
- (values
- 'global
- (cons #{value 14228}# #{mod 14229}#))
- (values 'other #f)))))))))))))
- (set! generate-temporaries
- (lambda (#{ls 14240}#)
- (begin
- (if (not (list? #{ls 14240}#))
- (syntax-violation
- 'generate-temporaries
- "invalid argument"
- #{ls 14240}#))
- (let ((#{mod 14248}#
- (cons 'hygiene (module-name (current-module)))))
- (map (lambda (#{x 14249}#)
- (#{wrap 4443}# (gensym) '((top)) #{mod 14248}#))
- #{ls 14240}#)))))
- (set! free-identifier=?
- (lambda (#{x 14253}# #{y 14254}#)
- (begin
- (if (not (if (if (vector? #{x 14253}#)
- (if (= (vector-length #{x 14253}#) 4)
- (eq? (vector-ref #{x 14253}# 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref #{x 14253}# 1))
- #f))
- (syntax-violation
- 'free-identifier=?
- "invalid argument"
- #{x 14253}#))
- (if (not (if (if (vector? #{y 14254}#)
- (if (= (vector-length #{y 14254}#) 4)
- (eq? (vector-ref #{y 14254}# 0) 'syntax-object)
+ #f)
+ (symbol? (vector-ref #{x 40411}# 1))
+ #f)))
+ (set! datum->syntax
+ (lambda (#{id 40436}# #{datum 40437}#)
+ (let ((#{wrap 40442}# (vector-ref #{id 40436}# 2))
+ (#{module 40443}# (vector-ref #{id 40436}# 3)))
+ (vector
+ 'syntax-object
+ #{datum 40437}#
+ #{wrap 40442}#
+ #{module 40443}#))))
+ (set! syntax->datum
+ (lambda (#{x 40450}#)
+ (#{strip 28284}# #{x 40450}# '(()))))
+ (set! syntax-source
+ (lambda (#{x 40453}#)
+ (#{source-annotation 28232}# #{x 40453}#)))
+ (set! generate-temporaries
+ (lambda (#{ls 40637}#)
+ (begin
+ (if (not (list? #{ls 40637}#))
+ (syntax-violation
+ 'generate-temporaries
+ "invalid argument"
+ #{ls 40637}#))
+ (let ((#{mod 40645}#
+ (cons 'hygiene (module-name (current-module)))))
+ (map (lambda (#{x 40646}#)
+ (let ((#{x 40650}# (gensym)))
+ (if (if (vector? #{x 40650}#)
+ (if (= (vector-length #{x 40650}#) 4)
+ (eq? (vector-ref #{x 40650}# 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref #{y 14254}# 1))
- #f))
- (syntax-violation
- 'free-identifier=?
- "invalid argument"
- #{y 14254}#))
- (if (eq? (if (if (vector? #{x 14253}#)
- (if (= (vector-length #{x 14253}#) 4)
- (eq? (vector-ref #{x 14253}# 0) 'syntax-object)
- #f)
+ (let ((#{expression 40665}# (vector-ref #{x 40650}# 1))
+ (#{wrap 40666}#
+ (let ((#{w2 40674}# (vector-ref #{x 40650}# 2)))
+ (cons (let ((#{m2 40681}# (car #{w2 40674}#)))
+ (if (null? #{m2 40681}#)
+ '(top)
+ (append '(top) #{m2 40681}#)))
+ (let ((#{m2 40688}# (cdr #{w2 40674}#)))
+ (if (null? #{m2 40688}#)
+ '()
+ (append '() #{m2 40688}#))))))
+ (#{module 40667}# (vector-ref #{x 40650}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 40665}#
+ #{wrap 40666}#
+ #{module 40667}#))
+ (if (null? #{x 40650}#)
+ #{x 40650}#
+ (vector
+ 'syntax-object
+ #{x 40650}#
+ '((top))
+ #{mod 40645}#)))))
+ #{ls 40637}#)))))
+ (set! free-identifier=?
+ (lambda (#{x 40697}# #{y 40698}#)
+ (begin
+ (if (not (if (if (vector? #{x 40697}#)
+ (if (= (vector-length #{x 40697}#) 4)
+ (eq? (vector-ref #{x 40697}# 0) 'syntax-object)
#f)
- (vector-ref #{x 14253}# 1)
- #{x 14253}#)
- (if (if (vector? #{y 14254}#)
- (if (= (vector-length #{y 14254}#) 4)
- (eq? (vector-ref #{y 14254}# 0) 'syntax-object)
- #f)
+ #f)
+ (symbol? (vector-ref #{x 40697}# 1))
+ #f))
+ (syntax-violation
+ 'free-identifier=?
+ "invalid argument"
+ #{x 40697}#))
+ (if (not (if (if (vector? #{y 40698}#)
+ (if (= (vector-length #{y 40698}#) 4)
+ (eq? (vector-ref #{y 40698}# 0) 'syntax-object)
#f)
- (vector-ref #{y 14254}# 1)
- #{y 14254}#))
- (eq? (#{id-var-name 4434}# #{x 14253}# '(()))
- (#{id-var-name 4434}# #{y 14254}# '(())))
- #f))))
- (set! bound-identifier=?
- (lambda (#{x 14404}# #{y 14405}#)
- (begin
- (if (not (if (if (vector? #{x 14404}#)
- (if (= (vector-length #{x 14404}#) 4)
- (eq? (vector-ref #{x 14404}# 0) 'syntax-object)
- #f)
+ #f)
+ (symbol? (vector-ref #{y 40698}# 1))
+ #f))
+ (syntax-violation
+ 'free-identifier=?
+ "invalid argument"
+ #{y 40698}#))
+ (#{free-id=? 28259}# #{x 40697}# #{y 40698}#))))
+ (set! bound-identifier=?
+ (lambda (#{x 40773}# #{y 40774}#)
+ (begin
+ (if (not (if (if (vector? #{x 40773}#)
+ (if (= (vector-length #{x 40773}#) 4)
+ (eq? (vector-ref #{x 40773}# 0) 'syntax-object)
#f)
- (symbol? (vector-ref #{x 14404}# 1))
- #f))
- (syntax-violation
- 'bound-identifier=?
- "invalid argument"
- #{x 14404}#))
- (if (not (if (if (vector? #{y 14405}#)
- (if (= (vector-length #{y 14405}#) 4)
- (eq? (vector-ref #{y 14405}# 0) 'syntax-object)
- #f)
+ #f)
+ (symbol? (vector-ref #{x 40773}# 1))
+ #f))
+ (syntax-violation
+ 'bound-identifier=?
+ "invalid argument"
+ #{x 40773}#))
+ (if (not (if (if (vector? #{y 40774}#)
+ (if (= (vector-length #{y 40774}#) 4)
+ (eq? (vector-ref #{y 40774}# 0) 'syntax-object)
#f)
- (symbol? (vector-ref #{y 14405}# 1))
- #f))
- (syntax-violation
- 'bound-identifier=?
- "invalid argument"
- #{y 14405}#))
- (if (if (if (vector? #{x 14404}#)
- (if (= (vector-length #{x 14404}#) 4)
- (eq? (vector-ref #{x 14404}# 0) 'syntax-object)
- #f)
- #f)
- (if (vector? #{y 14405}#)
- (if (= (vector-length #{y 14405}#) 4)
- (eq? (vector-ref #{y 14405}# 0) 'syntax-object)
- #f)
- #f)
- #f)
- (if (eq? (vector-ref #{x 14404}# 1)
- (vector-ref #{y 14405}# 1))
- (#{same-marks? 4433}#
- (car (vector-ref #{x 14404}# 2))
- (car (vector-ref #{y 14405}# 2)))
- #f)
- (eq? #{x 14404}# #{y 14405}#)))))
- (set! syntax-violation
- (lambda*
- (#{who 14538}#
- #{message 14539}#
- #{form 14540}#
- #:optional
- (#{subform 14541}# #f))
- (begin
- (if (not (if (not #{who 14538}#)
- (not #{who 14538}#)
- (let ((#{t 14559}# (string? #{who 14538}#)))
- (if #{t 14559}#
- #{t 14559}#
- (symbol? #{who 14538}#)))))
- (syntax-violation
- 'syntax-violation
- "invalid argument"
- #{who 14538}#))
- (if (not (string? #{message 14539}#))
- (syntax-violation
- 'syntax-violation
- "invalid argument"
- #{message 14539}#))
- (throw 'syntax-error
- #{who 14538}#
- #{message 14539}#
- (#{source-annotation 4408}#
- (if #{form 14540}#
- #{form 14540}#
- #{subform 14541}#))
- (#{strip 4463}# #{form 14540}# '(()))
- (if #{subform 14541}#
- (#{strip 4463}# #{subform 14541}# '(()))
- #f)))))
- (letrec*
- ((#{match-each 14762}#
- (lambda (#{e 15349}#
- #{p 15350}#
- #{w 15351}#
- #{mod 15352}#)
- (if (pair? #{e 15349}#)
- (let ((#{first 15353}#
- (#{match 14768}#
- (car #{e 15349}#)
- #{p 15350}#
- #{w 15351}#
- '()
- #{mod 15352}#)))
- (if #{first 15353}#
- (let ((#{rest 15356}#
- (#{match-each 14762}#
- (cdr #{e 15349}#)
- #{p 15350}#
- #{w 15351}#
- #{mod 15352}#)))
- (if #{rest 15356}#
- (cons #{first 15353}# #{rest 15356}#)
- #f))
- #f))
- (if (null? #{e 15349}#)
- '()
- (if (if (vector? #{e 15349}#)
- (if (= (vector-length #{e 15349}#) 4)
- (eq? (vector-ref #{e 15349}# 0) 'syntax-object)
#f)
- #f)
- (#{match-each 14762}#
- (vector-ref #{e 15349}# 1)
- #{p 15350}#
- (#{join-wraps 4431}#
- #{w 15351}#
- (vector-ref #{e 15349}# 2))
- (vector-ref #{e 15349}# 3))
+ (symbol? (vector-ref #{y 40774}# 1))
+ #f))
+ (syntax-violation
+ 'bound-identifier=?
+ "invalid argument"
+ #{y 40774}#))
+ (#{bound-id=? 28260}# #{x 40773}# #{y 40774}#))))
+ (set! syntax-violation
+ (lambda*
+ (#{who 40940}#
+ #{message 40941}#
+ #{form 40942}#
+ #:optional
+ (#{subform 40943}# #f))
+ (begin
+ (if (not (if (not #{who 40940}#)
+ (not #{who 40940}#)
+ (let ((#{t 40961}# (string? #{who 40940}#)))
+ (if #{t 40961}#
+ #{t 40961}#
+ (symbol? #{who 40940}#)))))
+ (syntax-violation
+ 'syntax-violation
+ "invalid argument"
+ #{who 40940}#))
+ (if (not (string? #{message 40941}#))
+ (syntax-violation
+ 'syntax-violation
+ "invalid argument"
+ #{message 40941}#))
+ (throw 'syntax-error
+ #{who 40940}#
+ #{message 40941}#
+ (#{source-annotation 28232}#
+ (if #{form 40942}#
+ #{form 40942}#
+ #{subform 40943}#))
+ (#{strip 28284}# #{form 40942}# '(()))
+ (if #{subform 40943}#
+ (#{strip 28284}# #{subform 40943}# '(()))
#f)))))
- (#{match-each-any 14764}#
- (lambda (#{e 15384}# #{w 15385}# #{mod 15386}#)
- (if (pair? #{e 15384}#)
- (let ((#{l 15387}#
- (#{match-each-any 14764}#
- (cdr #{e 15384}#)
- #{w 15385}#
- #{mod 15386}#)))
- (if #{l 15387}#
- (cons (#{wrap 4443}#
- (car #{e 15384}#)
- #{w 15385}#
- #{mod 15386}#)
- #{l 15387}#)
- #f))
- (if (null? #{e 15384}#)
- '()
- (if (if (vector? #{e 15384}#)
- (if (= (vector-length #{e 15384}#) 4)
- (eq? (vector-ref #{e 15384}# 0) 'syntax-object)
- #f)
+ (letrec*
+ ((#{match-each 41192}#
+ (lambda (#{e 42071}#
+ #{p 42072}#
+ #{w 42073}#
+ #{mod 42074}#)
+ (if (pair? #{e 42071}#)
+ (let ((#{first 42075}#
+ (#{match 41198}#
+ (car #{e 42071}#)
+ #{p 42072}#
+ #{w 42073}#
+ '()
+ #{mod 42074}#)))
+ (if #{first 42075}#
+ (let ((#{rest 42078}#
+ (#{match-each 41192}#
+ (cdr #{e 42071}#)
+ #{p 42072}#
+ #{w 42073}#
+ #{mod 42074}#)))
+ (if #{rest 42078}#
+ (cons #{first 42075}# #{rest 42078}#)
+ #f))
+ #f))
+ (if (null? #{e 42071}#)
+ '()
+ (if (if (vector? #{e 42071}#)
+ (if (= (vector-length #{e 42071}#) 4)
+ (eq? (vector-ref #{e 42071}# 0) 'syntax-object)
#f)
- (#{match-each-any 14764}#
- (vector-ref #{e 15384}# 1)
- (#{join-wraps 4431}#
- #{w 15385}#
- (vector-ref #{e 15384}# 2))
- #{mod 15386}#)
- #f)))))
- (#{match-empty 14765}#
- (lambda (#{p 15411}# #{r 15412}#)
- (if (null? #{p 15411}#)
- #{r 15412}#
- (if (eq? #{p 15411}# '_)
- #{r 15412}#
- (if (eq? #{p 15411}# 'any)
- (cons '() #{r 15412}#)
- (if (pair? #{p 15411}#)
- (#{match-empty 14765}#
- (car #{p 15411}#)
- (#{match-empty 14765}#
- (cdr #{p 15411}#)
- #{r 15412}#))
- (if (eq? #{p 15411}# 'each-any)
- (cons '() #{r 15412}#)
- (let ((#{atom-key 15413}# (vector-ref #{p 15411}# 0)))
- (if (eqv? #{atom-key 15413}# 'each)
- (#{match-empty 14765}#
- (vector-ref #{p 15411}# 1)
- #{r 15412}#)
- (if (eqv? #{atom-key 15413}# 'each+)
- (#{match-empty 14765}#
- (vector-ref #{p 15411}# 1)
- (#{match-empty 14765}#
- (reverse (vector-ref #{p 15411}# 2))
- (#{match-empty 14765}#
- (vector-ref #{p 15411}# 3)
- #{r 15412}#)))
- (if (if (eqv? #{atom-key 15413}# 'free-id)
- #t
- (eqv? #{atom-key 15413}# 'atom))
- #{r 15412}#
- (if (eqv? #{atom-key 15413}# 'vector)
- (#{match-empty 14765}#
- (vector-ref #{p 15411}# 1)
- #{r 15412}#)))))))))))))
- (#{combine 14766}#
- (lambda (#{r* 15432}# #{r 15433}#)
- (if (null? (car #{r* 15432}#))
- #{r 15433}#
- (cons (map car #{r* 15432}#)
- (#{combine 14766}#
- (map cdr #{r* 15432}#)
- #{r 15433}#)))))
- (#{match* 14767}#
- (lambda (#{e 14797}#
- #{p 14798}#
- #{w 14799}#
- #{r 14800}#
- #{mod 14801}#)
- (if (null? #{p 14798}#)
- (if (null? #{e 14797}#) #{r 14800}# #f)
- (if (pair? #{p 14798}#)
- (if (pair? #{e 14797}#)
- (#{match 14768}#
- (car #{e 14797}#)
- (car #{p 14798}#)
- #{w 14799}#
- (#{match 14768}#
- (cdr #{e 14797}#)
- (cdr #{p 14798}#)
- #{w 14799}#
- #{r 14800}#
- #{mod 14801}#)
- #{mod 14801}#)
- #f)
- (if (eq? #{p 14798}# 'each-any)
- (let ((#{l 14806}#
- (#{match-each-any 14764}#
- #{e 14797}#
- #{w 14799}#
- #{mod 14801}#)))
- (if #{l 14806}#
- (cons #{l 14806}# #{r 14800}#)
- #f))
- (let ((#{atom-key 14811}# (vector-ref #{p 14798}# 0)))
- (if (eqv? #{atom-key 14811}# 'each)
- (if (null? #{e 14797}#)
- (#{match-empty 14765}#
- (vector-ref #{p 14798}# 1)
- #{r 14800}#)
- (let ((#{l 14818}#
- (#{match-each 14762}#
- #{e 14797}#
- (vector-ref #{p 14798}# 1)
- #{w 14799}#
- #{mod 14801}#)))
- (if #{l 14818}#
- (letrec*
- ((#{collect 14821}#
- (lambda (#{l 14872}#)
- (if (null? (car #{l 14872}#))
- #{r 14800}#
- (cons (map car #{l 14872}#)
- (#{collect 14821}#
- (map cdr #{l 14872}#)))))))
- (#{collect 14821}# #{l 14818}#))
- #f)))
- (if (eqv? #{atom-key 14811}# 'each+)
- (call-with-values
- (lambda ()
- (let ((#{x-pat 14881}# (vector-ref #{p 14798}# 1))
- (#{y-pat 14882}# (vector-ref #{p 14798}# 2))
- (#{z-pat 14883}#
- (vector-ref #{p 14798}# 3)))
- (letrec*
- ((#{f 14887}#
- (lambda (#{e 14889}# #{w 14890}#)
- (if (pair? #{e 14889}#)
- (call-with-values
- (lambda ()
- (#{f 14887}#
- (cdr #{e 14889}#)
- #{w 14890}#))
- (lambda (#{xr* 14891}#
- #{y-pat 14892}#
- #{r 14893}#)
- (if #{r 14893}#
- (if (null? #{y-pat 14892}#)
- (let ((#{xr 14894}#
- (#{match 14768}#
- (car #{e 14889}#)
- #{x-pat 14881}#
- #{w 14890}#
- '()
- #{mod 14801}#)))
- (if #{xr 14894}#
- (values
- (cons #{xr 14894}#
- #{xr* 14891}#)
- #{y-pat 14892}#
- #{r 14893}#)
- (values #f #f #f)))
- (values
- '()
- (cdr #{y-pat 14892}#)
- (#{match 14768}#
- (car #{e 14889}#)
- (car #{y-pat 14892}#)
- #{w 14890}#
- #{r 14893}#
- #{mod 14801}#)))
- (values #f #f #f))))
- (if (if (vector? #{e 14889}#)
- (if (= (vector-length
- #{e 14889}#)
- 4)
- (eq? (vector-ref #{e 14889}# 0)
- 'syntax-object)
- #f)
- #f)
- (#{f 14887}#
- (vector-ref #{e 14889}# 1)
- (#{join-wraps 4431}#
- #{w 14890}#
- #{e 14889}#))
- (values
- '()
- #{y-pat 14882}#
- (#{match 14768}#
- #{e 14889}#
- #{z-pat 14883}#
- #{w 14890}#
- #{r 14800}#
- #{mod 14801}#)))))))
- (#{f 14887}# #{e 14797}# #{w 14799}#))))
- (lambda (#{xr* 14920}# #{y-pat 14921}# #{r 14922}#)
- (if #{r 14922}#
- (if (null? #{y-pat 14921}#)
- (if (null? #{xr* 14920}#)
- (#{match-empty 14765}#
- (vector-ref #{p 14798}# 1)
- #{r 14922}#)
- (#{combine 14766}#
- #{xr* 14920}#
- #{r 14922}#))
+ #f)
+ (#{match-each 41192}#
+ (vector-ref #{e 42071}# 1)
+ #{p 42072}#
+ (let ((#{w2 42100}# (vector-ref #{e 42071}# 2)))
+ (let ((#{m1 42101}# (car #{w 42073}#))
+ (#{s1 42102}# (cdr #{w 42073}#)))
+ (if (null? #{m1 42101}#)
+ (if (null? #{s1 42102}#)
+ #{w2 42100}#
+ (cons (car #{w2 42100}#)
+ (let ((#{m2 42113}# (cdr #{w2 42100}#)))
+ (if (null? #{m2 42113}#)
+ #{s1 42102}#
+ (append #{s1 42102}# #{m2 42113}#)))))
+ (cons (let ((#{m2 42121}# (car #{w2 42100}#)))
+ (if (null? #{m2 42121}#)
+ #{m1 42101}#
+ (append #{m1 42101}# #{m2 42121}#)))
+ (let ((#{m2 42129}# (cdr #{w2 42100}#)))
+ (if (null? #{m2 42129}#)
+ #{s1 42102}#
+ (append #{s1 42102}# #{m2 42129}#)))))))
+ (vector-ref #{e 42071}# 3))
+ #f)))))
+ (#{match-each-any 41194}#
+ (lambda (#{e 42138}# #{w 42139}# #{mod 42140}#)
+ (if (pair? #{e 42138}#)
+ (let ((#{l 42141}#
+ (#{match-each-any 41194}#
+ (cdr #{e 42138}#)
+ #{w 42139}#
+ #{mod 42140}#)))
+ (if #{l 42141}#
+ (cons (let ((#{x 42146}# (car #{e 42138}#)))
+ (if (if (null? (car #{w 42139}#))
+ (null? (cdr #{w 42139}#))
+ #f)
+ #{x 42146}#
+ (if (if (vector? #{x 42146}#)
+ (if (= (vector-length #{x 42146}#) 4)
+ (eq? (vector-ref #{x 42146}# 0)
+ 'syntax-object)
+ #f)
#f)
- #f)))
- (if (eqv? #{atom-key 14811}# 'free-id)
- (if (if (symbol? #{e 14797}#)
+ (let ((#{expression 42164}#
+ (vector-ref #{x 42146}# 1))
+ (#{wrap 42165}#
+ (let ((#{w2 42173}#
+ (vector-ref #{x 42146}# 2)))
+ (let ((#{m1 42174}# (car #{w 42139}#))
+ (#{s1 42175}# (cdr #{w 42139}#)))
+ (if (null? #{m1 42174}#)
+ (if (null? #{s1 42175}#)
+ #{w2 42173}#
+ (cons (car #{w2 42173}#)
+ (let ((#{m2 42190}#
+ (cdr #{w2 42173}#)))
+ (if (null? #{m2 42190}#)
+ #{s1 42175}#
+ (append
+ #{s1 42175}#
+ #{m2 42190}#)))))
+ (cons (let ((#{m2 42198}#
+ (car #{w2 42173}#)))
+ (if (null? #{m2 42198}#)
+ #{m1 42174}#
+ (append
+ #{m1 42174}#
+ #{m2 42198}#)))
+ (let ((#{m2 42206}#
+ (cdr #{w2 42173}#)))
+ (if (null? #{m2 42206}#)
+ #{s1 42175}#
+ (append
+ #{s1 42175}#
+ #{m2 42206}#))))))))
+ (#{module 42166}#
+ (vector-ref #{x 42146}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 42164}#
+ #{wrap 42165}#
+ #{module 42166}#))
+ (if (null? #{x 42146}#)
+ #{x 42146}#
+ (vector
+ 'syntax-object
+ #{x 42146}#
+ #{w 42139}#
+ #{mod 42140}#)))))
+ #{l 42141}#)
+ #f))
+ (if (null? #{e 42138}#)
+ '()
+ (if (if (vector? #{e 42138}#)
+ (if (= (vector-length #{e 42138}#) 4)
+ (eq? (vector-ref #{e 42138}# 0) 'syntax-object)
+ #f)
+ #f)
+ (#{match-each-any 41194}#
+ (vector-ref #{e 42138}# 1)
+ (let ((#{w2 42239}# (vector-ref #{e 42138}# 2)))
+ (let ((#{m1 42240}# (car #{w 42139}#))
+ (#{s1 42241}# (cdr #{w 42139}#)))
+ (if (null? #{m1 42240}#)
+ (if (null? #{s1 42241}#)
+ #{w2 42239}#
+ (cons (car #{w2 42239}#)
+ (let ((#{m2 42252}# (cdr #{w2 42239}#)))
+ (if (null? #{m2 42252}#)
+ #{s1 42241}#
+ (append #{s1 42241}# #{m2 42252}#)))))
+ (cons (let ((#{m2 42260}# (car #{w2 42239}#)))
+ (if (null? #{m2 42260}#)
+ #{m1 42240}#
+ (append #{m1 42240}# #{m2 42260}#)))
+ (let ((#{m2 42268}# (cdr #{w2 42239}#)))
+ (if (null? #{m2 42268}#)
+ #{s1 42241}#
+ (append #{s1 42241}# #{m2 42268}#)))))))
+ #{mod 42140}#)
+ #f)))))
+ (#{match-empty 41195}#
+ (lambda (#{p 42273}# #{r 42274}#)
+ (if (null? #{p 42273}#)
+ #{r 42274}#
+ (if (eq? #{p 42273}# '_)
+ #{r 42274}#
+ (if (eq? #{p 42273}# 'any)
+ (cons '() #{r 42274}#)
+ (if (pair? #{p 42273}#)
+ (#{match-empty 41195}#
+ (car #{p 42273}#)
+ (#{match-empty 41195}#
+ (cdr #{p 42273}#)
+ #{r 42274}#))
+ (if (eq? #{p 42273}# 'each-any)
+ (cons '() #{r 42274}#)
+ (let ((#{atom-key 42275}# (vector-ref #{p 42273}# 0)))
+ (if (eqv? #{atom-key 42275}# 'each)
+ (#{match-empty 41195}#
+ (vector-ref #{p 42273}# 1)
+ #{r 42274}#)
+ (if (eqv? #{atom-key 42275}# 'each+)
+ (#{match-empty 41195}#
+ (vector-ref #{p 42273}# 1)
+ (#{match-empty 41195}#
+ (reverse (vector-ref #{p 42273}# 2))
+ (#{match-empty 41195}#
+ (vector-ref #{p 42273}# 3)
+ #{r 42274}#)))
+ (if (if (eqv? #{atom-key 42275}# 'free-id)
#t
- (if (if (vector? #{e 14797}#)
- (if (= (vector-length #{e 14797}#) 4)
- (eq? (vector-ref #{e 14797}# 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref #{e 14797}# 1))
- #f))
- (if (let ((#{i 15253}#
- (#{wrap 4443}#
- #{e 14797}#
- #{w 14799}#
- #{mod 14801}#))
- (#{j 15254}#
- (vector-ref #{p 14798}# 1)))
- (if (eq? (if (if (vector? #{i 15253}#)
- (if (= (vector-length
- #{i 15253}#)
- 4)
- (eq? (vector-ref
- #{i 15253}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref #{i 15253}# 1)
- #{i 15253}#)
- (if (if (vector? #{j 15254}#)
- (if (= (vector-length
- #{j 15254}#)
- 4)
- (eq? (vector-ref
- #{j 15254}#
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref #{j 15254}# 1)
- #{j 15254}#))
- (eq? (#{id-var-name 4434}#
- #{i 15253}#
- '(()))
- (#{id-var-name 4434}#
- #{j 15254}#
- '(())))
- #f))
- #{r 14800}#
+ (eqv? #{atom-key 42275}# 'atom))
+ #{r 42274}#
+ (if (eqv? #{atom-key 42275}# 'vector)
+ (#{match-empty 41195}#
+ (vector-ref #{p 42273}# 1)
+ #{r 42274}#)))))))))))))
+ (#{combine 41196}#
+ (lambda (#{r* 42294}# #{r 42295}#)
+ (if (null? (car #{r* 42294}#))
+ #{r 42295}#
+ (cons (map car #{r* 42294}#)
+ (#{combine 41196}#
+ (map cdr #{r* 42294}#)
+ #{r 42295}#)))))
+ (#{match* 41197}#
+ (lambda (#{e 41227}#
+ #{p 41228}#
+ #{w 41229}#
+ #{r 41230}#
+ #{mod 41231}#)
+ (if (null? #{p 41228}#)
+ (if (null? #{e 41227}#) #{r 41230}# #f)
+ (if (pair? #{p 41228}#)
+ (if (pair? #{e 41227}#)
+ (#{match 41198}#
+ (car #{e 41227}#)
+ (car #{p 41228}#)
+ #{w 41229}#
+ (#{match 41198}#
+ (cdr #{e 41227}#)
+ (cdr #{p 41228}#)
+ #{w 41229}#
+ #{r 41230}#
+ #{mod 41231}#)
+ #{mod 41231}#)
+ #f)
+ (if (eq? #{p 41228}# 'each-any)
+ (let ((#{l 41236}#
+ (#{match-each-any 41194}#
+ #{e 41227}#
+ #{w 41229}#
+ #{mod 41231}#)))
+ (if #{l 41236}#
+ (cons #{l 41236}# #{r 41230}#)
+ #f))
+ (let ((#{atom-key 41241}# (vector-ref #{p 41228}# 0)))
+ (if (eqv? #{atom-key 41241}# 'each)
+ (if (null? #{e 41227}#)
+ (#{match-empty 41195}#
+ (vector-ref #{p 41228}# 1)
+ #{r 41230}#)
+ (let ((#{l 41248}#
+ (#{match-each 41192}#
+ #{e 41227}#
+ (vector-ref #{p 41228}# 1)
+ #{w 41229}#
+ #{mod 41231}#)))
+ (if #{l 41248}#
+ (letrec*
+ ((#{collect 41251}#
+ (lambda (#{l 41308}#)
+ (if (null? (car #{l 41308}#))
+ #{r 41230}#
+ (cons (map car #{l 41308}#)
+ (#{collect 41251}#
+ (map cdr #{l 41308}#)))))))
+ (#{collect 41251}# #{l 41248}#))
+ #f)))
+ (if (eqv? #{atom-key 41241}# 'each+)
+ (call-with-values
+ (lambda ()
+ (let ((#{x-pat 41317}# (vector-ref #{p 41228}# 1))
+ (#{y-pat 41318}# (vector-ref #{p 41228}# 2))
+ (#{z-pat 41319}# (vector-ref #{p 41228}# 3)))
+ (letrec*
+ ((#{f 41323}#
+ (lambda (#{e 41325}# #{w 41326}#)
+ (if (pair? #{e 41325}#)
+ (call-with-values
+ (lambda ()
+ (#{f 41323}#
+ (cdr #{e 41325}#)
+ #{w 41326}#))
+ (lambda (#{xr* 41327}#
+ #{y-pat 41328}#
+ #{r 41329}#)
+ (if #{r 41329}#
+ (if (null? #{y-pat 41328}#)
+ (let ((#{xr 41330}#
+ (#{match 41198}#
+ (car #{e 41325}#)
+ #{x-pat 41317}#
+ #{w 41326}#
+ '()
+ #{mod 41231}#)))
+ (if #{xr 41330}#
+ (values
+ (cons #{xr 41330}#
+ #{xr* 41327}#)
+ #{y-pat 41328}#
+ #{r 41329}#)
+ (values #f #f #f)))
+ (values
+ '()
+ (cdr #{y-pat 41328}#)
+ (#{match 41198}#
+ (car #{e 41325}#)
+ (car #{y-pat 41328}#)
+ #{w 41326}#
+ #{r 41329}#
+ #{mod 41231}#)))
+ (values #f #f #f))))
+ (if (if (vector? #{e 41325}#)
+ (if (= (vector-length #{e 41325}#)
+ 4)
+ (eq? (vector-ref #{e 41325}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (#{f 41323}#
+ (vector-ref #{e 41325}# 1)
+ (let ((#{m1 41356}#
+ (car #{w 41326}#))
+ (#{s1 41357}#
+ (cdr #{w 41326}#)))
+ (if (null? #{m1 41356}#)
+ (if (null? #{s1 41357}#)
+ #{e 41325}#
+ (cons (car #{e 41325}#)
+ (let ((#{m2 41369}#
+ (cdr #{e 41325}#)))
+ (if (null? #{m2 41369}#)
+ #{s1 41357}#
+ (append
+ #{s1 41357}#
+ #{m2 41369}#)))))
+ (cons (let ((#{m2 41379}#
+ (car #{e 41325}#)))
+ (if (null? #{m2 41379}#)
+ #{m1 41356}#
+ (append
+ #{m1 41356}#
+ #{m2 41379}#)))
+ (let ((#{m2 41389}#
+ (cdr #{e 41325}#)))
+ (if (null? #{m2 41389}#)
+ #{s1 41357}#
+ (append
+ #{s1 41357}#
+ #{m2 41389}#)))))))
+ (values
+ '()
+ #{y-pat 41318}#
+ (#{match 41198}#
+ #{e 41325}#
+ #{z-pat 41319}#
+ #{w 41326}#
+ #{r 41230}#
+ #{mod 41231}#)))))))
+ (#{f 41323}# #{e 41227}# #{w 41229}#))))
+ (lambda (#{xr* 41399}# #{y-pat 41400}# #{r 41401}#)
+ (if #{r 41401}#
+ (if (null? #{y-pat 41400}#)
+ (if (null? #{xr* 41399}#)
+ (#{match-empty 41195}#
+ (vector-ref #{p 41228}# 1)
+ #{r 41401}#)
+ (#{combine 41196}# #{xr* 41399}# #{r 41401}#))
#f)
+ #f)))
+ (if (eqv? #{atom-key 41241}# 'free-id)
+ (if (if (symbol? #{e 41227}#)
+ #t
+ (if (if (vector? #{e 41227}#)
+ (if (= (vector-length #{e 41227}#) 4)
+ (eq? (vector-ref #{e 41227}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref #{e 41227}# 1))
+ #f))
+ (if (#{free-id=? 28259}#
+ (if (if (null? (car #{w 41229}#))
+ (null? (cdr #{w 41229}#))
+ #f)
+ #{e 41227}#
+ (if (if (vector? #{e 41227}#)
+ (if (= (vector-length #{e 41227}#) 4)
+ (eq? (vector-ref #{e 41227}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 41829}#
+ (vector-ref #{e 41227}# 1))
+ (#{wrap 41830}#
+ (let ((#{w2 41840}#
+ (vector-ref
+ #{e 41227}#
+ 2)))
+ (let ((#{m1 41841}#
+ (car #{w 41229}#))
+ (#{s1 41842}#
+ (cdr #{w 41229}#)))
+ (if (null? #{m1 41841}#)
+ (if (null? #{s1 41842}#)
+ #{w2 41840}#
+ (cons (car #{w2 41840}#)
+ (let ((#{m2 41859}#
+ (cdr #{w2 41840}#)))
+ (if (null? #{m2 41859}#)
+ #{s1 41842}#
+ (append
+ #{s1 41842}#
+ #{m2 41859}#)))))
+ (cons (let ((#{m2 41867}#
+ (car #{w2 41840}#)))
+ (if (null? #{m2 41867}#)
+ #{m1 41841}#
+ (append
+ #{m1 41841}#
+ #{m2 41867}#)))
+ (let ((#{m2 41875}#
+ (cdr #{w2 41840}#)))
+ (if (null? #{m2 41875}#)
+ #{s1 41842}#
+ (append
+ #{s1 41842}#
+ #{m2 41875}#))))))))
+ (#{module 41831}#
+ (vector-ref #{e 41227}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 41829}#
+ #{wrap 41830}#
+ #{module 41831}#))
+ (if (null? #{e 41227}#)
+ #{e 41227}#
+ (vector
+ 'syntax-object
+ #{e 41227}#
+ #{w 41229}#
+ #{mod 41231}#))))
+ (vector-ref #{p 41228}# 1))
+ #{r 41230}#
#f)
- (if (eqv? #{atom-key 14811}# 'atom)
- (if (equal?
- (vector-ref #{p 14798}# 1)
- (#{strip 4463}# #{e 14797}# #{w 14799}#))
- #{r 14800}#
- #f)
- (if (eqv? #{atom-key 14811}# 'vector)
- (if (vector? #{e 14797}#)
- (#{match 14768}#
- (vector->list #{e 14797}#)
- (vector-ref #{p 14798}# 1)
- #{w 14799}#
- #{r 14800}#
- #{mod 14801}#)
- #f))))))))))))
- (#{match 14768}#
- (lambda (#{e 15314}#
- #{p 15315}#
- #{w 15316}#
- #{r 15317}#
- #{mod 15318}#)
- (if (not #{r 15317}#)
- #f
- (if (eq? #{p 15315}# '_)
- #{r 15317}#
- (if (eq? #{p 15315}# 'any)
- (cons (#{wrap 4443}#
- #{e 15314}#
- #{w 15316}#
- #{mod 15318}#)
- #{r 15317}#)
- (if (if (vector? #{e 15314}#)
- (if (= (vector-length #{e 15314}#) 4)
- (eq? (vector-ref #{e 15314}# 0) 'syntax-object)
#f)
+ (if (eqv? #{atom-key 41241}# 'atom)
+ (if (equal?
+ (vector-ref #{p 41228}# 1)
+ (#{strip 28284}# #{e 41227}# #{w 41229}#))
+ #{r 41230}#
+ #f)
+ (if (eqv? #{atom-key 41241}# 'vector)
+ (if (vector? #{e 41227}#)
+ (#{match 41198}#
+ (vector->list #{e 41227}#)
+ (vector-ref #{p 41228}# 1)
+ #{w 41229}#
+ #{r 41230}#
+ #{mod 41231}#)
+ #f))))))))))))
+ (#{match 41198}#
+ (lambda (#{e 41908}#
+ #{p 41909}#
+ #{w 41910}#
+ #{r 41911}#
+ #{mod 41912}#)
+ (if (not #{r 41911}#)
+ #f
+ (if (eq? #{p 41909}# '_)
+ #{r 41911}#
+ (if (eq? #{p 41909}# 'any)
+ (cons (if (if (null? (car #{w 41910}#))
+ (null? (cdr #{w 41910}#))
+ #f)
+ #{e 41908}#
+ (if (if (vector? #{e 41908}#)
+ (if (= (vector-length #{e 41908}#) 4)
+ (eq? (vector-ref #{e 41908}# 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((#{expression 41942}#
+ (vector-ref #{e 41908}# 1))
+ (#{wrap 41943}#
+ (let ((#{w2 41953}#
+ (vector-ref #{e 41908}# 2)))
+ (let ((#{m1 41954}# (car #{w 41910}#))
+ (#{s1 41955}# (cdr #{w 41910}#)))
+ (if (null? #{m1 41954}#)
+ (if (null? #{s1 41955}#)
+ #{w2 41953}#
+ (cons (car #{w2 41953}#)
+ (let ((#{m2 41972}#
+ (cdr #{w2 41953}#)))
+ (if (null? #{m2 41972}#)
+ #{s1 41955}#
+ (append
+ #{s1 41955}#
+ #{m2 41972}#)))))
+ (cons (let ((#{m2 41980}#
+ (car #{w2 41953}#)))
+ (if (null? #{m2 41980}#)
+ #{m1 41954}#
+ (append
+ #{m1 41954}#
+ #{m2 41980}#)))
+ (let ((#{m2 41988}#
+ (cdr #{w2 41953}#)))
+ (if (null? #{m2 41988}#)
+ #{s1 41955}#
+ (append
+ #{s1 41955}#
+ #{m2 41988}#))))))))
+ (#{module 41944}# (vector-ref #{e 41908}# 3)))
+ (vector
+ 'syntax-object
+ #{expression 41942}#
+ #{wrap 41943}#
+ #{module 41944}#))
+ (if (null? #{e 41908}#)
+ #{e 41908}#
+ (vector
+ 'syntax-object
+ #{e 41908}#
+ #{w 41910}#
+ #{mod 41912}#))))
+ #{r 41911}#)
+ (if (if (vector? #{e 41908}#)
+ (if (= (vector-length #{e 41908}#) 4)
+ (eq? (vector-ref #{e 41908}# 0) 'syntax-object)
#f)
- (#{match* 14767}#
- (vector-ref #{e 15314}# 1)
- #{p 15315}#
- (#{join-wraps 4431}#
- #{w 15316}#
- (vector-ref #{e 15314}# 2))
- #{r 15317}#
- (vector-ref #{e 15314}# 3))
- (#{match* 14767}#
- #{e 15314}#
- #{p 15315}#
- #{w 15316}#
- #{r 15317}#
- #{mod 15318}#))))))))
- (set! $sc-dispatch
- (lambda (#{e 14769}# #{p 14770}#)
- (if (eq? #{p 14770}# 'any)
- (list #{e 14769}#)
- (if (eq? #{p 14770}# '_)
- '()
- (if (if (vector? #{e 14769}#)
- (if (= (vector-length #{e 14769}#) 4)
- (eq? (vector-ref #{e 14769}# 0) 'syntax-object)
- #f)
+ #f)
+ (#{match* 41197}#
+ (vector-ref #{e 41908}# 1)
+ #{p 41909}#
+ (let ((#{w2 42031}# (vector-ref #{e 41908}# 2)))
+ (let ((#{m1 42032}# (car #{w 41910}#))
+ (#{s1 42033}# (cdr #{w 41910}#)))
+ (if (null? #{m1 42032}#)
+ (if (null? #{s1 42033}#)
+ #{w2 42031}#
+ (cons (car #{w2 42031}#)
+ (let ((#{m2 42044}# (cdr #{w2 42031}#)))
+ (if (null? #{m2 42044}#)
+ #{s1 42033}#
+ (append #{s1 42033}# #{m2 42044}#)))))
+ (cons (let ((#{m2 42052}# (car #{w2 42031}#)))
+ (if (null? #{m2 42052}#)
+ #{m1 42032}#
+ (append #{m1 42032}# #{m2 42052}#)))
+ (let ((#{m2 42060}# (cdr #{w2 42031}#)))
+ (if (null? #{m2 42060}#)
+ #{s1 42033}#
+ (append #{s1 42033}# #{m2 42060}#)))))))
+ #{r 41911}#
+ (vector-ref #{e 41908}# 3))
+ (#{match* 41197}#
+ #{e 41908}#
+ #{p 41909}#
+ #{w 41910}#
+ #{r 41911}#
+ #{mod 41912}#))))))))
+ (set! $sc-dispatch
+ (lambda (#{e 41199}# #{p 41200}#)
+ (if (eq? #{p 41200}# 'any)
+ (list #{e 41199}#)
+ (if (eq? #{p 41200}# '_)
+ '()
+ (if (if (vector? #{e 41199}#)
+ (if (= (vector-length #{e 41199}#) 4)
+ (eq? (vector-ref #{e 41199}# 0) 'syntax-object)
#f)
- (#{match* 14767}#
- (vector-ref #{e 14769}# 1)
- #{p 14770}#
- (vector-ref #{e 14769}# 2)
- '()
- (vector-ref #{e 14769}# 3))
- (#{match* 14767}#
- #{e 14769}#
- #{p 14770}#
- '(())
- '()
- #f))))))))))
+ #f)
+ (#{match* 41197}#
+ (vector-ref #{e 41199}# 1)
+ #{p 41200}#
+ (vector-ref #{e 41199}# 2)
+ '()
+ (vector-ref #{e 41199}# 3))
+ (#{match* 41197}#
+ #{e 41199}#
+ #{p 41200}#
+ '(())
+ '()
+ #f)))))))))
(define with-syntax
(make-syntax-transformer
'with-syntax
'macro
- (lambda (#{x 26694}#)
- (let ((#{tmp 26696}#
- ($sc-dispatch #{x 26694}# '(_ () any . each-any))))
- (if #{tmp 26696}#
+ (lambda (#{x 59996}#)
+ (let ((#{tmp 59998}#
+ ($sc-dispatch #{x 59996}# '(_ () any . each-any))))
+ (if #{tmp 59998}#
(@apply
- (lambda (#{e1 26700}# #{e2 26701}#)
+ (lambda (#{e1 60002}# #{e2 60003}#)
(cons '#(syntax-object
let
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("i26667" "i26668"))
+ #("i59969" "i59970"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26664")))
+ #(ribcage #(x) #((top)) #("i59966"))
+ #(ribcage
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons '() (cons #{e1 26700}# #{e2 26701}#))))
- #{tmp 26696}#)
- (let ((#{tmp 26702}#
+ (cons '() (cons #{e1 60002}# #{e2 60003}#))))
+ #{tmp 59998}#)
+ (let ((#{tmp 60004}#
($sc-dispatch
- #{x 26694}#
+ #{x 59996}#
'(_ ((any any)) any . each-any))))
- (if #{tmp 26702}#
+ (if #{tmp 60004}#
(@apply
- (lambda (#{out 26706}#
- #{in 26707}#
- #{e1 26708}#
- #{e2 26709}#)
+ (lambda (#{out 60008}#
+ #{in 60009}#
+ #{e1 60010}#
+ #{e2 60011}#)
(list '#(syntax-object
syntax-case
((top)
#(ribcage
#(out in e1 e2)
#((top) (top) (top) (top))
- #("i26673" "i26674" "i26675" "i26676"))
+ #("i59975" "i59976" "i59977" "i59978"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26664")))
+ #(ribcage #(x) #((top)) #("i59966"))
+ #(ribcage
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{in 26707}#
+ #{in 60009}#
'()
- (list #{out 26706}#
+ (list #{out 60008}#
(cons '#(syntax-object
let
((top)
#(ribcage
#(out in e1 e2)
#((top) (top) (top) (top))
- #("i26673"
- "i26674"
- "i26675"
- "i26676"))
+ #("i59975"
+ "i59976"
+ "i59977"
+ "i59978"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26664")))
+ #(ribcage #(x) #((top)) #("i59966"))
+ #(ribcage
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(cons '()
- (cons #{e1 26708}# #{e2 26709}#))))))
- #{tmp 26702}#)
- (let ((#{tmp 26710}#
+ (cons #{e1 60010}# #{e2 60011}#))))))
+ #{tmp 60004}#)
+ (let ((#{tmp 60012}#
($sc-dispatch
- #{x 26694}#
+ #{x 59996}#
'(_ #(each (any any)) any . each-any))))
- (if #{tmp 26710}#
+ (if #{tmp 60012}#
(@apply
- (lambda (#{out 26714}#
- #{in 26715}#
- #{e1 26716}#
- #{e2 26717}#)
+ (lambda (#{out 60016}#
+ #{in 60017}#
+ #{e1 60018}#
+ #{e2 60019}#)
(list '#(syntax-object
syntax-case
((top)
#(ribcage
#(out in e1 e2)
#((top) (top) (top) (top))
- #("i26683" "i26684" "i26685" "i26686"))
+ #("i59985" "i59986" "i59987" "i59988"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26664")))
+ #(ribcage #(x) #((top)) #("i59966"))
+ #(ribcage
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(cons '#(syntax-object
list
@@ -22573,62 +17905,89 @@
#(ribcage
#(out in e1 e2)
#((top) (top) (top) (top))
- #("i26683" "i26684" "i26685" "i26686"))
+ #("i59985" "i59986" "i59987" "i59988"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26664")))
+ #(ribcage #(x) #((top)) #("i59966"))
+ #(ribcage
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{in 26715}#)
+ #{in 60017}#)
'()
- (list #{out 26714}#
+ (list #{out 60016}#
(cons '#(syntax-object
let
((top)
#(ribcage
#(out in e1 e2)
#((top) (top) (top) (top))
- #("i26683"
- "i26684"
- "i26685"
- "i26686"))
+ #("i59985"
+ "i59986"
+ "i59987"
+ "i59988"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i26664")))
+ #("i59966"))
+ #(ribcage
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(cons '()
- (cons #{e1 26716}#
- #{e2 26717}#))))))
- #{tmp 26710}#)
+ (cons #{e1 60018}#
+ #{e2 60019}#))))))
+ #{tmp 60012}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 26694}#))))))))))
+ #{x 59996}#))))))))))
(define syntax-rules
(make-syntax-transformer
'syntax-rules
'macro
- (lambda (#{x 26771}#)
- (let ((#{tmp 26773}#
+ (lambda (#{x 60074}#)
+ (let ((#{tmp 60076}#
($sc-dispatch
- #{x 26771}#
+ #{x 60074}#
'(_ each-any . #(each ((any . any) any))))))
- (if #{tmp 26773}#
+ (if #{tmp 60076}#
(@apply
- (lambda (#{k 26777}#
- #{keyword 26778}#
- #{pattern 26779}#
- #{template 26780}#)
+ (lambda (#{k 60080}#
+ #{keyword 60081}#
+ #{pattern 60082}#
+ #{template 60083}#)
(list '#(syntax-object
lambda
((top)
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("i26734" "i26735" "i26736" "i26737"))
+ #("i60037" "i60038" "i60039" "i60040"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
x
@@ -22636,9 +17995,18 @@
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("i26734" "i26735" "i26736" "i26737"))
+ #("i60037" "i60038" "i60039" "i60040"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
(vector
'(#(syntax-object
@@ -22647,9 +18015,18 @@
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("i26734" "i26735" "i26736" "i26737"))
+ #("i60037" "i60038" "i60039" "i60040"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
.
#(syntax-object
@@ -22658,9 +18035,18 @@
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("i26734" "i26735" "i26736" "i26737"))
+ #("i60037" "i60038" "i60039" "i60040"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
(cons '#(syntax-object
patterns
@@ -22668,20 +18054,38 @@
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("i26734" "i26735" "i26736" "i26737"))
+ #("i60037" "i60038" "i60039" "i60040"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{pattern 26779}#))
+ #{pattern 60082}#))
(cons '#(syntax-object
syntax-case
((top)
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("i26734" "i26735" "i26736" "i26737"))
+ #("i60037" "i60038" "i60039" "i60040"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(cons '#(syntax-object
x
@@ -22689,15 +18093,24 @@
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("i26734" "i26735" "i26736" "i26737"))
+ #("i60037" "i60038" "i60039" "i60040"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons #{k 26777}#
- (map (lambda (#{tmp 26745 26781}#
- #{tmp 26744 26782}#)
+ (cons #{k 60080}#
+ (map (lambda (#{tmp 60048 60084}#
+ #{tmp 60047 60085}#)
(list (cons '#(syntax-object
- dummy
+ _
((top)
#(ribcage
#(k
@@ -22708,10 +18121,10 @@
(top)
(top)
(top))
- #("i26734"
- "i26735"
- "i26736"
- "i26737"))
+ #("i60037"
+ "i60038"
+ "i60039"
+ "i60040"))
#(ribcage
()
()
@@ -22719,9 +18132,20 @@
#(ribcage
#(x)
#((top))
- #("i26731")))
+ #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- #{tmp 26744 26782}#)
+ #{tmp 60047 60085}#)
(list '#(syntax-object
syntax
((top)
@@ -22734,10 +18158,10 @@
(top)
(top)
(top))
- #("i26734"
- "i26735"
- "i26736"
- "i26737"))
+ #("i60037"
+ "i60038"
+ "i60039"
+ "i60040"))
#(ribcage
()
()
@@ -22745,41 +18169,61 @@
#(ribcage
#(x)
#((top))
- #("i26731")))
+ #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- #{tmp 26745 26781}#)))
- #{template 26780}#
- #{pattern 26779}#))))))
- #{tmp 26773}#)
- (let ((#{tmp 26783}#
+ #{tmp 60048 60084}#)))
+ #{template 60083}#
+ #{pattern 60082}#))))))
+ #{tmp 60076}#)
+ (let ((#{tmp 60086}#
($sc-dispatch
- #{x 26771}#
+ #{x 60074}#
'(_ each-any any . #(each ((any . any) any))))))
- (if (if #{tmp 26783}#
+ (if (if #{tmp 60086}#
(@apply
- (lambda (#{k 26787}#
- #{docstring 26788}#
- #{keyword 26789}#
- #{pattern 26790}#
- #{template 26791}#)
- (string? (syntax->datum #{docstring 26788}#)))
- #{tmp 26783}#)
+ (lambda (#{k 60090}#
+ #{docstring 60091}#
+ #{keyword 60092}#
+ #{pattern 60093}#
+ #{template 60094}#)
+ (string? (syntax->datum #{docstring 60091}#)))
+ #{tmp 60086}#)
#f)
(@apply
- (lambda (#{k 26792}#
- #{docstring 26793}#
- #{keyword 26794}#
- #{pattern 26795}#
- #{template 26796}#)
+ (lambda (#{k 60095}#
+ #{docstring 60096}#
+ #{keyword 60097}#
+ #{pattern 60098}#
+ #{template 60099}#)
(list '#(syntax-object
lambda
((top)
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("i26757" "i26758" "i26759" "i26760" "i26761"))
+ #("i60060" "i60061" "i60062" "i60063" "i60064"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
x
@@ -22787,11 +18231,20 @@
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("i26757" "i26758" "i26759" "i26760" "i26761"))
+ #("i60060" "i60061" "i60062" "i60063" "i60064"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- #{docstring 26793}#
+ #{docstring 60096}#
(vector
'(#(syntax-object
macro-type
@@ -22799,13 +18252,22 @@
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("i26757"
- "i26758"
- "i26759"
- "i26760"
- "i26761"))
+ #("i60060"
+ "i60061"
+ "i60062"
+ "i60063"
+ "i60064"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
.
#(syntax-object
@@ -22814,13 +18276,22 @@
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("i26757"
- "i26758"
- "i26759"
- "i26760"
- "i26761"))
+ #("i60060"
+ "i60061"
+ "i60062"
+ "i60063"
+ "i60064"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
(cons '#(syntax-object
patterns
@@ -22828,28 +18299,46 @@
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("i26757"
- "i26758"
- "i26759"
- "i26760"
- "i26761"))
+ #("i60060"
+ "i60061"
+ "i60062"
+ "i60063"
+ "i60064"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{pattern 26795}#))
+ #{pattern 60098}#))
(cons '#(syntax-object
syntax-case
((top)
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("i26757"
- "i26758"
- "i26759"
- "i26760"
- "i26761"))
+ #("i60060"
+ "i60061"
+ "i60062"
+ "i60063"
+ "i60064"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(cons '#(syntax-object
x
@@ -22861,19 +18350,28 @@
pattern
template)
#((top) (top) (top) (top) (top))
- #("i26757"
- "i26758"
- "i26759"
- "i26760"
- "i26761"))
+ #("i60060"
+ "i60061"
+ "i60062"
+ "i60063"
+ "i60064"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26731")))
+ #(ribcage #(x) #((top)) #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons #{k 26792}#
- (map (lambda (#{tmp 26770 26797}#
- #{tmp 26769 26798}#)
+ (cons #{k 60095}#
+ (map (lambda (#{tmp 60073 60100}#
+ #{tmp 60072 60101}#)
(list (cons '#(syntax-object
- dummy
+ _
((top)
#(ribcage
#(k
@@ -22886,11 +18384,11 @@
(top)
(top)
(top))
- #("i26757"
- "i26758"
- "i26759"
- "i26760"
- "i26761"))
+ #("i60060"
+ "i60061"
+ "i60062"
+ "i60063"
+ "i60064"))
#(ribcage
()
()
@@ -22898,10 +18396,21 @@
#(ribcage
#(x)
#((top))
- #("i26731")))
+ #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- #{tmp 26769 26798}#)
+ #{tmp 60072 60101}#)
(list '#(syntax-object
syntax
((top)
@@ -22916,11 +18425,11 @@
(top)
(top)
(top))
- #("i26757"
- "i26758"
- "i26759"
- "i26760"
- "i26761"))
+ #("i60060"
+ "i60061"
+ "i60062"
+ "i60063"
+ "i60064"))
#(ribcage
()
()
@@ -22928,50 +18437,79 @@
#(ribcage
#(x)
#((top))
- #("i26731")))
+ #("i60034"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- #{tmp 26770 26797}#)))
- #{template 26796}#
- #{pattern 26795}#))))))
- #{tmp 26783}#)
+ #{tmp 60073 60100}#)))
+ #{template 60099}#
+ #{pattern 60098}#))))))
+ #{tmp 60086}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 26771}#))))))))
+ #{x 60074}#))))))))
(define define-syntax-rule
(make-syntax-transformer
'define-syntax-rule
'macro
- (lambda (#{x 26835}#)
- (let ((#{tmp 26837}#
- ($sc-dispatch #{x 26835}# '(_ (any . any) any))))
- (if #{tmp 26837}#
+ (lambda (#{x 60139}#)
+ (let ((#{tmp 60141}#
+ ($sc-dispatch #{x 60139}# '(_ (any . any) any))))
+ (if #{tmp 60141}#
(@apply
- (lambda (#{name 26841}#
- #{pattern 26842}#
- #{template 26843}#)
+ (lambda (#{name 60145}#
+ #{pattern 60146}#
+ #{template 60147}#)
(list '#(syntax-object
define-syntax
((top)
#(ribcage
#(name pattern template)
#((top) (top) (top))
- #("i26812" "i26813" "i26814"))
+ #("i60116" "i60117" "i60118"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26809")))
+ #(ribcage #(x) #((top)) #("i60113"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{name 26841}#
+ #{name 60145}#
(list '#(syntax-object
syntax-rules
((top)
#(ribcage
#(name pattern template)
#((top) (top) (top))
- #("i26812" "i26813" "i26814"))
+ #("i60116" "i60117" "i60118"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26809")))
+ #(ribcage #(x) #((top)) #("i60113"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'()
(list (cons '#(syntax-object
@@ -22980,54 +18518,81 @@
#(ribcage
#(name pattern template)
#((top) (top) (top))
- #("i26812" "i26813" "i26814"))
+ #("i60116" "i60117" "i60118"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26809")))
+ #(ribcage #(x) #((top)) #("i60113"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{pattern 26842}#)
- #{template 26843}#))))
- #{tmp 26837}#)
- (let ((#{tmp 26844}#
+ #{pattern 60146}#)
+ #{template 60147}#))))
+ #{tmp 60141}#)
+ (let ((#{tmp 60148}#
($sc-dispatch
- #{x 26835}#
+ #{x 60139}#
'(_ (any . any) any any))))
- (if (if #{tmp 26844}#
+ (if (if #{tmp 60148}#
(@apply
- (lambda (#{name 26848}#
- #{pattern 26849}#
- #{docstring 26850}#
- #{template 26851}#)
- (string? (syntax->datum #{docstring 26850}#)))
- #{tmp 26844}#)
+ (lambda (#{name 60152}#
+ #{pattern 60153}#
+ #{docstring 60154}#
+ #{template 60155}#)
+ (string? (syntax->datum #{docstring 60154}#)))
+ #{tmp 60148}#)
#f)
(@apply
- (lambda (#{name 26852}#
- #{pattern 26853}#
- #{docstring 26854}#
- #{template 26855}#)
+ (lambda (#{name 60156}#
+ #{pattern 60157}#
+ #{docstring 60158}#
+ #{template 60159}#)
(list '#(syntax-object
define-syntax
((top)
#(ribcage
#(name pattern docstring template)
#((top) (top) (top) (top))
- #("i26827" "i26828" "i26829" "i26830"))
+ #("i60131" "i60132" "i60133" "i60134"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26809")))
+ #(ribcage #(x) #((top)) #("i60113"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{name 26852}#
+ #{name 60156}#
(list '#(syntax-object
syntax-rules
((top)
#(ribcage
#(name pattern docstring template)
#((top) (top) (top) (top))
- #("i26827" "i26828" "i26829" "i26830"))
+ #("i60131" "i60132" "i60133" "i60134"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26809")))
+ #(ribcage #(x) #((top)) #("i60113"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'()
- #{docstring 26854}#
+ #{docstring 60158}#
(list (cons '#(syntax-object
_
((top)
@@ -23037,53 +18602,62 @@
docstring
template)
#((top) (top) (top) (top))
- #("i26827"
- "i26828"
- "i26829"
- "i26830"))
+ #("i60131"
+ "i60132"
+ "i60133"
+ "i60134"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i26809")))
+ #("i60113"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{pattern 26853}#)
- #{template 26855}#))))
- #{tmp 26844}#)
+ #{pattern 60157}#)
+ #{template 60159}#))))
+ #{tmp 60148}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 26835}#))))))))
+ #{x 60139}#))))))))
(define let*
(make-syntax-transformer
'let*
'macro
- (lambda (#{x 26904}#)
- (let ((#{tmp 26906}#
+ (lambda (#{x 60209}#)
+ (let ((#{tmp 60211}#
($sc-dispatch
- #{x 26904}#
+ #{x 60209}#
'(any #(each (any any)) any . each-any))))
- (if (if #{tmp 26906}#
+ (if (if #{tmp 60211}#
(@apply
- (lambda (#{let* 26910}#
- #{x 26911}#
- #{v 26912}#
- #{e1 26913}#
- #{e2 26914}#)
- (and-map identifier? #{x 26911}#))
- #{tmp 26906}#)
+ (lambda (#{let* 60215}#
+ #{x 60216}#
+ #{v 60217}#
+ #{e1 60218}#
+ #{e2 60219}#)
+ (and-map identifier? #{x 60216}#))
+ #{tmp 60211}#)
#f)
(@apply
- (lambda (#{let* 26915}#
- #{x 26916}#
- #{v 26917}#
- #{e1 26918}#
- #{e2 26919}#)
+ (lambda (#{let* 60220}#
+ #{x 60221}#
+ #{v 60222}#
+ #{e1 60223}#
+ #{e2 60224}#)
(letrec*
- ((#{f 26920}#
- (lambda (#{bindings 26923}#)
- (if (null? #{bindings 26923}#)
+ ((#{f 60225}#
+ (lambda (#{bindings 60228}#)
+ (if (null? #{bindings 60228}#)
(cons '#(syntax-object
let
((top)
@@ -23091,27 +18665,36 @@
#(ribcage
#(f bindings)
#((top) (top))
- #("i26890" "i26891"))
+ #("i60195" "i60196"))
#(ribcage
#(let* x v e1 e2)
#((top) (top) (top) (top) (top))
- #("i26880"
- "i26881"
- "i26882"
- "i26883"
- "i26884"))
+ #("i60185"
+ "i60186"
+ "i60187"
+ "i60188"
+ "i60189"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i26866")))
+ #(ribcage #(x) #((top)) #("i60171"))
+ #(ribcage
+ (let*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ let*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons '() (cons #{e1 26918}# #{e2 26919}#)))
- (let ((#{tmp 26924}#
- (list (#{f 26920}# (cdr #{bindings 26923}#))
- (car #{bindings 26923}#))))
- (let ((#{tmp 26925}#
- ($sc-dispatch #{tmp 26924}# '(any any))))
- (if #{tmp 26925}#
+ (cons '() (cons #{e1 60223}# #{e2 60224}#)))
+ (let ((#{tmp 60229}#
+ (list (#{f 60225}# (cdr #{bindings 60228}#))
+ (car #{bindings 60228}#))))
+ (let ((#{tmp 60230}#
+ ($sc-dispatch #{tmp 60229}# '(any any))))
+ (if #{tmp 60230}#
(@apply
- (lambda (#{body 26927}# #{binding 26928}#)
+ (lambda (#{body 60232}# #{binding 60233}#)
(list '#(syntax-object
let
((top)
@@ -23119,86 +18702,92 @@
#(ribcage
#(body binding)
#((top) (top))
- #("i26900" "i26901"))
+ #("i60205" "i60206"))
#(ribcage () () ())
#(ribcage
#(f bindings)
#((top) (top))
- #("i26890" "i26891"))
+ #("i60195" "i60196"))
#(ribcage
#(let* x v e1 e2)
#((top) (top) (top) (top) (top))
- #("i26880"
- "i26881"
- "i26882"
- "i26883"
- "i26884"))
+ #("i60185"
+ "i60186"
+ "i60187"
+ "i60188"
+ "i60189"))
#(ribcage () () ())
+ #(ribcage #(x) #((top)) #("i60171"))
#(ribcage
- #(x)
- #((top))
- #("i26866")))
+ (let*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ let*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (list #{binding 26928}#)
- #{body 26927}#))
- #{tmp 26925}#)
+ (list #{binding 60233}#)
+ #{body 60232}#))
+ #{tmp 60230}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp 26924}#))))))))
- (#{f 26920}# (map list #{x 26916}# #{v 26917}#))))
- #{tmp 26906}#)
+ #{tmp 60229}#))))))))
+ (#{f 60225}# (map list #{x 60221}# #{v 60222}#))))
+ #{tmp 60211}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 26904}#))))))
+ #{x 60209}#))))))
(define do
(make-syntax-transformer
'do
'macro
- (lambda (#{orig-x 26986}#)
- (let ((#{tmp 26988}#
+ (lambda (#{orig-x 60292}#)
+ (let ((#{tmp 60294}#
($sc-dispatch
- #{orig-x 26986}#
+ #{orig-x 60292}#
'(_ #(each (any any . any))
(any . each-any)
.
each-any))))
- (if #{tmp 26988}#
+ (if #{tmp 60294}#
(@apply
- (lambda (#{var 26992}#
- #{init 26993}#
- #{step 26994}#
- #{e0 26995}#
- #{e1 26996}#
- #{c 26997}#)
- (let ((#{tmp 26998}#
- (map (lambda (#{v 27001}# #{s 27002}#)
- (let ((#{tmp 27004}#
- ($sc-dispatch #{s 27002}# '())))
- (if #{tmp 27004}#
- (@apply (lambda () #{v 27001}#) #{tmp 27004}#)
- (let ((#{tmp 27007}#
- ($sc-dispatch #{s 27002}# '(any))))
- (if #{tmp 27007}#
+ (lambda (#{var 60298}#
+ #{init 60299}#
+ #{step 60300}#
+ #{e0 60301}#
+ #{e1 60302}#
+ #{c 60303}#)
+ (let ((#{tmp 60304}#
+ (map (lambda (#{v 60307}# #{s 60308}#)
+ (let ((#{tmp 60310}#
+ ($sc-dispatch #{s 60308}# '())))
+ (if #{tmp 60310}#
+ (@apply (lambda () #{v 60307}#) #{tmp 60310}#)
+ (let ((#{tmp 60313}#
+ ($sc-dispatch #{s 60308}# '(any))))
+ (if #{tmp 60313}#
(@apply
- (lambda (#{e 27010}#) #{e 27010}#)
- #{tmp 27007}#)
+ (lambda (#{e 60316}#) #{e 60316}#)
+ #{tmp 60313}#)
(syntax-violation
'do
"bad step expression"
- #{orig-x 26986}#
- #{s 27002}#))))))
- #{var 26992}#
- #{step 26994}#)))
- (let ((#{tmp 26999}#
- ($sc-dispatch #{tmp 26998}# 'each-any)))
- (if #{tmp 26999}#
+ #{orig-x 60292}#
+ #{s 60308}#))))))
+ #{var 60298}#
+ #{step 60300}#)))
+ (let ((#{tmp 60305}#
+ ($sc-dispatch #{tmp 60304}# 'each-any)))
+ (if #{tmp 60305}#
(@apply
- (lambda (#{step 27016}#)
- (let ((#{tmp 27018}# ($sc-dispatch #{e1 26996}# '())))
- (if #{tmp 27018}#
+ (lambda (#{step 60322}#)
+ (let ((#{tmp 60324}# ($sc-dispatch #{e1 60302}# '())))
+ (if #{tmp 60324}#
(@apply
(lambda ()
(list '#(syntax-object
@@ -23208,7 +18797,7 @@
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var init step e0 e1 c)
#((top)
@@ -23217,17 +18806,26 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'#(syntax-object
doloop
@@ -23236,7 +18834,7 @@
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var init step e0 e1 c)
#((top)
@@ -23245,19 +18843,28 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (map list #{var 26992}# #{init 26993}#)
+ (map list #{var 60298}# #{init 60299}#)
(list '#(syntax-object
if
((top)
@@ -23265,7 +18872,7 @@
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var init step e0 e1 c)
#((top)
@@ -23274,17 +18881,26 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list '#(syntax-object
not
@@ -23293,7 +18909,7 @@
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var
init
@@ -23307,19 +18923,29 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- #{e0 26995}#)
+ #{e0 60301}#)
(cons '#(syntax-object
begin
((top)
@@ -23327,7 +18953,7 @@
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var
init
@@ -23341,20 +18967,30 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
(append
- #{c 26997}#
+ #{c 60303}#
(list (cons '#(syntax-object
doloop
((top)
@@ -23365,7 +19001,7 @@
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var
init
@@ -23379,12 +19015,12 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage
()
()
@@ -23392,30 +19028,41 @@
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- #{step 27016}#)))))))
- #{tmp 27018}#)
- (let ((#{tmp 27022}#
+ #{step 60322}#)))))))
+ #{tmp 60324}#)
+ (let ((#{tmp 60328}#
($sc-dispatch
- #{e1 26996}#
+ #{e1 60302}#
'(any . each-any))))
- (if #{tmp 27022}#
+ (if #{tmp 60328}#
(@apply
- (lambda (#{e1 27026}# #{e2 27027}#)
+ (lambda (#{e1 60332}# #{e2 60333}#)
(list '#(syntax-object
let
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("i26963" "i26964"))
+ #("i60269" "i60270"))
#(ribcage () () ())
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var init step e0 e1 c)
#((top)
@@ -23424,17 +19071,26 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'#(syntax-object
doloop
@@ -23442,12 +19098,12 @@
#(ribcage
#(e1 e2)
#((top) (top))
- #("i26963" "i26964"))
+ #("i60269" "i60270"))
#(ribcage () () ())
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var init step e0 e1 c)
#((top)
@@ -23456,33 +19112,42 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(map list
- #{var 26992}#
- #{init 26993}#)
+ #{var 60298}#
+ #{init 60299}#)
(list '#(syntax-object
if
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("i26963" "i26964"))
+ #("i60269" "i60270"))
#(ribcage () () ())
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var init step e0 e1 c)
#((top)
@@ -23491,32 +19156,41 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{e0 26995}#
+ #{e0 60301}#
(cons '#(syntax-object
begin
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("i26963"
- "i26964"))
+ #("i60269"
+ "i60270"))
#(ribcage () () ())
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var
init
@@ -23530,33 +19204,43 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- (cons #{e1 27026}#
- #{e2 27027}#))
+ (cons #{e1 60332}#
+ #{e2 60333}#))
(cons '#(syntax-object
begin
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("i26963"
- "i26964"))
+ #("i60269"
+ "i60270"))
#(ribcage () () ())
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var
init
@@ -23570,20 +19254,30 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
(append
- #{c 26997}#
+ #{c 60303}#
(list (cons '#(syntax-object
doloop
((top)
@@ -23592,8 +19286,8 @@
e2)
#((top)
(top))
- #("i26963"
- "i26964"))
+ #("i60269"
+ "i60270"))
#(ribcage
()
()
@@ -23601,7 +19295,7 @@
#(ribcage
#(step)
#((top))
- #("i26954"))
+ #("i60260"))
#(ribcage
#(var
init
@@ -23615,12 +19309,12 @@
(top)
(top)
(top))
- #("i26939"
- "i26940"
- "i26941"
- "i26942"
- "i26943"
- "i26944"))
+ #("i60245"
+ "i60246"
+ "i60247"
+ "i60248"
+ "i60249"
+ "i60250"))
#(ribcage
()
()
@@ -23628,36 +19322,47 @@
#(ribcage
#(orig-x)
#((top))
- #("i26936")))
+ #("i60242"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- #{step 27016}#)))))))
- #{tmp 27022}#)
+ #{step 60322}#)))))))
+ #{tmp 60328}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{e1 26996}#))))))
- #{tmp 26999}#)
+ #{e1 60302}#))))))
+ #{tmp 60305}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp 26998}#)))))
- #{tmp 26988}#)
+ #{tmp 60304}#)))))
+ #{tmp 60294}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{orig-x 26986}#))))))
+ #{orig-x 60292}#))))))
(define quasiquote
(make-syntax-transformer
'quasiquote
'macro
(letrec*
- ((#{quasi 27313}#
- (lambda (#{p 27337}# #{lev 27338}#)
- (let ((#{tmp 27340}#
+ ((#{quasi 60620}#
+ (lambda (#{p 60644}# #{lev 60645}#)
+ (let ((#{tmp 60647}#
($sc-dispatch
- #{p 27337}#
+ #{p 60644}#
'(#(free-id
#(syntax-object
unquote
@@ -23666,7 +19371,7 @@
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -23675,28 +19380,37 @@
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
any))))
- (if #{tmp 27340}#
+ (if #{tmp 60647}#
(@apply
- (lambda (#{p 27344}#)
- (if (= #{lev 27338}# 0)
+ (lambda (#{p 60651}#)
+ (if (= #{lev 60645}# 0)
(list '#(syntax-object
"value"
((top)
- #(ribcage #(p) #((top)) #("i27063"))
+ #(ribcage #(p) #((top)) #("i60370"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -23705,25 +19419,34 @@
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{p 27344}#)
- (#{quasicons 27315}#
+ #{p 60651}#)
+ (#{quasicons 60622}#
'(#(syntax-object
"quote"
((top)
- #(ribcage #(p) #((top)) #("i27063"))
+ #(ribcage #(p) #((top)) #("i60370"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -23732,23 +19455,32 @@
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
unquote
((top)
- #(ribcage #(p) #((top)) #("i27063"))
+ #(ribcage #(p) #((top)) #("i60370"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -23757,21 +19489,30 @@
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (#{quasi 27313}#
- (list #{p 27344}#)
- (#{1-}# #{lev 27338}#)))))
- #{tmp 27340}#)
- (let ((#{tmp 27347}#
+ (#{quasi 60620}#
+ (list #{p 60651}#)
+ (#{1-}# #{lev 60645}#)))))
+ #{tmp 60647}#)
+ (let ((#{tmp 60654}#
($sc-dispatch
- #{p 27337}#
+ #{p 60644}#
'(#(free-id
#(syntax-object
quasiquote
@@ -23780,7 +19521,7 @@
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -23789,28 +19530,37 @@
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
any))))
- (if #{tmp 27347}#
+ (if #{tmp 60654}#
(@apply
- (lambda (#{p 27351}#)
- (#{quasicons 27315}#
+ (lambda (#{p 60658}#)
+ (#{quasicons 60622}#
'(#(syntax-object
"quote"
((top)
- #(ribcage #(p) #((top)) #("i27066"))
+ #(ribcage #(p) #((top)) #("i60373"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -23819,23 +19569,32 @@
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
quasiquote
((top)
- #(ribcage #(p) #((top)) #("i27066"))
+ #(ribcage #(p) #((top)) #("i60373"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -23844,26 +19603,35 @@
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (#{quasi 27313}#
- (list #{p 27351}#)
- (#{1+}# #{lev 27338}#))))
- #{tmp 27347}#)
- (let ((#{tmp 27354}#
- ($sc-dispatch #{p 27337}# '(any . any))))
- (if #{tmp 27354}#
+ (#{quasi 60620}#
+ (list #{p 60658}#)
+ (#{1+}# #{lev 60645}#))))
+ #{tmp 60654}#)
+ (let ((#{tmp 60661}#
+ ($sc-dispatch #{p 60644}# '(any . any))))
+ (if #{tmp 60661}#
(@apply
- (lambda (#{p 27358}# #{q 27359}#)
- (let ((#{tmp 27361}#
+ (lambda (#{p 60665}# #{q 60666}#)
+ (let ((#{tmp 60668}#
($sc-dispatch
- #{p 27358}#
+ #{p 60665}#
'(#(free-id
#(syntax-object
unquote
@@ -23871,12 +19639,12 @@
#(ribcage
#(p q)
#((top) (top))
- #("i27069" "i27070"))
+ #("i60376" "i60377"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -23891,38 +19659,47 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
.
each-any))))
- (if #{tmp 27361}#
+ (if #{tmp 60668}#
(@apply
- (lambda (#{p 27365}#)
- (if (= #{lev 27338}# 0)
- (#{quasilist* 27317}#
- (map (lambda (#{tmp 27077 27401}#)
+ (lambda (#{p 60672}#)
+ (if (= #{lev 60645}# 0)
+ (#{quasilist* 60624}#
+ (map (lambda (#{tmp 60384 60711}#)
(list '#(syntax-object
"value"
((top)
#(ribcage
#(p)
#((top))
- #("i27075"))
+ #("i60382"))
#(ribcage
#(p q)
#((top) (top))
- #("i27069" "i27070"))
+ #("i60376" "i60377"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -23937,37 +19714,47 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- #{tmp 27077 27401}#))
- #{p 27365}#)
- (#{quasi 27313}#
- #{q 27359}#
- #{lev 27338}#))
- (#{quasicons 27315}#
- (#{quasicons 27315}#
+ #{tmp 60384 60711}#))
+ #{p 60672}#)
+ (#{quasi 60620}#
+ #{q 60666}#
+ #{lev 60645}#))
+ (#{quasicons 60622}#
+ (#{quasicons 60622}#
'(#(syntax-object
"quote"
((top)
#(ribcage
#(p)
#((top))
- #("i27075"))
+ #("i60382"))
#(ribcage
#(p q)
#((top) (top))
- #("i27069" "i27070"))
+ #("i60376" "i60377"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -23982,13 +19769,22 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
unquote
@@ -23996,16 +19792,16 @@
#(ribcage
#(p)
#((top))
- #("i27075"))
+ #("i60382"))
#(ribcage
#(p q)
#((top) (top))
- #("i27069" "i27070"))
+ #("i60376" "i60377"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -24020,24 +19816,33 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (#{quasi 27313}#
- #{p 27365}#
- (#{1-}# #{lev 27338}#)))
- (#{quasi 27313}#
- #{q 27359}#
- #{lev 27338}#))))
- #{tmp 27361}#)
- (let ((#{tmp 27406}#
+ (#{quasi 60620}#
+ #{p 60672}#
+ (#{1-}# #{lev 60645}#)))
+ (#{quasi 60620}#
+ #{q 60666}#
+ #{lev 60645}#))))
+ #{tmp 60668}#)
+ (let ((#{tmp 60716}#
($sc-dispatch
- #{p 27358}#
+ #{p 60665}#
'(#(free-id
#(syntax-object
unquote-splicing
@@ -24045,12 +19850,12 @@
#(ribcage
#(p q)
#((top) (top))
- #("i27069" "i27070"))
+ #("i60376" "i60377"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -24065,40 +19870,49 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
.
each-any))))
- (if #{tmp 27406}#
+ (if #{tmp 60716}#
(@apply
- (lambda (#{p 27410}#)
- (if (= #{lev 27338}# 0)
- (#{quasiappend 27316}#
- (map (lambda (#{tmp 27082 27413}#)
+ (lambda (#{p 60720}#)
+ (if (= #{lev 60645}# 0)
+ (#{quasiappend 60623}#
+ (map (lambda (#{tmp 60389 60723}#)
(list '#(syntax-object
"value"
((top)
#(ribcage
#(p)
#((top))
- #("i27080"))
+ #("i60387"))
#(ribcage
#(p q)
#((top) (top))
- #("i27069"
- "i27070"))
+ #("i60376"
+ "i60377"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059"
- "i27060"))
+ #("i60366"
+ "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -24113,37 +19927,47 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- #{tmp 27082 27413}#))
- #{p 27410}#)
- (#{quasi 27313}#
- #{q 27359}#
- #{lev 27338}#))
- (#{quasicons 27315}#
- (#{quasicons 27315}#
+ #{tmp 60389 60723}#))
+ #{p 60720}#)
+ (#{quasi 60620}#
+ #{q 60666}#
+ #{lev 60645}#))
+ (#{quasicons 60622}#
+ (#{quasicons 60622}#
'(#(syntax-object
"quote"
((top)
#(ribcage
#(p)
#((top))
- #("i27080"))
+ #("i60387"))
#(ribcage
#(p q)
#((top) (top))
- #("i27069" "i27070"))
+ #("i60376" "i60377"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -24158,13 +19982,22 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
unquote-splicing
@@ -24172,16 +20005,16 @@
#(ribcage
#(p)
#((top))
- #("i27080"))
+ #("i60387"))
#(ribcage
#(p q)
#((top) (top))
- #("i27069" "i27070"))
+ #("i60376" "i60377"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -24196,57 +20029,66 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (#{quasi 27313}#
- #{p 27410}#
- (#{1-}# #{lev 27338}#)))
- (#{quasi 27313}#
- #{q 27359}#
- #{lev 27338}#))))
- #{tmp 27406}#)
- (#{quasicons 27315}#
- (#{quasi 27313}#
- #{p 27358}#
- #{lev 27338}#)
- (#{quasi 27313}#
- #{q 27359}#
- #{lev 27338}#)))))))
- #{tmp 27354}#)
- (let ((#{tmp 27427}#
- ($sc-dispatch #{p 27337}# '#(vector each-any))))
- (if #{tmp 27427}#
+ (#{quasi 60620}#
+ #{p 60720}#
+ (#{1-}# #{lev 60645}#)))
+ (#{quasi 60620}#
+ #{q 60666}#
+ #{lev 60645}#))))
+ #{tmp 60716}#)
+ (#{quasicons 60622}#
+ (#{quasi 60620}#
+ #{p 60665}#
+ #{lev 60645}#)
+ (#{quasi 60620}#
+ #{q 60666}#
+ #{lev 60645}#)))))))
+ #{tmp 60661}#)
+ (let ((#{tmp 60737}#
+ ($sc-dispatch #{p 60644}# '#(vector each-any))))
+ (if #{tmp 60737}#
(@apply
- (lambda (#{x 27431}#)
- (let ((#{x 27434}#
- (#{vquasi 27314}#
- #{x 27431}#
- #{lev 27338}#)))
- (let ((#{tmp 27436}#
+ (lambda (#{x 60741}#)
+ (let ((#{x 60744}#
+ (#{vquasi 60621}#
+ #{x 60741}#
+ #{lev 60645}#)))
+ (let ((#{tmp 60746}#
($sc-dispatch
- #{x 27434}#
+ #{x 60744}#
'(#(atom "quote") each-any))))
- (if #{tmp 27436}#
+ (if #{tmp 60746}#
(@apply
- (lambda (#{x 27440}#)
+ (lambda (#{x 60750}#)
(list '#(syntax-object
"quote"
((top)
#(ribcage
#(x)
#((top))
- #("i27187"))
+ #("i60494"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i27184"))
+ #("i60491"))
#(ribcage
(emit quasivector
quasilist*
@@ -24261,36 +20103,45 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (list->vector #{x 27440}#)))
- #{tmp 27436}#)
+ (list->vector #{x 60750}#)))
+ #{tmp 60746}#)
(letrec*
- ((#{f 27442}#
- (lambda (#{y 27454}# #{k 27455}#)
- (let ((#{tmp 27457}#
+ ((#{f 60752}#
+ (lambda (#{y 60764}# #{k 60765}#)
+ (let ((#{tmp 60767}#
($sc-dispatch
- #{y 27454}#
+ #{y 60764}#
'(#(atom "quote")
each-any))))
- (if #{tmp 27457}#
+ (if #{tmp 60767}#
(@apply
- (lambda (#{y 27460}#)
- (#{k 27455}#
- (map (lambda (#{tmp 27212 27461}#)
+ (lambda (#{y 60770}#)
+ (#{k 60765}#
+ (map (lambda (#{tmp 60519 60771}#)
(list '#(syntax-object
"quote"
((top)
#(ribcage
#(y)
#((top))
- #("i27210"))
+ #("i60517"))
#(ribcage
()
()
@@ -24302,13 +20153,13 @@
#((top)
(top)
(top))
- #("i27192"
- "i27193"
- "i27194"))
+ #("i60499"
+ "i60500"
+ "i60501"))
#(ribcage
#(_)
#((top))
- #("i27190"))
+ #("i60497"))
#(ribcage
()
()
@@ -24316,7 +20167,7 @@
#(ribcage
#(x)
#((top))
- #("i27184"))
+ #("i60491"))
#(ribcage
(emit quasivector
quasilist*
@@ -24331,51 +20182,62 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- #{tmp 27212 27461}#))
- #{y 27460}#)))
- #{tmp 27457}#)
- (let ((#{tmp 27462}#
+ #{tmp 60519 60771}#))
+ #{y 60770}#)))
+ #{tmp 60767}#)
+ (let ((#{tmp 60772}#
($sc-dispatch
- #{y 27454}#
+ #{y 60764}#
'(#(atom "list")
.
each-any))))
- (if #{tmp 27462}#
+ (if #{tmp 60772}#
(@apply
- (lambda (#{y 27465}#)
- (#{k 27455}#
- #{y 27465}#))
- #{tmp 27462}#)
- (let ((#{tmp 27466}#
+ (lambda (#{y 60775}#)
+ (#{k 60765}#
+ #{y 60775}#))
+ #{tmp 60772}#)
+ (let ((#{tmp 60776}#
($sc-dispatch
- #{y 27454}#
+ #{y 60764}#
'(#(atom "list*")
.
#(each+
any
(any)
())))))
- (if #{tmp 27466}#
+ (if #{tmp 60776}#
(@apply
- (lambda (#{y 27469}#
- #{z 27470}#)
- (#{f 27442}#
- #{z 27470}#
- (lambda (#{ls 27471}#)
- (#{k 27455}#
+ (lambda (#{y 60779}#
+ #{z 60780}#)
+ (#{f 60752}#
+ #{z 60780}#
+ (lambda (#{ls 60781}#)
+ (#{k 60765}#
(append
- #{y 27469}#
- #{ls 27471}#)))))
- #{tmp 27466}#)
+ #{y 60779}#
+ #{ls 60781}#)))))
+ #{tmp 60776}#)
(list '#(syntax-object
"list->vector"
((top)
@@ -24384,14 +20246,14 @@
()
())
#(ribcage
- #(#{ g27227}#)
- #((m27228
+ #(#{ g60534}#)
+ #((m60535
top))
- #("i27231"))
+ #("i60538"))
#(ribcage
#(else)
#((top))
- #("i27225"))
+ #("i60532"))
#(ribcage
()
()
@@ -24401,13 +20263,13 @@
#((top)
(top)
(top))
- #("i27192"
- "i27193"
- "i27194"))
+ #("i60499"
+ "i60500"
+ "i60501"))
#(ribcage
#(_)
#((top))
- #("i27190"))
+ #("i60497"))
#(ribcage
()
()
@@ -24415,7 +20277,7 @@
#(ribcage
#(x)
#((top))
- #("i27184"))
+ #("i60491"))
#(ribcage
(emit quasivector
quasilist*
@@ -24430,26 +20292,37 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- #{x 27434}#))))))))))
- (#{f 27442}#
- #{x 27434}#
- (lambda (#{ls 27444}#)
- (let ((#{tmp 27446}#
+ #{x 60744}#))))))))))
+ (#{f 60752}#
+ #{x 60744}#
+ (lambda (#{ls 60754}#)
+ (let ((#{tmp 60756}#
($sc-dispatch
- #{ls 27444}#
+ #{ls 60754}#
'each-any)))
- (if #{tmp 27446}#
+ (if #{tmp 60756}#
(@apply
- (lambda (#{ g27200 27449}#)
+ (lambda (#{ g60507 60759}#)
(cons '#(syntax-object
"vector"
((top)
@@ -24458,9 +20331,9 @@
()
())
#(ribcage
- #(#{ g27200}#)
- #((m27201 top))
- #("i27205"))
+ #(#{ g60507}#)
+ #((m60508 top))
+ #("i60512"))
#(ribcage
()
()
@@ -24476,11 +20349,11 @@
#(ribcage
#(ls)
#((top))
- #("i27199"))
+ #("i60506"))
#(ribcage
#(_)
#((top))
- #("i27190"))
+ #("i60497"))
#(ribcage
()
()
@@ -24488,7 +20361,7 @@
#(ribcage
#(x)
#((top))
- #("i27184"))
+ #("i60491"))
#(ribcage
(emit quasivector
quasilist*
@@ -24503,30 +20376,41 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- #{ g27200 27449}#))
- #{tmp 27446}#)
+ #{ g60507 60759}#))
+ #{tmp 60756}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{ls 27444}#))))))))))
- #{tmp 27427}#)
+ #{ls 60754}#))))))))))
+ #{tmp 60737}#)
(list '#(syntax-object
"quote"
((top)
- #(ribcage #(p) #((top)) #("i27090"))
+ #(ribcage #(p) #((top)) #("i60397"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27059" "i27060"))
+ #("i60366" "i60367"))
#(ribcage
(emit quasivector
quasilist*
@@ -24541,25 +20425,34 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{p 27337}#)))))))))))
- (#{vquasi 27314}#
- (lambda (#{p 27499}# #{lev 27500}#)
- (let ((#{tmp 27502}#
- ($sc-dispatch #{p 27499}# '(any . any))))
- (if #{tmp 27502}#
+ #{p 60644}#)))))))))))
+ (#{vquasi 60621}#
+ (lambda (#{p 60809}# #{lev 60810}#)
+ (let ((#{tmp 60812}#
+ ($sc-dispatch #{p 60809}# '(any . any))))
+ (if #{tmp 60812}#
(@apply
- (lambda (#{p 27506}# #{q 27507}#)
- (let ((#{tmp 27509}#
+ (lambda (#{p 60816}# #{q 60817}#)
+ (let ((#{tmp 60819}#
($sc-dispatch
- #{p 27506}#
+ #{p 60816}#
'(#(free-id
#(syntax-object
unquote
@@ -24567,12 +20460,12 @@
#(ribcage
#(p q)
#((top) (top))
- #("i27098" "i27099"))
+ #("i60405" "i60406"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27094" "i27095"))
+ #("i60401" "i60402"))
#(ribcage
(emit quasivector
quasilist*
@@ -24587,38 +20480,47 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
.
each-any))))
- (if #{tmp 27509}#
+ (if #{tmp 60819}#
(@apply
- (lambda (#{p 27513}#)
- (if (= #{lev 27500}# 0)
- (#{quasilist* 27317}#
- (map (lambda (#{tmp 27106 27549}#)
+ (lambda (#{p 60823}#)
+ (if (= #{lev 60810}# 0)
+ (#{quasilist* 60624}#
+ (map (lambda (#{tmp 60413 60862}#)
(list '#(syntax-object
"value"
((top)
#(ribcage
#(p)
#((top))
- #("i27104"))
+ #("i60411"))
#(ribcage
#(p q)
#((top) (top))
- #("i27098" "i27099"))
+ #("i60405" "i60406"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27094" "i27095"))
+ #("i60401" "i60402"))
#(ribcage
(emit quasivector
quasilist*
@@ -24633,32 +20535,41 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{tmp 27106 27549}#))
- #{p 27513}#)
- (#{vquasi 27314}# #{q 27507}# #{lev 27500}#))
- (#{quasicons 27315}#
- (#{quasicons 27315}#
+ #{tmp 60413 60862}#))
+ #{p 60823}#)
+ (#{vquasi 60621}# #{q 60817}# #{lev 60810}#))
+ (#{quasicons 60622}#
+ (#{quasicons 60622}#
'(#(syntax-object
"quote"
((top)
- #(ribcage #(p) #((top)) #("i27104"))
+ #(ribcage #(p) #((top)) #("i60411"))
#(ribcage
#(p q)
#((top) (top))
- #("i27098" "i27099"))
+ #("i60405" "i60406"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27094" "i27095"))
+ #("i60401" "i60402"))
#(ribcage
(emit quasivector
quasilist*
@@ -24673,27 +20584,36 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
unquote
((top)
- #(ribcage #(p) #((top)) #("i27104"))
+ #(ribcage #(p) #((top)) #("i60411"))
#(ribcage
#(p q)
#((top) (top))
- #("i27098" "i27099"))
+ #("i60405" "i60406"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27094" "i27095"))
+ #("i60401" "i60402"))
#(ribcage
(emit quasivector
quasilist*
@@ -24708,22 +20628,31 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (#{quasi 27313}#
- #{p 27513}#
- (#{1-}# #{lev 27500}#)))
- (#{vquasi 27314}# #{q 27507}# #{lev 27500}#))))
- #{tmp 27509}#)
- (let ((#{tmp 27556}#
+ (#{quasi 60620}#
+ #{p 60823}#
+ (#{1-}# #{lev 60810}#)))
+ (#{vquasi 60621}# #{q 60817}# #{lev 60810}#))))
+ #{tmp 60819}#)
+ (let ((#{tmp 60869}#
($sc-dispatch
- #{p 27506}#
+ #{p 60816}#
'(#(free-id
#(syntax-object
unquote-splicing
@@ -24731,12 +20660,12 @@
#(ribcage
#(p q)
#((top) (top))
- #("i27098" "i27099"))
+ #("i60405" "i60406"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27094" "i27095"))
+ #("i60401" "i60402"))
#(ribcage
(emit quasivector
quasilist*
@@ -24751,38 +20680,47 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
.
each-any))))
- (if #{tmp 27556}#
+ (if #{tmp 60869}#
(@apply
- (lambda (#{p 27560}#)
- (if (= #{lev 27500}# 0)
- (#{quasiappend 27316}#
- (map (lambda (#{tmp 27111 27563}#)
+ (lambda (#{p 60873}#)
+ (if (= #{lev 60810}# 0)
+ (#{quasiappend 60623}#
+ (map (lambda (#{tmp 60418 60876}#)
(list '#(syntax-object
"value"
((top)
#(ribcage
#(p)
#((top))
- #("i27109"))
+ #("i60416"))
#(ribcage
#(p q)
#((top) (top))
- #("i27098" "i27099"))
+ #("i60405" "i60406"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27094" "i27095"))
+ #("i60401" "i60402"))
#(ribcage
(emit quasivector
quasilist*
@@ -24797,34 +20735,43 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{tmp 27111 27563}#))
- #{p 27560}#)
- (#{vquasi 27314}#
- #{q 27507}#
- #{lev 27500}#))
- (#{quasicons 27315}#
- (#{quasicons 27315}#
+ #{tmp 60418 60876}#))
+ #{p 60873}#)
+ (#{vquasi 60621}#
+ #{q 60817}#
+ #{lev 60810}#))
+ (#{quasicons 60622}#
+ (#{quasicons 60622}#
'(#(syntax-object
"quote"
((top)
- #(ribcage #(p) #((top)) #("i27109"))
+ #(ribcage #(p) #((top)) #("i60416"))
#(ribcage
#(p q)
#((top) (top))
- #("i27098" "i27099"))
+ #("i60405" "i60406"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27094" "i27095"))
+ #("i60401" "i60402"))
#(ribcage
(emit quasivector
quasilist*
@@ -24839,27 +20786,36 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
unquote-splicing
((top)
- #(ribcage #(p) #((top)) #("i27109"))
+ #(ribcage #(p) #((top)) #("i60416"))
#(ribcage
#(p q)
#((top) (top))
- #("i27098" "i27099"))
+ #("i60405" "i60406"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i27094" "i27095"))
+ #("i60401" "i60402"))
#(ribcage
(emit quasivector
quasilist*
@@ -24874,27 +20830,36 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (#{quasi 27313}#
- #{p 27560}#
- (#{1-}# #{lev 27500}#)))
- (#{vquasi 27314}#
- #{q 27507}#
- #{lev 27500}#))))
- #{tmp 27556}#)
- (#{quasicons 27315}#
- (#{quasi 27313}# #{p 27506}# #{lev 27500}#)
- (#{vquasi 27314}# #{q 27507}# #{lev 27500}#)))))))
- #{tmp 27502}#)
- (let ((#{tmp 27581}# ($sc-dispatch #{p 27499}# '())))
- (if #{tmp 27581}#
+ (#{quasi 60620}#
+ #{p 60873}#
+ (#{1-}# #{lev 60810}#)))
+ (#{vquasi 60621}#
+ #{q 60817}#
+ #{lev 60810}#))))
+ #{tmp 60869}#)
+ (#{quasicons 60622}#
+ (#{quasi 60620}# #{p 60816}# #{lev 60810}#)
+ (#{vquasi 60621}# #{q 60817}# #{lev 60810}#)))))))
+ #{tmp 60812}#)
+ (let ((#{tmp 60894}# ($sc-dispatch #{p 60809}# '())))
+ (if #{tmp 60894}#
(@apply
(lambda ()
'(#(syntax-object
@@ -24904,7 +20869,7 @@
#(ribcage
#(p lev)
#((top) (top))
- #("i27094" "i27095"))
+ #("i60401" "i60402"))
#(ribcage
(emit quasivector
quasilist*
@@ -24913,64 +20878,73 @@
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
()))
- #{tmp 27581}#)
+ #{tmp 60894}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{p 27499}#)))))))
- (#{quasicons 27315}#
- (lambda (#{x 27594}# #{y 27595}#)
- (let ((#{tmp 27596}# (list #{x 27594}# #{y 27595}#)))
- (let ((#{tmp 27597}#
- ($sc-dispatch #{tmp 27596}# '(any any))))
- (if #{tmp 27597}#
+ #{p 60809}#)))))))
+ (#{quasicons 60622}#
+ (lambda (#{x 60907}# #{y 60908}#)
+ (let ((#{tmp 60909}# (list #{x 60907}# #{y 60908}#)))
+ (let ((#{tmp 60910}#
+ ($sc-dispatch #{tmp 60909}# '(any any))))
+ (if #{tmp 60910}#
(@apply
- (lambda (#{x 27599}# #{y 27600}#)
- (let ((#{tmp 27602}#
+ (lambda (#{x 60912}# #{y 60913}#)
+ (let ((#{tmp 60915}#
($sc-dispatch
- #{y 27600}#
+ #{y 60913}#
'(#(atom "quote") any))))
- (if #{tmp 27602}#
+ (if #{tmp 60915}#
(@apply
- (lambda (#{dy 27606}#)
- (let ((#{tmp 27608}#
+ (lambda (#{dy 60919}#)
+ (let ((#{tmp 60921}#
($sc-dispatch
- #{x 27599}#
+ #{x 60912}#
'(#(atom "quote") any))))
- (if #{tmp 27608}#
+ (if #{tmp 60921}#
(@apply
- (lambda (#{dx 27612}#)
+ (lambda (#{dx 60925}#)
(list '#(syntax-object
"quote"
((top)
#(ribcage
#(dx)
#((top))
- #("i27133"))
+ #("i60440"))
#(ribcage
#(dy)
#((top))
- #("i27129"))
+ #("i60436"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27123" "i27124"))
+ #("i60430" "i60431"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27118" "i27119"))
+ #("i60425" "i60426"))
#(ribcage
(emit quasivector
quasilist*
@@ -24985,39 +20959,48 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons #{dx 27612}# #{dy 27606}#)))
- #{tmp 27608}#)
- (if (null? #{dy 27606}#)
+ (cons #{dx 60925}# #{dy 60919}#)))
+ #{tmp 60921}#)
+ (if (null? #{dy 60919}#)
(list '#(syntax-object
"list"
((top)
#(ribcage
#(_)
#((top))
- #("i27135"))
+ #("i60442"))
#(ribcage
#(dy)
#((top))
- #("i27129"))
+ #("i60436"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27123" "i27124"))
+ #("i60430" "i60431"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27118" "i27119"))
+ #("i60425" "i60426"))
#(ribcage
(emit quasivector
quasilist*
@@ -25032,37 +21015,46 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{x 27599}#)
+ #{x 60912}#)
(list '#(syntax-object
"list*"
((top)
#(ribcage
#(_)
#((top))
- #("i27135"))
+ #("i60442"))
#(ribcage
#(dy)
#((top))
- #("i27129"))
+ #("i60436"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27123" "i27124"))
+ #("i60430" "i60431"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27118" "i27119"))
+ #("i60425" "i60426"))
#(ribcage
(emit quasivector
quasilist*
@@ -25077,42 +21069,51 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{x 27599}#
- #{y 27600}#)))))
- #{tmp 27602}#)
- (let ((#{tmp 27617}#
+ #{x 60912}#
+ #{y 60913}#)))))
+ #{tmp 60915}#)
+ (let ((#{tmp 60930}#
($sc-dispatch
- #{y 27600}#
+ #{y 60913}#
'(#(atom "list") . any))))
- (if #{tmp 27617}#
+ (if #{tmp 60930}#
(@apply
- (lambda (#{stuff 27621}#)
+ (lambda (#{stuff 60934}#)
(cons '#(syntax-object
"list"
((top)
#(ribcage
#(stuff)
#((top))
- #("i27138"))
+ #("i60445"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27123" "i27124"))
+ #("i60430" "i60431"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27118" "i27119"))
+ #("i60425" "i60426"))
#(ribcage
(emit quasivector
quasilist*
@@ -25127,41 +21128,50 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons #{x 27599}# #{stuff 27621}#)))
- #{tmp 27617}#)
- (let ((#{tmp 27622}#
+ (cons #{x 60912}# #{stuff 60934}#)))
+ #{tmp 60930}#)
+ (let ((#{tmp 60935}#
($sc-dispatch
- #{y 27600}#
+ #{y 60913}#
'(#(atom "list*") . any))))
- (if #{tmp 27622}#
+ (if #{tmp 60935}#
(@apply
- (lambda (#{stuff 27626}#)
+ (lambda (#{stuff 60939}#)
(cons '#(syntax-object
"list*"
((top)
#(ribcage
#(stuff)
#((top))
- #("i27141"))
+ #("i60448"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27123" "i27124"))
+ #("i60430" "i60431"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27118" "i27119"))
+ #("i60425" "i60426"))
#(ribcage
(emit quasivector
quasilist*
@@ -25176,31 +21186,40 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons #{x 27599}# #{stuff 27626}#)))
- #{tmp 27622}#)
+ (cons #{x 60912}# #{stuff 60939}#)))
+ #{tmp 60935}#)
(list '#(syntax-object
"list*"
((top)
- #(ribcage #(_) #((top)) #("i27143"))
+ #(ribcage #(_) #((top)) #("i60450"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27123" "i27124"))
+ #("i60430" "i60431"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27118" "i27119"))
+ #("i60425" "i60426"))
#(ribcage
(emit quasivector
quasilist*
@@ -25215,29 +21234,38 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{x 27599}#
- #{y 27600}#))))))))
- #{tmp 27597}#)
+ #{x 60912}#
+ #{y 60913}#))))))))
+ #{tmp 60910}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp 27596}#))))))
- (#{quasiappend 27316}#
- (lambda (#{x 27637}# #{y 27638}#)
- (let ((#{tmp 27640}#
- ($sc-dispatch #{y 27638}# '(#(atom "quote") ()))))
- (if #{tmp 27640}#
+ #{tmp 60909}#))))))
+ (#{quasiappend 60623}#
+ (lambda (#{x 60950}# #{y 60951}#)
+ (let ((#{tmp 60953}#
+ ($sc-dispatch #{y 60951}# '(#(atom "quote") ()))))
+ (if #{tmp 60953}#
(@apply
(lambda ()
- (if (null? #{x 27637}#)
+ (if (null? #{x 60950}#)
'(#(syntax-object
"quote"
((top)
@@ -25245,7 +21273,7 @@
#(ribcage
#(x y)
#((top) (top))
- #("i27147" "i27148"))
+ #("i60454" "i60455"))
#(ribcage
(emit quasivector
quasilist*
@@ -25254,32 +21282,41 @@
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
())
- (if (null? (cdr #{x 27637}#))
- (car #{x 27637}#)
- (let ((#{tmp 27645}#
- ($sc-dispatch #{x 27637}# 'each-any)))
- (if #{tmp 27645}#
+ (if (null? (cdr #{x 60950}#))
+ (car #{x 60950}#)
+ (let ((#{tmp 60958}#
+ ($sc-dispatch #{x 60950}# 'each-any)))
+ (if #{tmp 60958}#
(@apply
- (lambda (#{p 27649}#)
+ (lambda (#{p 60962}#)
(cons '#(syntax-object
"append"
((top)
#(ribcage () () ())
- #(ribcage #(p) #((top)) #("i27159"))
+ #(ribcage #(p) #((top)) #("i60466"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27147" "i27148"))
+ #("i60454" "i60455"))
#(ribcage
(emit quasivector
quasilist*
@@ -25294,29 +21331,38 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{p 27649}#))
- #{tmp 27645}#)
+ #{p 60962}#))
+ #{tmp 60958}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 27637}#))))))
- #{tmp 27640}#)
- (if (null? #{x 27637}#)
- #{y 27638}#
- (let ((#{tmp 27657}# (list #{x 27637}# #{y 27638}#)))
- (let ((#{tmp 27658}#
- ($sc-dispatch #{tmp 27657}# '(each-any any))))
- (if #{tmp 27658}#
+ #{x 60950}#))))))
+ #{tmp 60953}#)
+ (if (null? #{x 60950}#)
+ #{y 60951}#
+ (let ((#{tmp 60970}# (list #{x 60950}# #{y 60951}#)))
+ (let ((#{tmp 60971}#
+ ($sc-dispatch #{tmp 60970}# '(each-any any))))
+ (if #{tmp 60971}#
(@apply
- (lambda (#{p 27660}# #{y 27661}#)
+ (lambda (#{p 60973}# #{y 60974}#)
(cons '#(syntax-object
"append"
((top)
@@ -25324,13 +21370,13 @@
#(ribcage
#(p y)
#((top) (top))
- #("i27170" "i27171"))
- #(ribcage #(_) #((top)) #("i27162"))
+ #("i60477" "i60478"))
+ #(ribcage #(_) #((top)) #("i60469"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i27147" "i27148"))
+ #("i60454" "i60455"))
#(ribcage
(emit quasivector
quasilist*
@@ -25345,44 +21391,53 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (append #{p 27660}# (list #{y 27661}#))))
- #{tmp 27658}#)
+ (append #{p 60973}# (list #{y 60974}#))))
+ #{tmp 60971}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp 27657}#)))))))))
- (#{quasilist* 27317}#
- (lambda (#{x 27665}# #{y 27666}#)
+ #{tmp 60970}#)))))))))
+ (#{quasilist* 60624}#
+ (lambda (#{x 60978}# #{y 60979}#)
(letrec*
- ((#{f 27667}#
- (lambda (#{x 27756}#)
- (if (null? #{x 27756}#)
- #{y 27666}#
- (#{quasicons 27315}#
- (car #{x 27756}#)
- (#{f 27667}# (cdr #{x 27756}#)))))))
- (#{f 27667}# #{x 27665}#))))
- (#{emit 27319}#
- (lambda (#{x 27759}#)
- (let ((#{tmp 27761}#
- ($sc-dispatch #{x 27759}# '(#(atom "quote") any))))
- (if #{tmp 27761}#
+ ((#{f 60980}#
+ (lambda (#{x 61084}#)
+ (if (null? #{x 61084}#)
+ #{y 60979}#
+ (#{quasicons 60622}#
+ (car #{x 61084}#)
+ (#{f 60980}# (cdr #{x 61084}#)))))))
+ (#{f 60980}# #{x 60978}#))))
+ (#{emit 60626}#
+ (lambda (#{x 61087}#)
+ (let ((#{tmp 61089}#
+ ($sc-dispatch #{x 61087}# '(#(atom "quote") any))))
+ (if #{tmp 61089}#
(@apply
- (lambda (#{x 27765}#)
+ (lambda (#{x 61093}#)
(list '#(syntax-object
quote
((top)
- #(ribcage #(x) #((top)) #("i27237"))
+ #(ribcage #(x) #((top)) #("i60544"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i27234"))
+ #(ribcage #(x) #((top)) #("i60541"))
#(ribcage
(emit quasivector
quasilist*
@@ -25391,40 +21446,49 @@
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{x 27765}#))
- #{tmp 27761}#)
- (let ((#{tmp 27766}#
+ #{x 61093}#))
+ #{tmp 61089}#)
+ (let ((#{tmp 61094}#
($sc-dispatch
- #{x 27759}#
+ #{x 61087}#
'(#(atom "list") . each-any))))
- (if #{tmp 27766}#
+ (if #{tmp 61094}#
(@apply
- (lambda (#{x 27770}#)
- (let ((#{tmp 27771}# (map #{emit 27319}# #{x 27770}#)))
- (let ((#{tmp 27772}#
- ($sc-dispatch #{tmp 27771}# 'each-any)))
- (if #{tmp 27772}#
+ (lambda (#{x 61098}#)
+ (let ((#{tmp 61099}# (map #{emit 60626}# #{x 61098}#)))
+ (let ((#{tmp 61100}#
+ ($sc-dispatch #{tmp 61099}# 'each-any)))
+ (if #{tmp 61100}#
(@apply
- (lambda (#{ g27242 27774}#)
+ (lambda (#{ g60549 61102}#)
(cons '#(syntax-object
list
((top)
#(ribcage () () ())
#(ribcage
- #(#{ g27242}#)
- #((m27243 top))
- #("i27247"))
- #(ribcage #(x) #((top)) #("i27240"))
+ #(#{ g60549}#)
+ #((m60550 top))
+ #("i60554"))
+ #(ribcage #(x) #((top)) #("i60547"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i27234"))
+ #(ribcage #(x) #((top)) #("i60541"))
#(ribcage
(emit quasivector
quasilist*
@@ -25439,70 +21503,79 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{ g27242 27774}#))
- #{tmp 27772}#)
+ #{ g60549 61102}#))
+ #{tmp 61100}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp 27771}#)))))
- #{tmp 27766}#)
- (let ((#{tmp 27775}#
+ #{tmp 61099}#)))))
+ #{tmp 61094}#)
+ (let ((#{tmp 61103}#
($sc-dispatch
- #{x 27759}#
+ #{x 61087}#
'(#(atom "list*") . #(each+ any (any) ())))))
- (if #{tmp 27775}#
+ (if #{tmp 61103}#
(@apply
- (lambda (#{x 27779}# #{y 27780}#)
+ (lambda (#{x 61107}# #{y 61108}#)
(letrec*
- ((#{f 27781}#
- (lambda (#{x* 27784}#)
- (if (null? #{x* 27784}#)
- (#{emit 27319}# #{y 27780}#)
- (let ((#{tmp 27785}#
- (list (#{emit 27319}#
- (car #{x* 27784}#))
- (#{f 27781}#
- (cdr #{x* 27784}#)))))
- (let ((#{tmp 27786}#
+ ((#{f 61109}#
+ (lambda (#{x* 61112}#)
+ (if (null? #{x* 61112}#)
+ (#{emit 60626}# #{y 61108}#)
+ (let ((#{tmp 61113}#
+ (list (#{emit 60626}#
+ (car #{x* 61112}#))
+ (#{f 61109}#
+ (cdr #{x* 61112}#)))))
+ (let ((#{tmp 61114}#
($sc-dispatch
- #{tmp 27785}#
+ #{tmp 61113}#
'(any any))))
- (if #{tmp 27786}#
+ (if #{tmp 61114}#
(@apply
- (lambda (#{ g27262 27788}#
- #{ g27261 27789}#)
+ (lambda (#{ g60569 61116}#
+ #{ g60568 61117}#)
(list '#(syntax-object
cons
((top)
#(ribcage () () ())
#(ribcage
- #(#{ g27262}#
- #{ g27261}#)
- #((m27263 top)
- (m27263 top))
- #("i27267" "i27268"))
+ #(#{ g60569}#
+ #{ g60568}#)
+ #((m60570 top)
+ (m60570 top))
+ #("i60574" "i60575"))
#(ribcage () () ())
#(ribcage
#(f x*)
#((top) (top))
- #("i27256" "i27257"))
+ #("i60563" "i60564"))
#(ribcage
#(x y)
#((top) (top))
- #("i27252" "i27253"))
+ #("i60559" "i60560"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i27234"))
+ #("i60541"))
#(ribcage
(emit quasivector
quasilist*
@@ -25517,56 +21590,66 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- #{ g27262 27788}#
- #{ g27261 27789}#))
- #{tmp 27786}#)
+ #{ g60569 61116}#
+ #{ g60568 61117}#))
+ #{tmp 61114}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp 27785}#))))))))
- (#{f 27781}# #{x 27779}#)))
- #{tmp 27775}#)
- (let ((#{tmp 27790}#
+ #{tmp 61113}#))))))))
+ (#{f 61109}# #{x 61107}#)))
+ #{tmp 61103}#)
+ (let ((#{tmp 61118}#
($sc-dispatch
- #{x 27759}#
+ #{x 61087}#
'(#(atom "append") . each-any))))
- (if #{tmp 27790}#
+ (if #{tmp 61118}#
(@apply
- (lambda (#{x 27794}#)
- (let ((#{tmp 27795}#
- (map #{emit 27319}# #{x 27794}#)))
- (let ((#{tmp 27796}#
+ (lambda (#{x 61122}#)
+ (let ((#{tmp 61123}#
+ (map #{emit 60626}# #{x 61122}#)))
+ (let ((#{tmp 61124}#
($sc-dispatch
- #{tmp 27795}#
+ #{tmp 61123}#
'each-any)))
- (if #{tmp 27796}#
+ (if #{tmp 61124}#
(@apply
- (lambda (#{ g27274 27798}#)
+ (lambda (#{ g60581 61126}#)
(cons '#(syntax-object
append
((top)
#(ribcage () () ())
#(ribcage
- #(#{ g27274}#)
- #((m27275 top))
- #("i27279"))
+ #(#{ g60581}#)
+ #((m60582 top))
+ #("i60586"))
#(ribcage
#(x)
#((top))
- #("i27272"))
+ #("i60579"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i27234"))
+ #("i60541"))
#(ribcage
(emit quasivector
quasilist*
@@ -25581,54 +21664,63 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{ g27274 27798}#))
- #{tmp 27796}#)
+ #{ g60581 61126}#))
+ #{tmp 61124}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp 27795}#)))))
- #{tmp 27790}#)
- (let ((#{tmp 27799}#
+ #{tmp 61123}#)))))
+ #{tmp 61118}#)
+ (let ((#{tmp 61127}#
($sc-dispatch
- #{x 27759}#
+ #{x 61087}#
'(#(atom "vector") . each-any))))
- (if #{tmp 27799}#
+ (if #{tmp 61127}#
(@apply
- (lambda (#{x 27803}#)
- (let ((#{tmp 27804}#
- (map #{emit 27319}# #{x 27803}#)))
- (let ((#{tmp 27805}#
+ (lambda (#{x 61131}#)
+ (let ((#{tmp 61132}#
+ (map #{emit 60626}# #{x 61131}#)))
+ (let ((#{tmp 61133}#
($sc-dispatch
- #{tmp 27804}#
+ #{tmp 61132}#
'each-any)))
- (if #{tmp 27805}#
+ (if #{tmp 61133}#
(@apply
- (lambda (#{ g27286 27807}#)
+ (lambda (#{ g60593 61135}#)
(cons '#(syntax-object
vector
((top)
#(ribcage () () ())
#(ribcage
- #(#{ g27286}#)
- #((m27287 top))
- #("i27291"))
+ #(#{ g60593}#)
+ #((m60594 top))
+ #("i60598"))
#(ribcage
#(x)
#((top))
- #("i27284"))
+ #("i60591"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i27234"))
+ #("i60541"))
#(ribcage
(emit quasivector
quasilist*
@@ -25643,47 +21735,57 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- #{ g27286 27807}#))
- #{tmp 27805}#)
+ #{ g60593 61135}#))
+ #{tmp 61133}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp 27804}#)))))
- #{tmp 27799}#)
- (let ((#{tmp 27808}#
+ #{tmp 61132}#)))))
+ #{tmp 61127}#)
+ (let ((#{tmp 61136}#
($sc-dispatch
- #{x 27759}#
+ #{x 61087}#
'(#(atom "list->vector") any))))
- (if #{tmp 27808}#
+ (if #{tmp 61136}#
(@apply
- (lambda (#{x 27812}#)
- (let ((#{tmp 27813}#
- (#{emit 27319}# #{x 27812}#)))
+ (lambda (#{x 61140}#)
+ (let ((#{tmp 61141}#
+ (#{emit 60626}# #{x 61140}#)))
(list '#(syntax-object
list->vector
((top)
#(ribcage () () ())
#(ribcage
- #(#{ g27298}#)
- #((m27299 top))
- #("i27302"))
+ #(#{ g60605}#)
+ #((m60606 top))
+ #("i60609"))
#(ribcage
#(x)
#((top))
- #("i27296"))
+ #("i60603"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i27234"))
+ #("i60541"))
#(ribcage
(emit quasivector
quasilist*
@@ -25698,188 +21800,215 @@
(top)
(top)
(top))
- ("i27055"
- "i27053"
- "i27051"
- "i27049"
- "i27047"
- "i27045"
- "i27043")))
+ ("i60362"
+ "i60360"
+ "i60358"
+ "i60356"
+ "i60354"
+ "i60352"
+ "i60350"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{tmp 27813}#)))
- #{tmp 27808}#)
- (let ((#{tmp 27816}#
+ #{tmp 61141}#)))
+ #{tmp 61136}#)
+ (let ((#{tmp 61144}#
($sc-dispatch
- #{x 27759}#
+ #{x 61087}#
'(#(atom "value") any))))
- (if #{tmp 27816}#
+ (if #{tmp 61144}#
(@apply
- (lambda (#{x 27820}#) #{x 27820}#)
- #{tmp 27816}#)
+ (lambda (#{x 61148}#) #{x 61148}#)
+ #{tmp 61144}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 27759}#))))))))))))))))))
- (lambda (#{x 27320}#)
- (let ((#{tmp 27322}#
- ($sc-dispatch #{x 27320}# '(_ any))))
- (if #{tmp 27322}#
+ #{x 61087}#))))))))))))))))))
+ (lambda (#{x 60627}#)
+ (let ((#{tmp 60629}#
+ ($sc-dispatch #{x 60627}# '(_ any))))
+ (if #{tmp 60629}#
(@apply
- (lambda (#{e 27326}#)
- (#{emit 27319}# (#{quasi 27313}# #{e 27326}# 0)))
- #{tmp 27322}#)
+ (lambda (#{e 60633}#)
+ (#{emit 60626}# (#{quasi 60620}# #{e 60633}# 0)))
+ #{tmp 60629}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 27320}#)))))))
+ #{x 60627}#)))))))
(define include
(make-syntax-transformer
'include
'macro
- (lambda (#{x 27875}#)
+ (lambda (#{x 61204}#)
(letrec*
- ((#{read-file 27876}#
- (lambda (#{fn 27985}# #{k 27986}#)
- (let ((#{p 27987}# (open-input-file #{fn 27985}#)))
+ ((#{read-file 61205}#
+ (lambda (#{fn 61314}# #{k 61315}#)
+ (let ((#{p 61316}# (open-input-file #{fn 61314}#)))
(letrec*
- ((#{f 27988}#
- (lambda (#{x 28042}# #{result 28043}#)
- (if (eof-object? #{x 28042}#)
+ ((#{f 61317}#
+ (lambda (#{x 61371}# #{result 61372}#)
+ (if (eof-object? #{x 61371}#)
(begin
- (close-input-port #{p 27987}#)
- (reverse #{result 28043}#))
- (#{f 27988}#
- (read #{p 27987}#)
- (cons (datum->syntax #{k 27986}# #{x 28042}#)
- #{result 28043}#))))))
- (#{f 27988}# (read #{p 27987}#) '()))))))
- (let ((#{tmp 27878}#
- ($sc-dispatch #{x 27875}# '(any any))))
- (if #{tmp 27878}#
+ (close-input-port #{p 61316}#)
+ (reverse #{result 61372}#))
+ (#{f 61317}#
+ (read #{p 61316}#)
+ (cons (datum->syntax #{k 61315}# #{x 61371}#)
+ #{result 61372}#))))))
+ (#{f 61317}# (read #{p 61316}#) '()))))))
+ (let ((#{tmp 61207}#
+ ($sc-dispatch #{x 61204}# '(any any))))
+ (if #{tmp 61207}#
(@apply
- (lambda (#{k 27882}# #{filename 27883}#)
- (let ((#{fn 27884}# (syntax->datum #{filename 27883}#)))
- (let ((#{tmp 27885}#
- (#{read-file 27876}#
- #{fn 27884}#
- #{filename 27883}#)))
- (let ((#{tmp 27886}#
- ($sc-dispatch #{tmp 27885}# 'each-any)))
- (if #{tmp 27886}#
+ (lambda (#{k 61211}# #{filename 61212}#)
+ (let ((#{fn 61213}# (syntax->datum #{filename 61212}#)))
+ (let ((#{tmp 61214}#
+ (#{read-file 61205}#
+ #{fn 61213}#
+ #{filename 61212}#)))
+ (let ((#{tmp 61215}#
+ ($sc-dispatch #{tmp 61214}# 'each-any)))
+ (if #{tmp 61215}#
(@apply
- (lambda (#{exp 27904}#)
+ (lambda (#{exp 61233}#)
(cons '#(syntax-object
begin
((top)
#(ribcage () () ())
- #(ribcage #(exp) #((top)) #("i27872"))
+ #(ribcage #(exp) #((top)) #("i61201"))
#(ribcage () () ())
#(ribcage () () ())
- #(ribcage #(fn) #((top)) #("i27867"))
+ #(ribcage #(fn) #((top)) #("i61196"))
#(ribcage
#(k filename)
#((top) (top))
- #("i27863" "i27864"))
- #(ribcage (read-file) ((top)) ("i27847"))
- #(ribcage #(x) #((top)) #("i27846")))
+ #("i61192" "i61193"))
+ #(ribcage (read-file) ((top)) ("i61176"))
+ #(ribcage #(x) #((top)) #("i61175"))
+ #(ribcage
+ (include)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ include
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{exp 27904}#))
- #{tmp 27886}#)
+ #{exp 61233}#))
+ #{tmp 61215}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{tmp 27885}#))))))
- #{tmp 27878}#)
+ #{tmp 61214}#))))))
+ #{tmp 61207}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 27875}#)))))))
+ #{x 61204}#)))))))
(define include-from-path
(make-syntax-transformer
'include-from-path
'macro
- (lambda (#{x 28062}#)
- (let ((#{tmp 28064}#
- ($sc-dispatch #{x 28062}# '(any any))))
- (if #{tmp 28064}#
+ (lambda (#{x 61392}#)
+ (let ((#{tmp 61394}#
+ ($sc-dispatch #{x 61392}# '(any any))))
+ (if #{tmp 61394}#
(@apply
- (lambda (#{k 28068}# #{filename 28069}#)
- (let ((#{fn 28070}# (syntax->datum #{filename 28069}#)))
- (let ((#{tmp 28071}#
+ (lambda (#{k 61398}# #{filename 61399}#)
+ (let ((#{fn 61400}# (syntax->datum #{filename 61399}#)))
+ (let ((#{tmp 61401}#
(datum->syntax
- #{filename 28069}#
- (let ((#{t 28074}# (%search-load-path #{fn 28070}#)))
- (if #{t 28074}#
- #{t 28074}#
+ #{filename 61399}#
+ (let ((#{t 61404}# (%search-load-path #{fn 61400}#)))
+ (if #{t 61404}#
+ #{t 61404}#
(syntax-violation
'include-from-path
"file not found in path"
- #{x 28062}#
- #{filename 28069}#))))))
+ #{x 61392}#
+ #{filename 61399}#))))))
(list '#(syntax-object
include
((top)
#(ribcage () () ())
- #(ribcage #(fn) #((top)) #("i28056"))
+ #(ribcage #(fn) #((top)) #("i61386"))
#(ribcage () () ())
#(ribcage () () ())
- #(ribcage #(fn) #((top)) #("i28052"))
+ #(ribcage #(fn) #((top)) #("i61382"))
#(ribcage
#(k filename)
#((top) (top))
- #("i28048" "i28049"))
+ #("i61378" "i61379"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28045")))
+ #(ribcage #(x) #((top)) #("i61375"))
+ #(ribcage
+ (include-from-path)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ include-from-path
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{tmp 28071}#))))
- #{tmp 28064}#)
+ #{tmp 61401}#))))
+ #{tmp 61394}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 28062}#))))))
+ #{x 61392}#))))))
(define unquote
(make-syntax-transformer
'unquote
'macro
- (lambda (#{x 28083}#)
+ (lambda (#{x 61414}#)
(syntax-violation
'unquote
"expression not valid outside of quasiquote"
- #{x 28083}#))))
+ #{x 61414}#))))
(define unquote-splicing
(make-syntax-transformer
'unquote-splicing
'macro
- (lambda (#{x 28086}#)
+ (lambda (#{x 61418}#)
(syntax-violation
'unquote-splicing
"expression not valid outside of quasiquote"
- #{x 28086}#))))
+ #{x 61418}#))))
(define case
(make-syntax-transformer
'case
'macro
- (lambda (#{x 28142}#)
- (let ((#{tmp 28144}#
+ (lambda (#{x 61475}#)
+ (let ((#{tmp 61477}#
($sc-dispatch
- #{x 28142}#
+ #{x 61475}#
'(_ any any . each-any))))
- (if #{tmp 28144}#
+ (if #{tmp 61477}#
(@apply
- (lambda (#{e 28148}# #{m1 28149}# #{m2 28150}#)
- (let ((#{tmp 28151}#
+ (lambda (#{e 61481}# #{m1 61482}# #{m2 61483}#)
+ (let ((#{tmp 61484}#
(letrec*
- ((#{f 28193}#
- (lambda (#{clause 28196}# #{clauses 28197}#)
- (if (null? #{clauses 28197}#)
- (let ((#{tmp 28199}#
+ ((#{f 61538}#
+ (lambda (#{clause 61541}# #{clauses 61542}#)
+ (if (null? #{clauses 61542}#)
+ (let ((#{tmp 61544}#
($sc-dispatch
- #{clause 28196}#
+ #{clause 61541}#
'(#(free-id
#(syntax-object
else
@@ -25888,91 +22017,118 @@
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
any
.
each-any))))
- (if #{tmp 28199}#
+ (if #{tmp 61544}#
(@apply
- (lambda (#{e1 28203}# #{e2 28204}#)
+ (lambda (#{e1 61548}# #{e2 61549}#)
(cons '#(syntax-object
begin
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("i28110" "i28111"))
+ #("i61443" "i61444"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons #{e1 28203}# #{e2 28204}#)))
- #{tmp 28199}#)
- (let ((#{tmp 28205}#
+ (cons #{e1 61548}# #{e2 61549}#)))
+ #{tmp 61544}#)
+ (let ((#{tmp 61550}#
($sc-dispatch
- #{clause 28196}#
+ #{clause 61541}#
'(each-any any . each-any))))
- (if #{tmp 28205}#
+ (if #{tmp 61550}#
(@apply
- (lambda (#{k 28209}#
- #{e1 28210}#
- #{e2 28211}#)
+ (lambda (#{k 61554}#
+ #{e1 61555}#
+ #{e2 61556}#)
(list '#(syntax-object
if
((top)
#(ribcage
#(k e1 e2)
#((top) (top) (top))
- #("i28116"
- "i28117"
- "i28118"))
+ #("i61449"
+ "i61450"
+ "i61451"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list '#(syntax-object
memv
@@ -25982,9 +22138,9 @@
#((top)
(top)
(top))
- #("i28116"
- "i28117"
- "i28118"))
+ #("i61449"
+ "i61450"
+ "i61451"))
#(ribcage () () ())
#(ribcage
#(f
@@ -25993,22 +22149,32 @@
#((top)
(top)
(top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top)
(top)
(top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
'#(syntax-object
t
@@ -26018,9 +22184,9 @@
#((top)
(top)
(top))
- #("i28116"
- "i28117"
- "i28118"))
+ #("i61449"
+ "i61450"
+ "i61451"))
#(ribcage () () ())
#(ribcage
#(f
@@ -26029,22 +22195,32 @@
#((top)
(top)
(top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top)
(top)
(top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
(list '#(syntax-object
quote
@@ -26054,9 +22230,9 @@
#((top)
(top)
(top))
- #("i28116"
- "i28117"
- "i28118"))
+ #("i61449"
+ "i61450"
+ "i61451"))
#(ribcage
()
()
@@ -26068,17 +22244,17 @@
#((top)
(top)
(top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top)
(top)
(top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage
()
()
@@ -26086,10 +22262,21 @@
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- #{k 28209}#))
+ #{k 61554}#))
(cons '#(syntax-object
begin
((top)
@@ -26098,9 +22285,9 @@
#((top)
(top)
(top))
- #("i28116"
- "i28117"
- "i28118"))
+ #("i61449"
+ "i61450"
+ "i61451"))
#(ribcage () () ())
#(ribcage
#(f
@@ -26109,76 +22296,95 @@
#((top)
(top)
(top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top)
(top)
(top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- (cons #{e1 28210}#
- #{e2 28211}#))))
- #{tmp 28205}#)
+ (cons #{e1 61555}#
+ #{e2 61556}#))))
+ #{tmp 61550}#)
(syntax-violation
'case
"bad clause"
- #{x 28142}#
- #{clause 28196}#)))))
- (let ((#{tmp 28219}#
- (#{f 28193}#
- (car #{clauses 28197}#)
- (cdr #{clauses 28197}#))))
- (let ((#{tmp 28222}#
+ #{x 61475}#
+ #{clause 61541}#)))))
+ (let ((#{tmp 61564}#
+ (#{f 61538}#
+ (car #{clauses 61542}#)
+ (cdr #{clauses 61542}#))))
+ (let ((#{tmp 61567}#
($sc-dispatch
- #{clause 28196}#
+ #{clause 61541}#
'(each-any any . each-any))))
- (if #{tmp 28222}#
+ (if #{tmp 61567}#
(@apply
- (lambda (#{k 28226}#
- #{e1 28227}#
- #{e2 28228}#)
+ (lambda (#{k 61571}#
+ #{e1 61572}#
+ #{e2 61573}#)
(list '#(syntax-object
if
((top)
#(ribcage
#(k e1 e2)
#((top) (top) (top))
- #("i28132"
- "i28133"
- "i28134"))
+ #("i61465"
+ "i61466"
+ "i61467"))
#(ribcage () () ())
#(ribcage
#(rest)
#((top))
- #("i28128"))
+ #("i61461"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list '#(syntax-object
memv
@@ -26186,32 +22392,42 @@
#(ribcage
#(k e1 e2)
#((top) (top) (top))
- #("i28132"
- "i28133"
- "i28134"))
+ #("i61465"
+ "i61466"
+ "i61467"))
#(ribcage () () ())
#(ribcage
#(rest)
#((top))
- #("i28128"))
+ #("i61461"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
'#(syntax-object
t
@@ -26219,32 +22435,42 @@
#(ribcage
#(k e1 e2)
#((top) (top) (top))
- #("i28132"
- "i28133"
- "i28134"))
+ #("i61465"
+ "i61466"
+ "i61467"))
#(ribcage () () ())
#(ribcage
#(rest)
#((top))
- #("i28128"))
+ #("i61461"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
(list '#(syntax-object
quote
@@ -26254,9 +22480,9 @@
#((top)
(top)
(top))
- #("i28132"
- "i28133"
- "i28134"))
+ #("i61465"
+ "i61466"
+ "i61467"))
#(ribcage
()
()
@@ -26264,7 +22490,7 @@
#(ribcage
#(rest)
#((top))
- #("i28128"))
+ #("i61461"))
#(ribcage
()
()
@@ -26276,17 +22502,17 @@
#((top)
(top)
(top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top)
(top)
(top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage
()
()
@@ -26294,232 +22520,415 @@
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- #{k 28226}#))
+ #{k 61571}#))
(cons '#(syntax-object
begin
((top)
#(ribcage
#(k e1 e2)
#((top) (top) (top))
- #("i28132"
- "i28133"
- "i28134"))
+ #("i61465"
+ "i61466"
+ "i61467"))
#(ribcage () () ())
#(ribcage
#(rest)
#((top))
- #("i28128"))
+ #("i61461"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("i28101"
- "i28102"
- "i28103"))
+ #("i61434"
+ "i61435"
+ "i61436"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("i28091"
- "i28092"
- "i28093"))
+ #("i61424"
+ "i61425"
+ "i61426"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28088")))
+ #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- (cons #{e1 28227}#
- #{e2 28228}#))
- #{tmp 28219}#))
- #{tmp 28222}#)
+ (cons #{e1 61572}#
+ #{e2 61573}#))
+ #{tmp 61564}#))
+ #{tmp 61567}#)
(syntax-violation
'case
"bad clause"
- #{x 28142}#
- #{clause 28196}#))))))))
- (#{f 28193}# #{m1 28149}# #{m2 28150}#))))
- (let ((#{body 28152}# #{tmp 28151}#))
+ #{x 61475}#
+ #{clause 61541}#))))))))
+ (#{f 61538}# #{m1 61482}# #{m2 61483}#))))
+ (let ((#{body 61485}# #{tmp 61484}#))
(list '#(syntax-object
let
((top)
#(ribcage () () ())
- #(ribcage #(body) #((top)) #("i28099"))
+ #(ribcage #(body) #((top)) #("i61432"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("i28091" "i28092" "i28093"))
+ #("i61424" "i61425" "i61426"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28088")))
+ #(ribcage #(x) #((top)) #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list (list '#(syntax-object
t
((top)
#(ribcage () () ())
- #(ribcage #(body) #((top)) #("i28099"))
+ #(ribcage #(body) #((top)) #("i61432"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("i28091" "i28092" "i28093"))
+ #("i61424" "i61425" "i61426"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28088")))
+ #(ribcage #(x) #((top)) #("i61421"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{e 28148}#))
- #{body 28152}#))))
- #{tmp 28144}#)
+ #{e 61481}#))
+ #{body 61485}#))))
+ #{tmp 61477}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 28142}#))))))
+ #{x 61475}#))))))
(define make-variable-transformer
- (lambda (#{proc 28246}#)
- (if (procedure? #{proc 28246}#)
+ (lambda (#{proc 61592}#)
+ (if (procedure? #{proc 61592}#)
(letrec*
- ((#{trans 28247}#
- (lambda (#{x 28253}#)
- (#{proc 28246}# #{x 28253}#))))
+ ((#{trans 61593}#
+ (lambda (#{x 61595}#)
+ (#{proc 61592}# #{x 61595}#))))
(begin
(set-procedure-property!
- #{trans 28247}#
+ #{trans 61593}#
'variable-transformer
#t)
- #{trans 28247}#))
+ #{trans 61593}#))
(error "variable transformer not a procedure"
- #{proc 28246}#))))
+ #{proc 61592}#))))
(define identifier-syntax
(make-syntax-transformer
'identifier-syntax
'macro
- (lambda (#{x 28285}#)
- (let ((#{tmp 28287}#
- ($sc-dispatch #{x 28285}# '(_ any))))
- (if #{tmp 28287}#
+ (lambda (#{x 61632}#)
+ (let ((#{tmp 61634}#
+ ($sc-dispatch #{x 61632}# '(_ any))))
+ (if #{tmp 61634}#
(@apply
- (lambda (#{e 28291}#)
+ (lambda (#{e 61638}#)
(list '#(syntax-object
lambda
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
x
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
'#((#(syntax-object
macro-type
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
.
#(syntax-object
identifier-syntax
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))))
(list '#(syntax-object
syntax-case
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'#(syntax-object
x
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'()
(list '#(syntax-object
id
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
identifier?
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(#(syntax-object
syntax
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
id
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))))
(list '#(syntax-object
syntax
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{e 28291}#))
+ #{e 61638}#))
(list '(#(syntax-object
_
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
x
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
...
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
(list '#(syntax-object
syntax
((top)
- #(ribcage #(e) #((top)) #("i28260"))
+ #(ribcage #(e) #((top)) #("i61607"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons #{e 28291}#
+ (cons #{e 61638}#
'(#(syntax-object
x
((top)
#(ribcage
#(e)
#((top))
- #("i28260"))
+ #("i61607"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
...
@@ -26527,55 +22936,82 @@
#(ribcage
#(e)
#((top))
- #("i28260"))
+ #("i61607"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))))))))
- #{tmp 28287}#)
- (let ((#{tmp 28292}#
+ #{tmp 61634}#)
+ (let ((#{tmp 61639}#
($sc-dispatch
- #{x 28285}#
+ #{x 61632}#
'(_ (any any)
((#(free-id
#(syntax-object
set!
((top)
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
any
any)
any)))))
- (if (if #{tmp 28292}#
+ (if (if #{tmp 61639}#
(@apply
- (lambda (#{id 28296}#
- #{exp1 28297}#
- #{var 28298}#
- #{val 28299}#
- #{exp2 28300}#)
- (if (identifier? #{id 28296}#)
- (identifier? #{var 28298}#)
+ (lambda (#{id 61643}#
+ #{exp1 61644}#
+ #{var 61645}#
+ #{val 61646}#
+ #{exp2 61647}#)
+ (if (identifier? #{id 61643}#)
+ (identifier? #{var 61645}#)
#f))
- #{tmp 28292}#)
+ #{tmp 61639}#)
#f)
(@apply
- (lambda (#{id 28301}#
- #{exp1 28302}#
- #{var 28303}#
- #{val 28304}#
- #{exp2 28305}#)
+ (lambda (#{id 61648}#
+ #{exp1 61649}#
+ #{var 61650}#
+ #{val 61651}#
+ #{exp2 61652}#)
(list '#(syntax-object
make-variable-transformer
((top)
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("i28275" "i28276" "i28277" "i28278" "i28279"))
+ #("i61622" "i61623" "i61624" "i61625" "i61626"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list '#(syntax-object
lambda
@@ -26583,13 +23019,22 @@
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
x
@@ -26597,13 +23042,22 @@
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
'#((#(syntax-object
macro-type
@@ -26611,13 +23065,22 @@
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
.
#(syntax-object
@@ -26626,13 +23089,22 @@
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))))
(list '#(syntax-object
syntax-case
@@ -26640,13 +23112,22 @@
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'#(syntax-object
x
@@ -26654,13 +23135,22 @@
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
set!
@@ -26668,13 +23158,22 @@
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28257")))
+ #(ribcage #(x) #((top)) #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
(list (list '#(syntax-object
set!
@@ -26686,19 +23185,28 @@
(top)
(top)
(top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{var 28303}#
- #{val 28304}#)
+ #{var 61650}#
+ #{val 61651}#)
(list '#(syntax-object
syntax
((top)
@@ -26709,19 +23217,28 @@
(top)
(top)
(top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{exp2 28305}#))
- (list (cons #{id 28301}#
+ #{exp2 61652}#))
+ (list (cons #{id 61648}#
'(#(syntax-object
x
((top)
@@ -26732,16 +23249,25 @@
(top)
(top)
(top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
...
@@ -26753,16 +23279,25 @@
(top)
(top)
(top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))))
(list '#(syntax-object
syntax
@@ -26774,18 +23309,27 @@
(top)
(top)
(top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons #{exp1 28302}#
+ (cons #{exp1 61649}#
'(#(syntax-object
x
((top)
@@ -26800,16 +23344,26 @@
(top)
(top)
(top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
#(syntax-object
...
@@ -26825,18 +23379,28 @@
(top)
(top)
(top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))))))
- (list #{id 28301}#
+ (list #{id 61648}#
(list '#(syntax-object
identifier?
((top)
@@ -26847,16 +23411,25 @@
(top)
(top)
(top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list '#(syntax-object
syntax
@@ -26872,18 +23445,28 @@
(top)
(top)
(top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- #{id 28301}#))
+ #{id 61648}#))
(list '#(syntax-object
syntax
((top)
@@ -26894,68 +23477,95 @@
(top)
(top)
(top))
- #("i28275"
- "i28276"
- "i28277"
- "i28278"
- "i28279"))
+ #("i61622"
+ "i61623"
+ "i61624"
+ "i61625"
+ "i61626"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i28257")))
+ #("i61604"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{exp1 28302}#))))))
- #{tmp 28292}#)
+ #{exp1 61649}#))))))
+ #{tmp 61639}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 28285}#))))))))
+ #{x 61632}#))))))))
(define define*
(make-syntax-transformer
'define*
'macro
- (lambda (#{x 28337}#)
- (let ((#{tmp 28339}#
+ (lambda (#{x 61685}#)
+ (let ((#{tmp 61687}#
($sc-dispatch
- #{x 28337}#
+ #{x 61685}#
'(_ (any . any) any . each-any))))
- (if #{tmp 28339}#
+ (if #{tmp 61687}#
(@apply
- (lambda (#{id 28343}#
- #{args 28344}#
- #{b0 28345}#
- #{b1 28346}#)
+ (lambda (#{id 61691}#
+ #{args 61692}#
+ #{b0 61693}#
+ #{b1 61694}#)
(list '#(syntax-object
define
((top)
#(ribcage
#(id args b0 b1)
#((top) (top) (top) (top))
- #("i28319" "i28320" "i28321" "i28322"))
+ #("i61667" "i61668" "i61669" "i61670"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28316")))
+ #(ribcage #(x) #((top)) #("i61664"))
+ #(ribcage
+ (define*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{id 28343}#
+ #{id 61691}#
(cons '#(syntax-object
lambda*
((top)
#(ribcage
#(id args b0 b1)
#((top) (top) (top) (top))
- #("i28319" "i28320" "i28321" "i28322"))
+ #("i61667" "i61668" "i61669" "i61670"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28316")))
+ #(ribcage #(x) #((top)) #("i61664"))
+ #(ribcage
+ (define*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons #{args 28344}#
- (cons #{b0 28345}# #{b1 28346}#)))))
- #{tmp 28339}#)
- (let ((#{tmp 28347}#
- ($sc-dispatch #{x 28337}# '(_ any any))))
- (if (if #{tmp 28347}#
+ (cons #{args 61692}#
+ (cons #{b0 61693}# #{b1 61694}#)))))
+ #{tmp 61687}#)
+ (let ((#{tmp 61695}#
+ ($sc-dispatch #{x 61685}# '(_ any any))))
+ (if (if #{tmp 61695}#
(@apply
- (lambda (#{id 28351}# #{val 28352}#)
+ (lambda (#{id 61699}# #{val 61700}#)
(identifier?
'#(syntax-object
x
@@ -26963,29 +23573,47 @@
#(ribcage
#(id val)
#((top) (top))
- #("i28329" "i28330"))
+ #("i61677" "i61678"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28316")))
+ #(ribcage #(x) #((top)) #("i61664"))
+ #(ribcage
+ (define*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))))
- #{tmp 28347}#)
+ #{tmp 61695}#)
#f)
(@apply
- (lambda (#{id 28353}# #{val 28354}#)
+ (lambda (#{id 61701}# #{val 61702}#)
(list '#(syntax-object
define
((top)
#(ribcage
#(id val)
#((top) (top))
- #("i28333" "i28334"))
+ #("i61681" "i61682"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("i28316")))
+ #(ribcage #(x) #((top)) #("i61664"))
+ #(ribcage
+ (define*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- #{id 28353}#
- #{val 28354}#))
- #{tmp 28347}#)
+ #{id 61701}#
+ #{val 61702}#))
+ #{tmp 61695}#)
(syntax-violation
#f
"source expression failed to match any pattern"
- #{x 28337}#))))))))
+ #{x 61685}#))))))))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index be6b2b614..1c6a95111 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -313,9 +313,9 @@
(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)
@@ -402,12 +402,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))
@@ -415,7 +417,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)
@@ -436,8 +438,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)
@@ -485,13 +487,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.
;; <environment> ::= ((<label> . <binding>)*)
;; identifier bindings include a type and a value
;; <binding> ::= (macro . <procedure>) macros
+ ;; (syntax-parameter . (<procedure>)) syntax parameters
;; (core . <procedure>) core forms
;; (module-ref . <procedure>) @ or @@
;; (begin) begin
@@ -563,22 +566,10 @@
(if (null? r)
'()
(let ((a (car r)))
- (if (eq? (cadr a) 'macro)
+ (if (memq (cadr a) '(macro syntax-parameter))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
- (define lookup
- ;; x may be a label or a symbol
- ;; although symbols are usually global, we check the environment first
- ;; anyway because a temporary binding may have been established by
- ;; fluid-let-syntax
- (lambda (x r mod)
- (cond
- ((assq x r) => cdr)
- ((symbol? x)
- (or (get-global-definition-hook x mod) (make-binding 'global)))
- (else (make-binding 'displaced-lexical)))))
-
(define global-extend
(lambda (type sym val)
(put-global-definition-hook sym type val)))
@@ -738,69 +729,116 @@
(same-marks? (cdr x) (cdr y))))))
(define id-var-name
- (lambda (id w)
+ ;; Syntax objects use wraps to associate names with marked
+ ;; identifiers. This function returns the name corresponding to
+ ;; the given identifier and wrap, or the original identifier if no
+ ;; corresponding name was found.
+ ;;
+ ;; The name may be a string created by gen-label, indicating a
+ ;; lexical binding, or another syntax object, indicating a
+ ;; reference to a top-level definition created during a previous
+ ;; macroexpansion.
+ ;;
+ ;; For lexical variables, finding a label simply amounts to
+ ;; looking for an entry with the same symbolic name and the same
+ ;; marks. Finding a toplevel definition is the same, except we
+ ;; also have to compare modules, hence the `mod' parameter.
+ ;; Instead of adding a separate entry in the ribcage for modules,
+ ;; which wouldn't be used for lexicals, we arrange for the entry
+ ;; for the name entry to be a pair with the module in its car, and
+ ;; the name itself in the cdr. So if the name that we find is a
+ ;; pair, we have to check modules.
+ ;;
+ ;; The identifer may be passed in wrapped or unwrapped. In any
+ ;; case, this routine returns either a symbol, a syntax object, or
+ ;; a string label.
+ ;;
+ (lambda (id w mod)
(define-syntax-rule (first e)
;; Rely on Guile's multiple-values truncation.
e)
(define search
- (lambda (sym subst marks)
+ (lambda (sym subst marks mod)
(if (null? subst)
(values #f marks)
(let ((fst (car subst)))
(if (eq? fst 'shift)
- (search sym (cdr subst) (cdr marks))
+ (search sym (cdr subst) (cdr marks) mod)
(let ((symnames (ribcage-symnames fst)))
(if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))))))
+ (search-vector-rib sym subst marks symnames fst mod)
+ (search-list-rib sym subst marks symnames fst mod))))))))
(define search-list-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let f ((symnames symnames) (i 0))
(cond
- ((null? symnames) (search sym (cdr subst) marks))
+ ((null? symnames) (search sym (cdr subst) marks mod))
((and (eq? (car symnames) sym)
(same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (list-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (cdr symnames) (fx+ i 1)))
+ (values n marks))))
(else (f (cdr symnames) (fx+ i 1)))))))
(define search-vector-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let ((n (vector-length symnames)))
(let f ((i 0))
(cond
- ((fx= i n) (search sym (cdr subst) marks))
+ ((fx= i n) (search sym (cdr subst) marks mod))
((and (eq? (vector-ref symnames i) sym)
(same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (vector-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (fx+ i 1)))
+ (values n marks))))
(else (f (fx+ i 1))))))))
(cond
((symbol? id)
- (or (first (search id (wrap-subst w) (wrap-marks w))) id))
+ (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id))
((syntax-object? id)
(let ((id (syntax-object-expression id))
- (w1 (syntax-object-wrap id)))
+ (w1 (syntax-object-wrap id))
+ (mod (syntax-object-module id)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
- (call-with-values (lambda () (search id (wrap-subst w) marks))
+ (call-with-values (lambda () (search id (wrap-subst w) marks mod))
(lambda (new-id marks)
(or new-id
- (first (search id (wrap-subst w1) marks))
+ (first (search id (wrap-subst w1) marks mod))
id))))))
(else (syntax-violation 'id-var-name "invalid id" id)))))
;; Returns three values: binding type, binding value, the module (for
;; resolving toplevel vars).
- (define (resolve-identifier id w r mod)
+ (define (resolve-identifier id w r mod resolve-syntax-parameters?)
+ (define (resolve-syntax-parameters b)
+ (if (and resolve-syntax-parameters?
+ (eq? (binding-type b) 'syntax-parameter))
+ (or (assq-ref r (binding-value b))
+ (make-binding 'macro (car (binding-value b))))
+ b))
(define (resolve-global var mod)
- (let ((b (or (get-global-definition-hook var mod)
- (make-binding 'global))))
+ (let ((b (resolve-syntax-parameters
+ (or (get-global-definition-hook var mod)
+ (make-binding 'global)))))
(if (eq? (binding-type b) 'global)
(values 'global var mod)
(values (binding-type b) (binding-value b) mod))))
(define (resolve-lexical label mod)
- (let ((b (or (assq-ref r label)
- (make-binding 'displaced-lexical))))
+ (let ((b (resolve-syntax-parameters
+ (or (assq-ref r label)
+ (make-binding 'displaced-lexical)))))
(values (binding-type b) (binding-value b) mod)))
- (let ((n (id-var-name id w)))
+ (let ((n (id-var-name id w mod)))
(cond
+ ((syntax-object? n)
+ ;; Recursing allows syntax-parameterize to override
+ ;; macro-introduced syntax parameters.
+ (resolve-identifier n w r mod resolve-syntax-parameters?))
((symbol? n)
(resolve-global n (if (syntax-object? id)
(syntax-object-module id)
@@ -825,9 +863,39 @@
(define free-id=?
(lambda (i j)
- (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
- (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
-
+ (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
+ (mj (and (syntax-object? j) (syntax-object-module j)))
+ (ni (id-var-name i empty-wrap mi))
+ (nj (id-var-name j empty-wrap mj)))
+ (define (id-module-binding id mod)
+ (module-variable
+ (if mod
+ ;; The normal case.
+ (resolve-module (cdr mod))
+ ;; Either modules have not been booted, or we have a
+ ;; raw symbol coming in, which is possible.
+ (current-module))
+ (id-sym-name id)))
+ (cond
+ ((syntax-object? ni) (free-id=? ni j))
+ ((syntax-object? nj) (free-id=? i nj))
+ ((symbol? ni)
+ ;; `i' is not lexically bound. Assert that `j' is free,
+ ;; and if so, compare their bindings, that they are either
+ ;; bound to the same variable, or both unbound and have
+ ;; the same name.
+ (and (eq? nj (id-sym-name j))
+ (let ((bi (id-module-binding i mi)))
+ (if bi
+ (eq? bi (id-module-binding j mj))
+ (and (not (id-module-binding j mj))
+ (eq? ni nj))))
+ (eq? (id-module-binding i mi) (id-module-binding j mj))))
+ (else
+ ;; Otherwise `i' is bound, so check that `j' is bound, and
+ ;; bound to the same thing.
+ (equal? ni nj))))))
+
;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;; long as the missing portion of the wrap is common to both of the ids
;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
@@ -918,159 +986,171 @@
;;
(define expand-top-sequence
(lambda (body r w s m esew mod)
- (define (scan body r w s m esew mod exps)
- (cond
- ((null? body)
- ;; in reversed order
- exps)
- (else
+ (let* ((r (cons '("placeholder" . (placeholder)) r))
+ (ribcage (make-empty-ribcage))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
+ (define (record-definition! id var)
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ ;; Ribcages map symbol+marks to names, mostly for
+ ;; resolving lexicals. Here to add a mapping for toplevel
+ ;; definitions we also need to match the module. So, we
+ ;; put it in the name instead, and make id-var-name handle
+ ;; the special case of names that are pairs. See the
+ ;; comments in id-var-name for more.
+ (extend-ribcage! ribcage id
+ (cons (syntax-object-module id)
+ (wrap var top-wrap mod)))))
+ (define (macro-introduced-identifier? id)
+ (not (equal? (wrap-marks (syntax-object-wrap id)) '(top))))
+ (define (fresh-derived-name id orig-form)
+ (symbol-append
+ (syntax-object-expression id)
+ '-
+ (string->symbol
+ ;; FIXME: `hash' currently stops descending into nested
+ ;; data at some point, so it's less unique than we would
+ ;; like. Also this encodes hash values into the ABI of
+ ;; compiled modules; a problem?
+ (number->string
+ (hash (syntax->datum orig-form) most-positive-fixnum)
+ 16))))
+ (define (parse body r w s m esew mod)
+ (let lp ((body body) (exps '()))
+ (if (null? body)
+ exps
+ (lp (cdr body)
+ (append (parse1 (car body) r w s m esew mod)
+ exps)))))
+ (define (parse1 x r w s m esew mod)
(call-with-values
(lambda ()
- (call-with-values
- (lambda ()
- (let ((e (car body)))
- (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
- (lambda (type value e w s mod)
- (case type
- ((begin-form)
- (syntax-case e ()
- ((_) exps)
- ((_ e1 e2 ...)
- (scan #'(e1 e2 ...) r w s m esew mod exps))))
- ((local-syntax-form)
- (expand-local-syntax value e r w s mod
- (lambda (body r w s mod)
- (scan body r w s m esew mod exps))))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (parse-when-list e #'(x ...)))
- (body #'(e1 e2 ...)))
- (cond
- ((eq? m 'e)
- (if (memq 'eval when-list)
- (scan body r w s
- (if (memq 'expand when-list) 'c&e 'e)
- '(eval)
- mod exps)
- (begin
- (if (memq 'expand when-list)
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod))
- (values exps))))
- ((memq 'load when-list)
- (if (or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (scan body r w s 'c&e '(compile load) mod exps)
- (if (memq m '(c c&e))
- (scan body r w s 'c '(load) mod exps)
- (values exps))))
- ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod)
- (values exps))
- (else
- (values exps)))))))
- ((define-syntax-form define-syntax-parameter-form)
- (let ((n (id-var-name value w)) (r (macros-only-env r)))
- (case m
- ((c)
- (if (memq 'compile esew)
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (if (memq 'load esew)
- (values (cons e exps))
- (values exps)))
- (if (memq 'load esew)
- (values (cons (expand-install-global n (expand e r w mod))
- exps))
- (values exps))))
- ((c&e)
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (values (cons e exps))))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (expand-install-global n (expand e r w mod))
- mod))
- (values exps)))))
- ((define-form)
- (let* ((n (id-var-name value w))
- ;; Lookup the name in the module of the define form.
- (type (binding-type (lookup n r mod))))
- (case type
- ((global core macro module-ref)
- ;; affect compile-time environment (once we have booted)
- (if (and (memq m '(c c&e))
- (not (module-local-variable (current-module) n))
- (current-module))
- (let ((old (module-variable (current-module) n)))
- ;; use value of the same-named imported variable, if
- ;; any
- (if (and (variable? old) (variable-bound? old))
- (module-define! (current-module) n (variable-ref old))
- (module-add! (current-module) n (make-undefined-variable)))))
- (values
- (cons
- (if (eq? m 'c&e)
- (let ((x (build-global-definition s n (expand e r w mod))))
- (top-level-eval-hook x mod)
- x)
- (lambda ()
- (build-global-definition s n (expand e r w mod))))
- exps)))
- ((displaced-lexical)
- (syntax-violation #f "identifier out of context"
- e (wrap value w mod)))
- (else
- (syntax-violation #f "cannot define keyword at top level"
- e (wrap value w mod))))))
- (else
- (values (cons
- (if (eq? m 'c&e)
- (let ((x (expand-expr type value e r w s mod)))
- (top-level-eval-hook x mod)
- x)
- (lambda ()
- (expand-expr type value e r w s mod)))
- exps)))))))
- (lambda (exps)
- (scan (cdr body) r w s m esew mod exps))))))
-
- (call-with-values (lambda ()
- (scan body r w s m esew mod '()))
- (lambda (exps)
+ (syntax-type x r w (source-annotation x) ribcage mod #f))
+ (lambda (type value e w s mod)
+ (case type
+ ((define-form)
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (list
+ (if (eq? m 'c&e)
+ (let ((x (build-global-definition s var (expand e r w mod))))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda ()
+ (build-global-definition s var (expand e r w mod)))))))
+ ((define-syntax-form define-syntax-parameter-form)
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (case m
+ ((c)
+ (cond
+ ((memq 'compile esew)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (if (memq 'load esew)
+ (list (lambda () e))
+ '())))
+ ((memq 'load esew)
+ (list (lambda ()
+ (expand-install-global var type (expand e r w mod)))))
+ (else '())))
+ ((c&e)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (list (lambda () e))))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (expand-install-global var type (expand e r w mod))
+ mod))
+ '()))))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 ...)
+ (parse #'(e1 ...) r w s m esew mod))))
+ ((local-syntax-form)
+ (expand-local-syntax value e r w s mod
+ (lambda (forms r w s mod)
+ (parse forms r w s m esew mod))))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (parse-when-list e #'(x ...)))
+ (body #'(e1 e2 ...)))
+ (define (recurse m esew)
+ (parse body r w s m esew mod))
+ (cond
+ ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (recurse (if (memq 'expand when-list) 'c&e 'e)
+ '(eval))
+ (begin
+ (if (memq 'expand when-list)
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod))
+ '())))
+ ((memq 'load when-list)
+ (if (or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (recurse 'c&e '(compile load))
+ (if (memq m '(c c&e))
+ (recurse 'c '(load))
+ '())))
+ ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod)
+ '())
+ (else
+ '()))))))
+ (else
+ (list
+ (if (eq? m 'c&e)
+ (let ((x (expand-expr type value e r w s mod)))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda ()
+ (expand-expr type value e r w s mod)))))))))
+ (let ((exps (map (lambda (x) (x))
+ (reverse (parse body r w s m esew mod)))))
(if (null? exps)
(build-void s)
- (build-sequence
- s
- (let lp ((in exps) (out '()))
- (if (null? in) out
- (let ((e (car in)))
- (lp (cdr in)
- (cons (if (procedure? e) (e) e) out)))))))))))
+ (build-sequence s exps))))))
(define expand-install-global
- (lambda (name e)
+ (lambda (name type e)
(build-global-definition
no-source
name
- (build-application
+ (build-primcall
no-source
- (build-primref no-source 'make-syntax-transformer)
- (list (build-data no-source name)
- (build-data no-source 'macro)
- e)))))
-
+ 'make-syntax-transformer
+ (if (eq? type 'define-syntax-parameter-form)
+ (list (build-data no-source name)
+ (build-data no-source 'syntax-parameter)
+ (build-primcall no-source 'list (list e)))
+ (list (build-data no-source name)
+ (build-data no-source 'macro)
+ e))))))
+
(define parse-when-list
(lambda (e when-list)
- ;; when-list is syntax'd version of list of situations
+ ;; `when-list' is syntax'd version of list of situations. We
+ ;; could match these keywords lexically, via free-id=?, but then
+ ;; we twingle the definition of eval-when to the bindings of
+ ;; eval, load, expand, and compile, which is totally unintended.
+ ;; So do a symbolic match instead.
(let ((result (strip when-list empty-wrap)))
(let lp ((l result))
(if (null? l)
@@ -1123,18 +1203,19 @@
(lambda (e r w s rib mod for-car?)
(cond
((symbol? e)
- (let* ((n (id-var-name e w))
- (b (lookup n r mod))
- (type (binding-type b)))
- (case type
- ((lexical) (values type (binding-value b) e w s mod))
- ((global) (values type n e w s mod))
- ((macro)
- (if for-car?
- (values type (binding-value b) e w s mod)
- (syntax-type (expand-macro (binding-value b) e r w s rib mod)
- r empty-wrap s rib mod #f)))
- (else (values type (binding-value b) e w s mod)))))
+ (call-with-values (lambda () (resolve-identifier e w r mod #t))
+ (lambda (type value mod*)
+ (case type
+ ((macro)
+ (if for-car?
+ (values type value e w s mod)
+ (syntax-type (expand-macro value e r w s rib mod)
+ r empty-wrap s rib mod #f)))
+ ((global)
+ ;; Toplevel definitions may resolve to bindings with
+ ;; different names or in different modules.
+ (values type value value w s mod*))
+ (else (values type value e w s mod))))))
((pair? e)
(let ((first (car e)))
(call-with-values
@@ -1224,7 +1305,7 @@
(lambda (e r w s mod)
(expand e r w mod))))
((lexical-call)
- (expand-application
+ (expand-call
(let ((id (car e)))
(build-lexical-reference 'fun (source-annotation id)
(if (syntax-object? id)
@@ -1233,7 +1314,7 @@
value))
e r w s mod))
((global-call)
- (expand-application
+ (expand-call
(build-global-reference (source-annotation (car e))
(if (syntax-object? value)
(syntax-object-expression value)
@@ -1244,18 +1325,13 @@
e r w s mod))
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value mod))
- ((call) (expand-application (expand (car e) r w mod) e r w s mod))
+ ((call) (expand-call (expand (car e) r w mod) e r w s mod))
((begin-form)
(syntax-case e ()
((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))
((_)
- (if (include-deprecated-features)
- (begin
- (issue-deprecation-warning
- "Sequences of zero expressions are deprecated. Use *unspecified*.")
- (expand-void))
- (syntax-violation #f "sequence of zero expressions"
- (source-wrap e w s mod))))))
+ (syntax-violation #f "sequence of zero expressions"
+ (source-wrap e w s mod)))))
((local-syntax-form)
(expand-local-syntax value e r w s mod expand-sequence))
((eval-when-form)
@@ -1277,12 +1353,12 @@
(else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod))))))
- (define expand-application
+ (define expand-call
(lambda (x e r w s mod)
(syntax-case e ()
((e0 e1 ...)
- (build-application s x
- (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
+ (build-call s x
+ (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
;; (What follows is my interpretation of what's going on here -- Andy)
;;
@@ -1307,7 +1383,7 @@
;;
;; The only wrinkle is when we want a macro to expand to code in another
;; module, as is the case for the r6rs `library' form -- the body expressions
- ;; should be scoped relative the new module, the one defined by the macro.
+ ;; should be scoped relative the the new module, the one defined by the macro.
;; For that, use `(@@ mod-name body)'.
;;
;; Part of the macro output will be from the site of the macro use and part
@@ -1428,7 +1504,11 @@
(parse (cdr body)
(cons id ids) (cons label labels)
var-ids vars vals
- (cons (make-binding 'macro (cons er (wrap e w mod)))
+ (cons (make-binding
+ (if (eq? type 'define-syntax-parameter-form)
+ 'syntax-parameter
+ 'macro)
+ (cons er (wrap e w mod)))
bindings))))
((begin-form)
(syntax-case e ()
@@ -1463,7 +1543,7 @@
(let loop ((bs bindings) (er-cache #f) (r-cache #f))
(if (not (null? bs))
(let* ((b (car bs)))
- (if (eq? (car b) 'macro)
+ (if (memq (car b) '(macro syntax-parameter))
(let* ((er (cadr b))
(r-cache
(if (eq? er er-cache)
@@ -1473,6 +1553,8 @@
(eval-local-transformer
(expand (cddr b) r-cache empty-wrap mod)
mod))
+ (if (eq? (car b) 'syntax-parameter)
+ (set-cdr! b (list (cdr b))))
(loop (cdr bs) er r-cache))
(loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r)))
@@ -1799,38 +1881,45 @@
(global-extend 'local-syntax 'letrec-syntax #t)
(global-extend 'local-syntax 'let-syntax #f)
- (global-extend 'core 'syntax-parameterize
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((var val) ...) e1 e2 ...)
- (valid-bound-ids? #'(var ...))
- (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...))))
- (for-each
- (lambda (id n)
- (case (binding-type (lookup n r mod))
- ((displaced-lexical)
- (syntax-violation 'syntax-parameterize
- "identifier out of context"
- e
- (source-wrap id w s mod)))))
- #'(var ...)
- names)
- (expand-body
- #'(e1 e2 ...)
- (source-wrap e w s mod)
- (extend-env
- names
- (let ((trans-r (macros-only-env r)))
- (map (lambda (x)
- (make-binding 'macro
- (eval-local-transformer (expand x trans-r w mod)
- mod)))
- #'(val ...)))
- r)
- w
- mod)))
- (_ (syntax-violation 'syntax-parameterize "bad syntax"
- (source-wrap e w s mod))))))
+ (global-extend
+ 'core 'syntax-parameterize
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ ((var val) ...) e1 e2 ...)
+ (valid-bound-ids? #'(var ...))
+ (let ((names
+ (map (lambda (x)
+ (call-with-values
+ (lambda () (resolve-identifier x w r mod #f))
+ (lambda (type value mod)
+ (case type
+ ((displaced-lexical)
+ (syntax-violation 'syntax-parameterize
+ "identifier out of context"
+ e
+ (source-wrap x w s mod)))
+ ((syntax-parameter)
+ value)
+ (else
+ (syntax-violation 'syntax-parameterize
+ "invalid syntax parameter"
+ e
+ (source-wrap x w s mod)))))))
+ #'(var ...)))
+ (bindings
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (make-binding
+ 'macro
+ (eval-local-transformer (expand x trans-r w mod) mod)))
+ #'(val ...)))))
+ (expand-body #'(e1 e2 ...)
+ (source-wrap e w s mod)
+ (extend-env names bindings r)
+ w
+ mod)))
+ (_ (syntax-violation 'syntax-parameterize "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'quote
(lambda (e r w s mod)
@@ -1839,167 +1928,166 @@
(_ (syntax-violation 'quote "bad syntax"
(source-wrap e w s mod))))))
- (global-extend 'core 'syntax
- (let ()
- (define gen-syntax
- (lambda (src e r maps ellipsis? mod)
- (if (id? e)
- (let ((label (id-var-name e empty-wrap)))
- ;; Mod does not matter, we are looking to see if
- ;; the id is lexical syntax.
- (let ((b (lookup label r mod)))
- (if (eq? (binding-type b) 'syntax)
- (call-with-values
- (lambda ()
- (let ((var.lev (binding-value b)))
- (gen-ref src (car var.lev) (cdr var.lev) maps)))
- (lambda (var maps) (values `(ref ,var) maps)))
- (if (ellipsis? e)
- (syntax-violation 'syntax "misplaced ellipsis" src)
- (values `(quote ,e) maps)))))
- (syntax-case e ()
- ((dots e)
- (ellipsis? #'dots)
- (gen-syntax src #'e r maps (lambda (x) #f) mod))
- ((x dots . y)
- ;; this could be about a dozen lines of code, except that we
- ;; choose to handle #'(x ... ...) forms
- (ellipsis? #'dots)
- (let f ((y #'y)
- (k (lambda (maps)
- (call-with-values
- (lambda ()
- (gen-syntax src #'x r
- (cons '() maps) ellipsis? mod))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis"
- src)
- (values (gen-map x (car maps))
- (cdr maps))))))))
- (syntax-case y ()
- ((dots . y)
- (ellipsis? #'dots)
- (f #'y
- (lambda (maps)
- (call-with-values
- (lambda () (k (cons '() maps)))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis" src)
- (values (gen-mappend x (car maps))
- (cdr maps))))))))
- (_ (call-with-values
- (lambda () (gen-syntax src y r maps ellipsis? mod))
- (lambda (y maps)
- (call-with-values
- (lambda () (k maps))
- (lambda (x maps)
- (values (gen-append x y) maps)))))))))
- ((x . y)
- (call-with-values
- (lambda () (gen-syntax src #'x r maps ellipsis? mod))
- (lambda (x maps)
- (call-with-values
- (lambda () (gen-syntax src #'y r maps ellipsis? mod))
- (lambda (y maps) (values (gen-cons x y) maps))))))
- (#(e1 e2 ...)
- (call-with-values
- (lambda ()
- (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
- (lambda (e maps) (values (gen-vector e) maps))))
- (_ (values `(quote ,e) maps))))))
-
- (define gen-ref
- (lambda (src var level maps)
- (if (fx= level 0)
- (values var maps)
- (if (null? maps)
- (syntax-violation 'syntax "missing ellipsis" src)
- (call-with-values
- (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
- (lambda (outer-var outer-maps)
- (let ((b (assq outer-var (car maps))))
- (if b
- (values (cdr b) maps)
- (let ((inner-var (gen-var 'tmp)))
- (values inner-var
- (cons (cons (cons outer-var inner-var)
- (car maps))
- outer-maps)))))))))))
-
- (define gen-mappend
- (lambda (e map-env)
- `(apply (primitive append) ,(gen-map e map-env))))
-
- (define gen-map
- (lambda (e map-env)
- (let ((formals (map cdr map-env))
- (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
- (cond
- ((eq? (car e) 'ref)
- ;; identity map equivalence:
- ;; (map (lambda (x) x) y) == y
- (car actuals))
- ((and-map
- (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
- (cdr e))
- ;; eta map equivalence:
- ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
- `(map (primitive ,(car e))
- ,@(map (let ((r (map cons formals actuals)))
- (lambda (x) (cdr (assq (cadr x) r))))
- (cdr e))))
- (else `(map (lambda ,formals ,e) ,@actuals))))))
-
- (define gen-cons
- (lambda (x y)
- (case (car y)
- ((quote)
- (if (eq? (car x) 'quote)
- `(quote (,(cadr x) . ,(cadr y)))
- (if (eq? (cadr y) '())
- `(list ,x)
- `(cons ,x ,y))))
- ((list) `(list ,x ,@(cdr y)))
- (else `(cons ,x ,y)))))
-
- (define gen-append
- (lambda (x y)
- (if (equal? y '(quote ()))
- x
- `(append ,x ,y))))
-
- (define gen-vector
- (lambda (x)
- (cond
- ((eq? (car x) 'list) `(vector ,@(cdr x)))
- ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
- (else `(list->vector ,x)))))
-
-
- (define regen
- (lambda (x)
- (case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
- ((primitive) (build-primref no-source (cadr x)))
- ((quote) (build-data no-source (cadr x)))
- ((lambda)
- (if (list? (cadr x))
- (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
- (error "how did we get here" x)))
- (else (build-application no-source
- (build-primref no-source (car x))
- (map regen (cdr x)))))))
-
- (lambda (e r w s mod)
- (let ((e (source-wrap e w s mod)))
- (syntax-case e ()
- ((_ x)
+ (global-extend
+ 'core 'syntax
+ (let ()
+ (define gen-syntax
+ (lambda (src e r maps ellipsis? mod)
+ (if (id? e)
+ (call-with-values (lambda ()
+ (resolve-identifier e empty-wrap r mod #f))
+ (lambda (type value mod)
+ (case type
+ ((syntax)
+ (call-with-values
+ (lambda () (gen-ref src (car value) (cdr value) maps))
+ (lambda (var maps)
+ (values `(ref ,var) maps))))
+ (else
+ (if (ellipsis? e)
+ (syntax-violation 'syntax "misplaced ellipsis" src)
+ (values `(quote ,e) maps))))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? #'dots)
+ (gen-syntax src #'e r maps (lambda (x) #f) mod))
+ ((x dots . y)
+ ;; this could be about a dozen lines of code, except that we
+ ;; choose to handle #'(x ... ...) forms
+ (ellipsis? #'dots)
+ (let f ((y #'y)
+ (k (lambda (maps)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'x r
+ (cons '() maps) ellipsis? mod))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis"
+ src)
+ (values (gen-map x (car maps))
+ (cdr maps))))))))
+ (syntax-case y ()
+ ((dots . y)
+ (ellipsis? #'dots)
+ (f #'y
+ (lambda (maps)
(call-with-values
- (lambda () (gen-syntax e #'x r '() ellipsis? mod))
- (lambda (e maps) (regen e))))
- (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
+ (lambda () (k (cons '() maps)))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis" src)
+ (values (gen-mappend x (car maps))
+ (cdr maps))))))))
+ (_ (call-with-values
+ (lambda () (gen-syntax src y r maps ellipsis? mod))
+ (lambda (y maps)
+ (call-with-values
+ (lambda () (k maps))
+ (lambda (x maps)
+ (values (gen-append x y) maps)))))))))
+ ((x . y)
+ (call-with-values
+ (lambda () (gen-syntax src #'x r maps ellipsis? mod))
+ (lambda (x maps)
+ (call-with-values
+ (lambda () (gen-syntax src #'y r maps ellipsis? mod))
+ (lambda (y maps) (values (gen-cons x y) maps))))))
+ (#(e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
+ (lambda (e maps) (values (gen-vector e) maps))))
+ (_ (values `(quote ,e) maps))))))
+
+ (define gen-ref
+ (lambda (src var level maps)
+ (if (fx= level 0)
+ (values var maps)
+ (if (null? maps)
+ (syntax-violation 'syntax "missing ellipsis" src)
+ (call-with-values
+ (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
+ (lambda (outer-var outer-maps)
+ (let ((b (assq outer-var (car maps))))
+ (if b
+ (values (cdr b) maps)
+ (let ((inner-var (gen-var 'tmp)))
+ (values inner-var
+ (cons (cons (cons outer-var inner-var)
+ (car maps))
+ outer-maps)))))))))))
+
+ (define gen-mappend
+ (lambda (e map-env)
+ `(apply (primitive append) ,(gen-map e map-env))))
+
+ (define gen-map
+ (lambda (e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
+ (cond
+ ((eq? (car e) 'ref)
+ ;; identity map equivalence:
+ ;; (map (lambda (x) x) y) == y
+ (car actuals))
+ ((and-map
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+ (cdr e))
+ ;; eta map equivalence:
+ ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
+ `(map (primitive ,(car e))
+ ,@(map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e))))
+ (else `(map (lambda ,formals ,e) ,@actuals))))))
+
+ (define gen-cons
+ (lambda (x y)
+ (case (car y)
+ ((quote)
+ (if (eq? (car x) 'quote)
+ `(quote (,(cadr x) . ,(cadr y)))
+ (if (eq? (cadr y) '())
+ `(list ,x)
+ `(cons ,x ,y))))
+ ((list) `(list ,x ,@(cdr y)))
+ (else `(cons ,x ,y)))))
+
+ (define gen-append
+ (lambda (x y)
+ (if (equal? y '(quote ()))
+ x
+ `(append ,x ,y))))
+
+ (define gen-vector
+ (lambda (x)
+ (cond
+ ((eq? (car x) 'list) `(vector ,@(cdr x)))
+ ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
+ (else `(list->vector ,x)))))
+
+
+ (define regen
+ (lambda (x)
+ (case (car x)
+ ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
+ ((primitive) (build-primref no-source (cadr x)))
+ ((quote) (build-data no-source (cadr x)))
+ ((lambda)
+ (if (list? (cadr x))
+ (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
+ (error "how did we get here" x)))
+ (else (build-primcall no-source (car x) (map regen (cdr x)))))))
+
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
+ (syntax-case e ()
+ ((_ x)
+ (call-with-values
+ (lambda () (gen-syntax e #'x r '() ellipsis? mod))
+ (lambda (e maps) (regen e))))
+ (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
(global-extend 'core 'lambda
(lambda (e r w s mod)
@@ -2134,58 +2222,53 @@
(_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
- (global-extend 'core 'set!
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ id val)
- (id? #'id)
- (let ((n (id-var-name #'id w))
- ;; Lookup id in its module
- (id-mod (if (syntax-object? #'id)
- (syntax-object-module #'id)
- mod)))
- (let ((b (lookup n r id-mod)))
- (case (binding-type b)
- ((lexical)
- (build-lexical-assignment s
- (syntax->datum #'id)
- (binding-value b)
- (expand #'val r w mod)))
- ((global)
- (build-global-assignment s n (expand #'val r w mod) id-mod))
- ((macro)
- (let ((p (binding-value b)))
- (if (procedure-property p 'variable-transformer)
- ;; As syntax-type does, call expand-macro with
- ;; the mod of the expression. Hmm.
- (expand (expand-macro p e r w s #f mod) r empty-wrap mod)
- (syntax-violation 'set! "not a variable transformer"
- (wrap e w mod)
- (wrap #'id w id-mod)))))
- ((displaced-lexical)
- (syntax-violation 'set! "identifier out of context"
- (wrap #'id w mod)))
- (else (syntax-violation 'set! "bad set!"
- (source-wrap e w s mod)))))))
- ((_ (head tail ...) val)
- (call-with-values
- (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
- (lambda (type value ee ww ss modmod)
- (case type
- ((module-ref)
- (let ((val (expand #'val r w mod)))
- (call-with-values (lambda () (value #'(head tail ...) r w))
- (lambda (e r w s* mod)
- (syntax-case e ()
- (e (id? #'e)
- (build-global-assignment s (syntax->datum #'e)
- val mod)))))))
- (else
- (build-application s
- (expand #'(setter head) r w mod)
- (map (lambda (e) (expand e r w mod))
- #'(tail ... val))))))))
- (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
+ (global-extend
+ 'core 'set!
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ id val)
+ (id? #'id)
+ (call-with-values
+ (lambda () (resolve-identifier #'id w r mod #t))
+ (lambda (type value id-mod)
+ (case type
+ ((lexical)
+ (build-lexical-assignment s (syntax->datum #'id) value
+ (expand #'val r w mod)))
+ ((global)
+ (build-global-assignment s value (expand #'val r w mod) id-mod))
+ ((macro)
+ (if (procedure-property value 'variable-transformer)
+ ;; As syntax-type does, call expand-macro with
+ ;; the mod of the expression. Hmm.
+ (expand (expand-macro value e r w s #f mod) r empty-wrap mod)
+ (syntax-violation 'set! "not a variable transformer"
+ (wrap e w mod)
+ (wrap #'id w id-mod))))
+ ((displaced-lexical)
+ (syntax-violation 'set! "identifier out of context"
+ (wrap #'id w mod)))
+ (else
+ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))
+ ((_ (head tail ...) val)
+ (call-with-values
+ (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
+ (lambda (type value ee ww ss modmod)
+ (case type
+ ((module-ref)
+ (let ((val (expand #'val r w mod)))
+ (call-with-values (lambda () (value #'(head tail ...) r w))
+ (lambda (e r w s* mod)
+ (syntax-case e ()
+ (e (id? #'e)
+ (build-global-assignment s (syntax->datum #'e)
+ val mod)))))))
+ (else
+ (build-call s
+ (expand #'(setter head) r w mod)
+ (map (lambda (e) (expand e r w mod))
+ #'(tail ... val))))))))
+ (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@
(lambda (e r w)
@@ -2334,20 +2417,21 @@
(lambda (pvars exp y r mod)
(let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
- (build-application no-source
- (build-primref no-source 'apply)
- (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
- (expand exp
- (extend-env
- labels
- (map (lambda (var level)
- (make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr pvars))
- r)
- (make-binding-wrap ids labels empty-wrap)
- mod))
- y))))))
+ (build-primcall
+ no-source
+ 'apply
+ (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
+ (expand exp
+ (extend-env
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax `(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels empty-wrap)
+ mod))
+ y))))))
(define gen-clause
(lambda (x keys clauses r pat fender exp mod)
@@ -2362,36 +2446,32 @@
(else
(let ((y (gen-var 'tmp)))
;; fat finger binding and references to temp variable y
- (build-application no-source
- (build-simple-lambda no-source (list 'tmp) #f (list y) '()
- (let ((y (build-lexical-reference 'value no-source
- 'tmp y)))
- (build-conditional no-source
- (syntax-case fender ()
- (#t y)
- (_ (build-conditional no-source
- y
- (build-dispatch-call pvars fender y r mod)
- (build-data no-source #f))))
- (build-dispatch-call pvars exp y r mod)
- (gen-syntax-case x keys clauses r mod))))
- (list (if (eq? p 'any)
- (build-application no-source
- (build-primref no-source 'list)
- (list x))
- (build-application no-source
- (build-primref no-source '$sc-dispatch)
- (list x (build-data no-source p)))))))))))))
+ (build-call no-source
+ (build-simple-lambda no-source (list 'tmp) #f (list y) '()
+ (let ((y (build-lexical-reference 'value no-source
+ 'tmp y)))
+ (build-conditional no-source
+ (syntax-case fender ()
+ (#t y)
+ (_ (build-conditional no-source
+ y
+ (build-dispatch-call pvars fender y r mod)
+ (build-data no-source #f))))
+ (build-dispatch-call pvars exp y r mod)
+ (gen-syntax-case x keys clauses r mod))))
+ (list (if (eq? p 'any)
+ (build-primcall no-source 'list (list x))
+ (build-primcall no-source '$sc-dispatch
+ (list x (build-data no-source p)))))))))))))
(define gen-syntax-case
(lambda (x keys clauses r mod)
(if (null? clauses)
- (build-application no-source
- (build-primref no-source 'syntax-violation)
- (list (build-data no-source #f)
- (build-data no-source
- "source expression failed to match any pattern")
- x))
+ (build-primcall no-source 'syntax-violation
+ (list (build-data no-source #f)
+ (build-data no-source
+ "source expression failed to match any pattern")
+ x))
(syntax-case (car clauses) ()
((pat exp)
(if (and (id? #'pat)
@@ -2401,18 +2481,18 @@
(expand #'exp r empty-wrap mod)
(let ((labels (list (gen-label)))
(var (gen-var #'pat)))
- (build-application no-source
- (build-simple-lambda
- no-source (list (syntax->datum #'pat)) #f (list var)
- '()
- (expand #'exp
- (extend-env labels
- (list (make-binding 'syntax `(,var . 0)))
- r)
- (make-binding-wrap #'(pat)
- labels empty-wrap)
- mod))
- (list x))))
+ (build-call no-source
+ (build-simple-lambda
+ no-source (list (syntax->datum #'pat)) #f (list var)
+ '()
+ (expand #'exp
+ (extend-env labels
+ (list (make-binding 'syntax `(,var . 0)))
+ r)
+ (make-binding-wrap #'(pat)
+ labels empty-wrap)
+ mod))
+ (list x))))
(gen-clause x keys (cdr clauses) r
#'pat #t #'exp mod)))
((pat fender exp)
@@ -2429,14 +2509,14 @@
#'(key ...))
(let ((x (gen-var 'tmp)))
;; fat finger binding and references to temp variable x
- (build-application s
- (build-simple-lambda no-source (list 'tmp) #f (list x) '()
- (gen-syntax-case (build-lexical-reference 'value no-source
- 'tmp x)
- #'(key ...) #'(m ...)
- r
- mod))
- (list (expand #'val r empty-wrap mod))))
+ (build-call s
+ (build-simple-lambda no-source (list 'tmp) #f (list x) '()
+ (gen-syntax-case (build-lexical-reference 'value no-source
+ 'tmp x)
+ #'(key ...) #'(m ...)
+ r
+ mod))
+ (list (expand #'val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e))))))))
;; The portable macroexpand seeds expand-top's mode m with 'e (for
@@ -2488,7 +2568,10 @@
(syntax-object-expression id)
(strip-anti-mark (syntax-object-wrap id))
r
- (syntax-object-module id)))
+ (syntax-object-module id)
+ ;; FIXME: come up with a better policy for
+ ;; resolve-syntax-parameters
+ #t))
(lambda (type value mod)
(case type
((lexical) (values 'lexical value))
@@ -2711,7 +2794,7 @@
#((macro-type . syntax-rules)
(patterns pattern ...))
(syntax-case x (k ...)
- ((dummy . pattern) #'template)
+ ((_ . pattern) #'template)
...)))
((_ (k ...) docstring ((keyword . pattern) template) ...)
(string? (syntax->datum #'docstring))
@@ -2721,7 +2804,7 @@
#((macro-type . syntax-rules)
(patterns pattern ...))
(syntax-case x (k ...)
- ((dummy . pattern) #'template)
+ ((_ . pattern) #'template)
...))))))
(define-syntax define-syntax-rule
diff --git a/module/ice-9/weak-vector.scm b/module/ice-9/weak-vector.scm
index 09e2e0a8d..31d79ec6f 100644
--- a/module/ice-9/weak-vector.scm
+++ b/module/ice-9/weak-vector.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,13 +19,8 @@
(define-module (ice-9 weak-vector)
- :export (make-weak-vector list->weak-vector weak-vector weak-vector?
- make-weak-key-alist-vector
- make-weak-value-alist-vector
- make-doubly-weak-alist-vector
- weak-key-alist-vector?
- weak-value-alist-vector?
- doubly-weak-alist-vector?) ; C
- )
+ #:export (make-weak-vector list->weak-vector weak-vector weak-vector?))
-(%init-weaks-builtins) ; defined in libguile/weaks.c
+(eval-when (load eval compile)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_weak_vector_builtins"))
diff --git a/module/language/brainfuck/compile-tree-il.scm b/module/language/brainfuck/compile-tree-il.scm
index 33d563490..f9dd036e8 100644
--- a/module/language/brainfuck/compile-tree-il.scm
+++ b/module/language/brainfuck/compile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Brainfuck for GNU Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -94,7 +94,7 @@
(parse-tree-il
`(let (pointer tape) (pointer tape)
((const 0)
- (apply (primitive make-vector) (const ,tape-size) (const 0)))
+ (call (primitive make-vector) (const ,tape-size) (const 0)))
,(compile-body exp)))
env
env))
@@ -109,11 +109,11 @@
(cond
((null? in)
;; No more input, build our output.
- (cond
- ((null? out) '(void)) ; no output
- ((null? (cdr out)) (car out)) ; single expression
- (else `(begin ,@(reverse out)))) ; sequence
- )
+ (cond
+ ((null? out) '(void)) ; no output
+ ((null? (cdr out)) (car out)) ; single expression
+ (else `(begin ,@(reverse out)))) ; sequence
+ )
(else
(pmatch (car in)
@@ -121,34 +121,34 @@
;; (set! pointer (+ pointer +-1))
((<bf-move> ,dir)
(emit `(set! (lexical pointer)
- (apply (primitive +) (lexical pointer) (const ,dir)))))
+ (call (primitive +) (lexical pointer) (const ,dir)))))
;; Cell increment +- is done as:
;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
((<bf-increment> ,inc)
- (emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer)
- (apply (primitive +)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const ,inc)))))
+ (emit `(call (primitive vector-set!) (lexical tape) (lexical pointer)
+ (call (primitive +)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const ,inc)))))
;; Output . is done by converting the cell's integer value to a
;; character first and then printing out this character:
;; (write-char (integer->char (vector-ref tape pointer)))
((<bf-print>)
- (emit `(apply (primitive write-char)
- (apply (primitive integer->char)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))))))
+ (emit `(call (primitive write-char)
+ (call (primitive integer->char)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))))))
;; Input , is done similarly, read in a character, get its ASCII
;; code and store it into the current cell:
;; (vector-set! tape pointer (char->integer (read-char)))
((<bf-read>)
- (emit `(apply (primitive vector-set!)
- (lexical tape) (lexical pointer)
- (apply (primitive char->integer)
- (apply (primitive read-char))))))
+ (emit `(call (primitive vector-set!)
+ (lexical tape) (lexical pointer)
+ (call (primitive char->integer)
+ (call (primitive read-char))))))
;; For loops [...] we use a letrec construction to execute the body until
;; the current cell gets zero. The body is compiled via a recursive call
@@ -171,14 +171,14 @@
((lambda ()
(lambda-case
((() #f #f #f () ())
- (if (apply (primitive =)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const 0))
+ (if (call (primitive =)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const 0))
(void)
(begin ,(compile-body body)
- (apply (lexical ,iterate)))))
+ (call (lexical ,iterate)))))
#f)))
- (apply (lexical ,iterate))))))
+ (call (lexical ,iterate))))))
(else (error "unknown brainfuck instruction" (car in))))))))
diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
index a2401f442..0914f920a 100644
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -32,7 +32,7 @@
(-> (@ '(language ecmascript impl) 'sym)))
(define-syntax-rule (@impl sym arg ...)
- (-> (apply (@implv sym) arg ...)))
+ (-> (call (@implv sym) arg ...)))
(define (empty-lexical-environment)
'())
@@ -95,23 +95,23 @@
(this
(@impl get-this))
((+ ,a)
- (-> (apply (-> (primitive '+))
- (@impl ->number (comp a e))
- (-> (const 0)))))
+ (-> (call (-> (primitive '+))
+ (@impl ->number (comp a e))
+ (-> (const 0)))))
((- ,a)
- (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
+ (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
((~ ,a)
(@impl bitwise-not (comp a e)))
((! ,a)
(@impl logical-not (comp a e)))
((+ ,a ,b)
- (-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
((- ,a ,b)
- (-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
((/ ,a ,b)
- (-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
((* ,a ,b)
- (-> (apply (-> (primitive '*)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
((% ,a ,b)
(@impl mod (comp a e) (comp b e)))
((<< ,a ,b)
@@ -119,27 +119,27 @@
((>> ,a ,b)
(@impl shift (comp a e) (comp `(- ,b) e)))
((< ,a ,b)
- (-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
((<= ,a ,b)
- (-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
((> ,a ,b)
- (-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
((>= ,a ,b)
- (-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
((in ,a ,b)
(@impl has-property? (comp a e) (comp b e)))
((== ,a ,b)
- (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
((!= ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'equal?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'equal?))
+ (comp a e) (comp b e))))))
((=== ,a ,b)
- (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
((!== ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'eqv?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'eqv?))
+ (comp a e) (comp b e))))))
((& ,a ,b)
(@impl band (comp a e) (comp b e)))
((^ ,a ,b)
@@ -168,9 +168,9 @@
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set! (lookup foo e)
- (-> (apply (-> (primitive '+))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -181,9 +181,9 @@
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postinc (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -196,16 +196,16 @@
(@impl pput
(-> (lexical objvar objvar))
(-> (lexical propvar propvar))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
((postdec (ref ,foo))
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set (lookup foo e)
- (-> (apply (-> (primitive '-))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postdec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -216,9 +216,9 @@
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '-))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postdec (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
@@ -238,18 +238,18 @@
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '+))
- v
- (-> (const 1))))))
+ (-> (call (-> (primitive '+))
+ v
+ (-> (const 1))))))
v))))
((preinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput (-> (lexical objvar objvar))
(-> (const prop))
@@ -259,11 +259,11 @@
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
@@ -273,18 +273,18 @@
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '-))
+ (-> (call (-> (primitive '-))
v
(-> (const 1))))))
v))))
((predec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
@@ -295,11 +295,11 @@
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
@@ -337,7 +337,7 @@
(-> (lambda '()
`(lambda-case
((() #f #f #f () ())
- (apply ,(@impl pget obj prop) ,@args)))))))
+ (call ,(@impl pget obj prop) ,@args)))))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (const prop))
@@ -349,25 +349,25 @@
,@(map (lambda (x) (comp x e)) args))
e))
((call ,proc ,args)
- `(apply ,(comp proc e)
- ,@(map (lambda (x) (comp x e)) args)))
+ `(call ,(comp proc e)
+ ,@(map (lambda (x) (comp x e)) args)))
((return ,expr)
- (-> (apply (-> (primitive 'return))
- (comp expr e))))
+ (-> (call (-> (primitive 'return))
+ (comp expr e))))
((array . ,args)
- `(apply ,(@implv new-array)
- ,@(map (lambda (x) (comp x e)) args)))
+ `(call ,(@implv new-array)
+ ,@(map (lambda (x) (comp x e)) args)))
((object . ,args)
- `(apply ,(@implv new-object)
- ,@(map (lambda (x)
- (pmatch x
- ((,prop ,val)
- (-> (apply (-> (primitive 'cons))
- (-> (const prop))
- (comp val e))))
- (else
- (error "bad prop-val pair" x))))
- args)))
+ `(call ,(@implv new-object)
+ ,@(map (lambda (x)
+ (pmatch x
+ ((,prop ,val)
+ (-> (call (-> (primitive 'cons))
+ (-> (const prop))
+ (comp val e))))
+ (else
+ (error "bad prop-val pair" x))))
+ args)))
((pref ,obj ,prop)
(@impl pget
(comp obj e)
@@ -442,14 +442,14 @@
`((() #f #f #f () ())
,(-> (begin
(comp statement e)
- (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))))
(-> (lambda '()
(-> (lambda-case
`((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e))
- (-> (apply (-> (lexical '%loop %loop))))
+ (-> (call (-> (lexical '%loop %loop))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%loop %loop)))))))))
+ (-> (call (-> (lexical '%loop %loop)))))))))
((while ,test ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
@@ -459,9 +459,9 @@
`((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e))
(-> (begin (comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
((for ,init ,test ,inc ,statement)
(let ((%continue (gensym "%continue ")))
@@ -475,10 +475,10 @@
(comp 'true e))
(-> (begin (comp statement e)
(comp (or inc '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
(-> (begin (comp (or init '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))))
((for-in ,var ,object ,statement)
(let ((%enum (gensym "%enum "))
@@ -498,9 +498,9 @@
,(-> (const 'pop))))
e)
(comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
((block ,x)
(comp x e))
diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 0df21c7e6..e1d75ba7a 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
-;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011 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
@@ -109,7 +109,7 @@
;;; Build a call to a primitive procedure nicely.
(define (call-primitive loc sym . args)
- (make-application loc (make-primitive-ref loc sym) args))
+ (make-primcall loc sym args))
;;; Error reporting routine for syntax/compilation problems or build
;;; code for a runtime-error output.
@@ -118,9 +118,8 @@
(apply error args))
(define (runtime-error loc msg . args)
- (make-application loc
- (make-primitive-ref loc 'error)
- (cons (make-const loc msg) args)))
+ (make-primcall loc 'error
+ (cons (make-const loc msg) args)))
;;; Generate code to ensure a global symbol is there for further use of
;;; a given symbol. In general during the compilation, those needed are
@@ -129,13 +128,13 @@
;;; this routine.
(define (generate-ensure-global loc sym module)
- (make-application loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc module)
- (make-const loc sym))))
+ (make-call loc
+ (make-module-ref loc runtime 'ensure-fluid! #t)
+ (list (make-const loc module)
+ (make-const loc sym))))
(define (ensuring-globals loc bindings body)
- (make-sequence
+ (list->seq
loc
`(,@(map-globals-needed (fluid-ref bindings)
(lambda (mod sym)
@@ -151,12 +150,11 @@
(call-primitive
loc
'with-fluids*
- (make-application loc
- (make-primitive-ref loc 'list)
- (map (lambda (sym)
- (make-module-ref loc module sym #t))
- syms))
- (make-application loc (make-primitive-ref loc 'list) vals)
+ (make-primcall loc 'list
+ (map (lambda (sym)
+ (make-module-ref loc module sym #t))
+ syms))
+ (make-primcall loc 'list vals)
(make-lambda loc
'()
(make-lambda-case #f '() #f #f #f '() '() body #f))))
@@ -204,7 +202,7 @@
sym
module
(lambda ()
- (make-application
+ (make-call
loc
(make-module-ref loc runtime 'set-variable! #t)
(list (make-const loc module) (make-const loc sym) value)))
@@ -288,7 +286,7 @@
(map (lambda (el) (compile-expr (cdr el)))
for)))
(make-body (lambda ()
- (make-sequence loc (map compile-expr body)))))
+ (list->seq loc (map compile-expr body)))))
(if (null? lexical)
(let-dynamic loc (map car dynamic) module
(make-values dynamic) (make-body))
@@ -332,7 +330,7 @@
(map car bind))
(let iterate ((tail bind))
(if (null? tail)
- (make-sequence loc (map compile-expr body))
+ (list->seq loc (map compile-expr body))
(let ((sym (caar tail))
(value (compile-expr (cdar tail))))
(if (bind-lexically? sym module)
@@ -502,36 +500,35 @@
(map (lambda (x) (nil-value loc)) optional)
all-syms
(let ((compiled-body
- (make-sequence loc (map compile-expr body))))
- (make-sequence
+ (list->seq loc (map compile-expr body))))
+ (make-seq
loc
- (list
- (if rest
- (make-conditional
- loc
- (call-primitive loc
- 'null?
- (make-lexical-ref loc
- rest
- the-rest-sym))
- (make-lexical-set loc
- rest
- the-rest-sym
- (nil-value loc))
- (make-void loc))
+ (if rest
+ (make-conditional
+ loc
+ (call-primitive loc
+ 'null?
+ (make-lexical-ref loc
+ rest
+ the-rest-sym))
+ (make-lexical-set loc
+ rest
+ the-rest-sym
+ (nil-value loc))
(make-void loc))
- (if (null? dynamic)
- compiled-body
- (let-dynamic loc
- dynamic
- value-slot
- (map (lambda (name-sym)
- (make-lexical-ref
- loc
- (car name-sym)
- (cdr name-sym)))
- all-dyn-pairs)
- compiled-body)))))
+ (make-void loc))
+ (if (null? dynamic)
+ compiled-body
+ (let-dynamic loc
+ dynamic
+ value-slot
+ (map (lambda (name-sym)
+ (make-lexical-ref
+ loc
+ (car name-sym)
+ (cdr name-sym)))
+ all-dyn-pairs)
+ compiled-body))))
#f)))))))))
;;; Handle the common part of defconst and defvar, that is, checking for
@@ -623,7 +620,7 @@
(report-error loc "invalid symbol list" syms))
(let ((old (fluid-ref fluid))
(make-body (lambda ()
- (make-sequence loc (map compile-expr body)))))
+ (list->seq loc (map compile-expr body)))))
(if (eq? old 'all)
(make-body)
(let ((new (if (eq? syms 'all)
@@ -635,7 +632,7 @@
;;; Special operators
(defspecial progn (loc args)
- (make-sequence loc (map compile-expr args)))
+ (list->seq loc (map compile-expr args)))
(defspecial if (loc args)
(pmatch args
@@ -645,53 +642,51 @@
(compile-expr then)
(if (null? else)
(nil-value loc)
- (make-sequence loc
- (map compile-expr else)))))))
+ (list->seq loc (map compile-expr else)))))))
(defspecial defconst (loc args)
(pmatch args
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence loc
- (list (set-variable! loc
- sym
- value-slot
- (compile-expr value))
- (make-const loc sym)))))))
+ (make-seq loc
+ (set-variable! loc
+ sym
+ value-slot
+ (compile-expr value))
+ (make-const loc sym))))))
(defspecial defvar (loc args)
(pmatch args
((,sym) (make-const loc sym))
((,sym ,value . ,doc)
(if (handle-var-def loc sym doc)
- (make-sequence
+ (make-seq
loc
- (list
+ (make-conditional
+ loc
(make-conditional
loc
- (make-conditional
+ (call-primitive
loc
- (call-primitive
- loc
- 'module-bound?
- (call-primitive loc
- 'resolve-interface
- (make-const loc value-slot))
- (make-const loc sym))
+ 'module-bound?
(call-primitive loc
- 'fluid-bound?
- (make-module-ref loc value-slot sym #t))
- (make-const loc #f))
- (make-void loc)
- (set-variable! loc sym value-slot (compile-expr value)))
- (make-const loc sym)))))))
+ 'resolve-interface
+ (make-const loc value-slot))
+ (make-const loc sym))
+ (call-primitive loc
+ 'fluid-bound?
+ (make-module-ref loc value-slot sym #t))
+ (make-const loc #f))
+ (make-void loc)
+ (set-variable! loc sym value-slot (compile-expr value)))
+ (make-const loc sym))))))
(defspecial setq (loc args)
(define (car* x) (if (null? x) '() (car x)))
(define (cdr* x) (if (null? x) '() (cdr x)))
(define (cadr* x) (car* (cdr* x)))
(define (cddr* x) (cdr* (cdr* x)))
- (make-sequence
+ (list->seq
loc
(let loop ((args args) (last (nil-value loc)))
(if (null? args)
@@ -779,13 +774,12 @@
((,condition . ,body)
(let* ((itersym (gensym))
(compiled-body (map compile-expr body))
- (iter-call (make-application loc
- (make-lexical-ref loc
- 'iterate
- itersym)
- (list)))
- (full-body (make-sequence loc
- `(,@compiled-body ,iter-call)))
+ (iter-call (make-call loc
+ (make-lexical-ref loc
+ 'iterate
+ itersym)
+ (list)))
+ (full-body (list->seq loc `(,@compiled-body ,iter-call)))
(lambda-body (make-conditional loc
(compile-expr condition)
full-body
@@ -821,19 +815,16 @@
(if (not (symbol? name))
(report-error loc "expected symbol as macro name" name)
(let* ((tree-il
- (make-sequence
+ (make-seq
loc
- (list
- (set-variable!
- loc
- name
- function-slot
- (make-application
- loc
- (make-module-ref loc '(guile) 'cons #t)
- (list (make-const loc 'macro)
- (compile-lambda loc args body))))
- (make-const loc name)))))
+ (set-variable!
+ loc
+ name
+ function-slot
+ (make-primcall loc 'cons
+ (list (make-const loc 'macro)
+ (compile-lambda loc args body))))
+ (make-const loc name))))
(compile (ensuring-globals loc bindings-data tree-il)
#:from 'tree-il
#:to 'value)
@@ -844,14 +835,14 @@
((,name ,args . ,body)
(if (not (symbol? name))
(report-error loc "expected symbol as function name" name)
- (make-sequence loc
- (list (set-variable! loc
- name
- function-slot
- (compile-lambda loc
- args
- body))
- (make-const loc name)))))))
+ (make-seq loc
+ (set-variable! loc
+ name
+ function-slot
+ (compile-lambda loc
+ args
+ body))
+ (make-const loc name))))))
(defspecial #{`}# (loc args)
(pmatch args
@@ -876,13 +867,13 @@
=> (lambda (macro-function)
(compile-expr (apply macro-function arguments))))
(else
- (make-application loc
- (if (symbol? operator)
- (reference-variable loc
- operator
- function-slot)
- (compile-expr operator))
- (map compile-expr arguments))))))
+ (make-call loc
+ (if (symbol? operator)
+ (reference-variable loc
+ operator
+ function-slot)
+ (compile-expr operator))
+ (map compile-expr arguments))))))
;;; Compile a symbol expression. This is a variable reference or maybe
;;; some special value like nil.
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1d391c4e1..69af8d65a 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -34,8 +34,9 @@
<toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
<toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
<conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
- <application> application? make-application application-src application-proc application-args
- <sequence> sequence? make-sequence sequence-src sequence-exps
+ <call> call? make-call call-src call-proc call-args
+ <primcall> primcall? make-primcall primcall-src primcall-name primcall-args
+ <seq> seq? make-seq seq-head seq-tail
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src
lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
@@ -45,13 +46,15 @@
<letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
- <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
+ <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-pre dynwind-body dynwind-post dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
<dynref> dynref? make-dynref dynref-src dynref-fluid
<dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
+ list->seq
+
parse-tree-il
unparse-tree-il
tree-il->scheme
@@ -118,8 +121,9 @@
;; (<toplevel-set> name exp)
;; (<toplevel-define> name exp)
;; (<conditional> test consequent alternate)
- ;; (<application> proc args)
- ;; (<sequence> exps)
+ ;; (<call> proc args)
+ ;; (<primcall> name args)
+ ;; (<seq> head tail)
;; (<lambda> meta body)
;; (<lambda-case> req opt rest kw inits gensyms body alternate)
;; (<let> names gensyms vals body)
@@ -129,7 +133,7 @@
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
(<let-values> exp body)
- (<dynwind> winder body unwinder)
+ (<dynwind> winder pre body post unwinder)
(<dynref> fluid)
(<dynset> fluid exp)
(<prompt> tag body handler)
@@ -137,6 +141,14 @@
+;; A helper.
+(define (list->seq loc exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (make-seq loc (car exps) (list->seq #f (cdr exps)))))
+
+
+
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
@@ -149,8 +161,11 @@
((void)
(make-void loc))
- ((apply ,proc . ,args)
- (make-application loc (retrans proc) (map retrans args)))
+ ((call ,proc . ,args)
+ (make-call loc (retrans proc) (map retrans args)))
+
+ ((primcall ,name . ,args)
+ (make-primcall loc name (map retrans args)))
((if ,test ,consequent ,alternate)
(make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
@@ -209,8 +224,12 @@
((const ,exp)
(make-const loc exp))
+ ((seq ,head ,tail)
+ (make-seq loc (retrans head) (retrans tail)))
+
+ ;; Convenience.
((begin . ,exps)
- (make-sequence loc (map retrans exps)))
+ (list->seq loc (map retrans exps)))
((let ,names ,gensyms ,vals ,body)
(make-let loc names gensyms (map retrans vals) (retrans body)))
@@ -227,8 +246,10 @@
((let-values ,exp ,body)
(make-let-values loc (retrans exp) (retrans body)))
- ((dynwind ,winder ,body ,unwinder)
- (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
+ ((dynwind ,winder ,pre ,body ,post ,unwinder)
+ (make-dynwind loc (retrans winder) (retrans pre)
+ (retrans body)
+ (retrans post) (retrans unwinder)))
((dynlet ,fluids ,vals ,body)
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
@@ -253,8 +274,11 @@
((<void>)
'(void))
- ((<application> proc args)
- `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+ ((<call> proc args)
+ `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
+
+ ((<primcall> name args)
+ `(primcall ,name ,@(map unparse-tree-il args)))
((<conditional> test consequent alternate)
`(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
@@ -294,9 +318,9 @@
((<const> exp)
`(const ,exp))
- ((<sequence> exps)
- `(begin ,@(map unparse-tree-il exps)))
-
+ ((<seq> head tail)
+ `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail)))
+
((<let> names gensyms vals body)
`(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
@@ -310,9 +334,10 @@
((<let-values> exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- ((<dynwind> winder body unwinder)
- `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
- ,(unparse-tree-il unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il pre)
+ ,(unparse-tree-il body)
+ ,(unparse-tree-il post) ,(unparse-tree-il unwinder)))
((<dynlet> fluids vals body)
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
@@ -336,9 +361,12 @@
((<void>)
'(if #f #f))
- ((<application> proc args)
+ ((<call> proc args)
`(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
+ ((<primcall> name args)
+ `(,name ,@(map tree-il->scheme args)))
+
((<conditional> test consequent alternate)
(if (void? alternate)
`(if ,(tree-il->scheme test) ,(tree-il->scheme consequent))
@@ -433,8 +461,14 @@
exp
(list 'quote exp)))
- ((<sequence> exps)
- `(begin ,@(map tree-il->scheme exps)))
+ ((<seq> head tail)
+ `(begin ,(tree-il->scheme head)
+ ,@(unfold (lambda (x) (not (seq? x)))
+ (lambda (x) (tree-il->scheme (seq-head x)))
+ seq-tail
+ tail
+ (lambda (x)
+ (list (tree-il->scheme x))))))
((<let> gensyms vals body)
`(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
@@ -453,7 +487,7 @@
`(call-with-values (lambda () ,(tree-il->scheme exp))
,(tree-il->scheme (make-lambda #f '() body))))
- ((<dynwind> body winder unwinder)
+ ((<dynwind> winder body unwinder)
`(dynamic-wind ,(tree-il->scheme winder)
(lambda () ,(tree-il->scheme body))
,(tree-il->scheme unwinder)))
@@ -478,7 +512,8 @@
((<abort> tag args tail)
- `(apply abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args)
+ `(apply abort-to-prompt
+ ,(tree-il->scheme tag) ,@(map tree-il->scheme args)
,(tree-il->scheme tail)))))
@@ -489,7 +524,7 @@ invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
and SEED is the current result, intially seeded with SEED.
This is an implementation of `foldts' as described by Andy Wingo in
-``Applications of fold to XML transformation''."
+``Calls of fold to XML transformation''."
(let loop ((tree tree)
(result seed))
(if (or (null? tree) (pair? tree))
@@ -507,10 +542,12 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop alternate
(loop consequent
(loop test (down tree result))))))
- ((<application> proc args)
+ ((<call> proc args)
(up tree (loop (cons proc args) (down tree result))))
- ((<sequence> exps)
- (up tree (loop exps (down tree result))))
+ ((<primcall> name args)
+ (up tree (loop args (down tree result))))
+ ((<seq> head tail)
+ (up tree (loop tail (loop head (down tree result)))))
((<lambda> body)
(up tree (loop body (down tree result))))
((<lambda-case> inits body alternate)
@@ -532,10 +569,13 @@ This is an implementation of `foldts' as described by Andy Wingo in
(down tree result)))))
((<let-values> exp body)
(up tree (loop body (loop exp (down tree result)))))
- ((<dynwind> body winder unwinder)
+ ((<dynwind> winder pre body post unwinder)
(up tree (loop unwinder
- (loop winder
- (loop body (down tree result))))))
+ (loop post
+ (loop body
+ (loop pre
+ (loop winder
+ (down tree result))))))))
((<dynlet> fluids vals body)
(up tree (loop body
(loop vals
@@ -578,11 +618,14 @@ This is an implementation of `foldts' as described by Andy Wingo in
(let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...)))
- ((<application> proc args)
+ ((<call> proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
- ((<sequence> exps)
- (fold-values foldts exps seed ...))
+ ((<primcall> name args)
+ (fold-values foldts args seed ...))
+ ((<seq> head tail)
+ (let-values (((seed ...) (foldts head seed ...)))
+ (foldts tail seed ...)))
((<lambda> body)
(foldts body seed ...))
((<lambda-case> inits body alternate)
@@ -603,9 +646,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
((<let-values> exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
- ((<dynwind> body winder unwinder)
- (let*-values (((seed ...) (foldts body seed ...))
- ((seed ...) (foldts winder seed ...)))
+ ((<dynwind> winder pre body post unwinder)
+ (let*-values (((seed ...) (foldts winder seed ...))
+ ((seed ...) (foldts pre seed ...))
+ ((seed ...) (foldts body seed ...))
+ ((seed ...) (foldts post seed ...)))
(foldts unwinder seed ...)))
((<dynlet> fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
@@ -631,9 +676,12 @@ This is an implementation of `foldts' as described by Andy Wingo in
(define (post-order! f x)
(let lp ((x x))
(record-case x
- ((<application> proc args)
- (set! (application-proc x) (lp proc))
- (set! (application-args x) (map lp args)))
+ ((<call> proc args)
+ (set! (call-proc x) (lp proc))
+ (set! (call-args x) (map lp args)))
+
+ ((<primcall> name args)
+ (set! (primcall-args x) (map lp args)))
((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test))
@@ -661,9 +709,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(if alternate
(set! (lambda-case-alternate x) (lp alternate))))
- ((<sequence> exps)
- (set! (sequence-exps x) (map lp exps)))
-
+ ((<seq> head tail)
+ (set! (seq-head x) (lp head))
+ (set! (seq-tail x) (lp tail)))
+
((<let> gensyms vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
@@ -680,9 +729,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
+ ((<dynwind> winder pre body post unwinder)
(set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-pre x) (lp pre))
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-post x) (lp post))
(set! (dynwind-unwinder x) (lp unwinder)))
((<dynlet> fluids vals body)
@@ -715,9 +766,12 @@ This is an implementation of `foldts' as described by Andy Wingo in
(let lp ((x x))
(let ((x (or (f x) x)))
(record-case x
- ((<application> proc args)
- (set! (application-proc x) (lp proc))
- (set! (application-args x) (map lp args)))
+ ((<call> proc args)
+ (set! (call-proc x) (lp proc))
+ (set! (call-args x) (map lp args)))
+
+ ((<primcall> name args)
+ (set! (primcall-args x) (map lp args)))
((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test))
@@ -744,9 +798,10 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (lambda-case-body x) (lp body))
(if alternate (set! (lambda-case-alternate x) (lp alternate))))
- ((<sequence> exps)
- (set! (sequence-exps x) (map lp exps)))
-
+ ((<seq> head tail)
+ (set! (seq-head x) (lp head))
+ (set! (seq-tail x) (lp tail)))
+
((<let> vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
@@ -763,9 +818,11 @@ This is an implementation of `foldts' as described by Andy Wingo in
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
+ ((<dynwind> winder pre body post unwinder)
(set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-pre x) (lp pre))
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-post x) (lp post))
(set! (dynwind-unwinder x) (lp unwinder)))
((<dynlet> fluids vals body)
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 047019049..f75c9f16a 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -179,10 +179,13 @@
(analyze! x new-proc (append labels labels-in-proc) #t #f))
(define (recur x new-proc) (analyze! x new-proc '() tail? #f))
(record-case x
- ((<application> proc args)
+ ((<call> proc args)
(apply lset-union eq? (step-tail-call proc args)
(map step args)))
+ ((<primcall> args)
+ (apply lset-union eq? (map step args)))
+
((<conditional> test consequent alternate)
(lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))
@@ -221,13 +224,8 @@
((<toplevel-define> exp)
(step exp))
- ((<sequence> exps)
- (let lp ((exps exps) (ret '()))
- (cond ((null? exps) '())
- ((null? (cdr exps))
- (lset-union eq? ret (step-tail (car exps))))
- (else
- (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
+ ((<seq> head tail)
+ (lset-union eq? (step head) (step-tail tail)))
((<lambda> body)
;; order is important here
@@ -338,8 +336,10 @@
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
- ((<dynwind> body winder unwinder)
- (lset-union eq? (step body) (step winder) (step unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (lset-union eq? (step winder) (step pre)
+ (step body)
+ (step post) (step unwinder)))
((<dynlet> fluids vals body)
(apply lset-union eq? (step body) (map step (append fluids vals))))
@@ -366,9 +366,12 @@
(define (allocate! x proc n)
(define (recur y) (allocate! y proc n))
(record-case x
- ((<application> proc args)
+ ((<call> proc args)
(apply max (recur proc) (map recur args)))
+ ((<primcall> args)
+ (apply max n (map recur args)))
+
((<conditional> test consequent alternate)
(max (recur test) (recur consequent) (recur alternate)))
@@ -384,8 +387,9 @@
((<toplevel-define> exp)
(recur exp))
- ((<sequence> exps)
- (apply max (map recur exps)))
+ ((<seq> head tail)
+ (max (recur head)
+ (recur tail)))
((<lambda> body)
;; allocate closure vars in order
@@ -508,8 +512,10 @@
((<let-values> exp body)
(max (recur exp) (recur body)))
- ((<dynwind> body winder unwinder)
- (max (recur body) (recur winder) (recur unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (max (recur winder) (recur pre)
+ (recur body)
+ (recur post) (recur unwinder)))
((<dynlet> fluids vals body)
(apply max (recur body) (map recur (append fluids vals))))
@@ -865,7 +871,7 @@ accurate information is missing from a given `tree-il' element."
(defs toplevel-info-defs)) ;; (VARIABLE-NAME ...)
(define (goops-toplevel-definition proc args env)
- ;; If application of PROC to ARGS is a GOOPS top-level definition, return
+ ;; If call of PROC to ARGS is a GOOPS top-level definition, return
;; the name of the variable being defined; otherwise return #f. This
;; assumes knowledge of the current implementation of `define-class' et al.
(define (toplevel-define-arg args)
@@ -926,7 +932,7 @@ accurate information is missing from a given `tree-il' element."
(make-toplevel-info (vhash-delq name refs)
(vhash-consq name #t defs)))
- ((<application> proc args)
+ ((<call> proc args)
;; Check for a dynamic top-level definition, as is
;; done by code expanded from GOOPS macros.
(let ((name (goops-toplevel-definition proc args
@@ -964,12 +970,12 @@ accurate information is missing from a given `tree-il' element."
(define-record-type <arity-info>
(make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
arity-info?
- (toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
+ (toplevel-calls toplevel-procedure-calls) ;; ((NAME . CALL) ...)
(lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...)
(toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...)
-(define (validate-arity proc application lexical?)
- ;; Validate the argument count of APPLICATION, a tree-il application of
+(define (validate-arity proc call lexical?)
+ ;; Validate the argument count of CALL, a tree-il call of
;; PROC, emitting a warning in case of argument count mismatch.
(define (filter-keyword-args keywords allow-other-keys? args)
@@ -1029,8 +1035,8 @@ accurate information is missing from a given `tree-il' element."
(else
(values #f #f))))))))
- (let ((args (application-args application))
- (src (tree-il-src application)))
+ (let ((args (call-args call))
+ (src (tree-il-src call)))
(call-with-values (lambda () (arities proc))
(lambda (name arities)
(define matches?
@@ -1117,7 +1123,7 @@ accurate information is missing from a given `tree-il' element."
((<fix> gensyms vals)
(fold extend info gensyms vals))
- ((<application> proc args src)
+ ((<call> proc args src)
(record-case proc
((<lambda> body)
(validate-arity proc x #t)
@@ -1177,9 +1183,9 @@ accurate information is missing from a given `tree-il' element."
(let ((toplevel-calls (toplevel-procedure-calls result))
(toplevel-lambdas (toplevel-lambdas result)))
(vlist-for-each
- (lambda (name+application)
- (let* ((name (car name+application))
- (application (cdr name+application))
+ (lambda (name+call)
+ (let* ((name (car name+call))
+ (call (cdr name+call))
(proc
(or (and=> (vhash-assq name toplevel-lambdas) cdr)
(and (module? env)
@@ -1194,7 +1200,7 @@ accurate information is missing from a given `tree-il' element."
(module-ref env name))))
proc)))
(if (or (lambda? proc*) (procedure? proc*))
- (validate-arity proc* application (lambda? proc*)))))
+ (validate-arity proc* call (lambda? proc*)))))
toplevel-calls)))
(make-arity-info vlist-null vlist-null vlist-null)))
@@ -1345,7 +1351,7 @@ accurate information is missing from a given `tree-il' element."
(match x
(($ <const> _ exp)
exp)
- (($ <application> _
+ (($ <call> _
(or ($ <toplevel-ref> _ '_) ($ <module-ref> _ '_))
(($ <const> _ (and (? string?) fmt))))
;; Gettexted literals, like `(_ "foo")'.
@@ -1402,7 +1408,7 @@ accurate information is missing from a given `tree-il' element."
(false-if-exception (module-ref env name))))
(match x
- (($ <application> src ($ <toplevel-ref> _ name) args)
+ (($ <call> src ($ <toplevel-ref> _ name) args)
(let ((proc (resolve-toplevel name)))
(and (or (eq? proc format)
(eq? proc (@ (ice-9 format) format)))
diff --git a/module/language/tree-il/canonicalize.scm b/module/language/tree-il/canonicalize.scm
index 04f561282..27d72956f 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -36,16 +36,6 @@
(post-order!
(lambda (x)
(match x
- (($ <sequence> src (tail))
- tail)
- (($ <sequence> src exps)
- (and (any sequence? exps)
- (make-sequence src
- (append-map (lambda (x)
- (if (sequence? x)
- (sequence-exps x)
- (list x)))
- exps))))
(($ <let> src () () () body)
body)
(($ <letrec> src _ () () () body)
@@ -65,7 +55,7 @@
(else #f)))
(define (thunk-application? x)
(match x
- (($ <application> _
+ (($ <call> _
($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
()) #t)
(_ #f)))
@@ -73,7 +63,7 @@
(define thunk
(make-lambda #f '()
(make-lambda-case #f '() #f #f #f '() '() body #f)))
- (make-application #f thunk '()))
+ (make-call #f thunk '()))
;; This code has a nasty job to do: to ensure that either the
;; handler is escape-only, or the body is the application of a
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index de55026ab..31e9a70b5 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -115,6 +115,9 @@
((class-of . 1) . class-of)
((@slot-ref . 2) . slot-ref)
((@slot-set! . 3) . slot-set)
+ ((string-length . 1) . string-length)
+ ((string-ref . 2) . string-ref)
+ ((vector-length . 1) . vector-length)
((vector-ref . 2) . vector-ref)
((vector-set! . 3) . vector-set)
((variable-ref . 1) . variable-ref)
@@ -268,200 +271,12 @@
(emit-code src (make-glil-const exp))))
(maybe-emit-return))
- ;; FIXME: should represent sequence as exps tail
- ((<sequence> exps)
- (let lp ((exps exps))
- (if (null? (cdr exps))
- (comp-tail (car exps))
- (begin
- (comp-drop (car exps))
- (lp (cdr exps))))))
-
- ((<application> src proc args)
- ;; FIXME: need a better pattern-matcher here
+ ((<seq> head tail)
+ (comp-drop head)
+ (comp-tail tail))
+
+ ((<call> src proc args)
(cond
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@apply)
- (>= (length args) 1))
- (let ((proc (car args))
- (args (cdr args)))
- (cond
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)) (not (eq? context 'vals)))
- ;; tail: (lambda () (apply values '(1 2)))
- ;; drop: (lambda () (apply values '(1 2)) 3)
- ;; push: (lambda () (list (apply values '(10 12)) 1))
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((tail)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'return/values* (length args))))))
-
- (else
- (case context
- ((tail)
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
- ((push)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length args))))
- (maybe-emit-return))
- ((vals)
- (comp-vals
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args))
- MVRA)
- (maybe-emit-return))
- ((drop)
- ;; Well, shit. The proc might return any number of
- ;; values (including 0), since it's in a drop context,
- ;; yet apply does not create a MV continuation. So we
- ;; mv-call out to our trampoline instead.
- (comp-drop
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values))
- ;; tail: (lambda () (values '(1 2)))
- ;; drop: (lambda () (values '(1 2)) 3)
- ;; push: (lambda () (list (values '(10 12)) 1))
- ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((push)
- (case (length args)
- ((0)
- ;; FIXME: This is surely an error. We need to add a
- ;; values-mismatch warning pass.
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (emit-code src (make-glil-call 'call 0))
- (maybe-emit-return))
- ((1)
- (comp-push (car args)))
- (else
- ;; Taking advantage of unspecified order of evaluation of
- ;; arguments.
- (for-each comp-drop (cdr args))
- (comp-push (car args)))))
- ((vals)
- (for-each comp-push args)
- (emit-code #f (make-glil-const (length args)))
- (emit-branch src 'br MVRA))
- ((tail)
- (for-each comp-push args)
- (emit-code src (let ((len (length args)))
- (if (= len 1)
- (make-glil-call 'return 1)
- (make-glil-call 'return/values len)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-values)
- (= (length args) 2))
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (case context
- ((vals)
- ;; Fall back.
- (comp-vals
- (make-application src (make-primitive-ref #f 'call-with-values)
- args)
- MVRA)
- (maybe-emit-return))
- (else
- (let ((MV (make-label)) (POST (make-label))
- (producer (car args)) (consumer (cadr args)))
- (if (not (eq? context 'tail))
- (emit-code src (make-glil-call 'new-frame 0)))
- (comp-push consumer)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push producer)
- (emit-code src (make-glil-mv-call 0 MV))
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call 1)))
- (else (emit-code src (make-glil-call 'call 1))
- (emit-branch #f 'br POST)))
- (emit-label MV)
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
- (else (emit-code src (make-glil-call 'call/nargs 0))
- (emit-label POST)
- (if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-current-continuation)
- (= (length args) 1))
- (case context
- ((tail)
- (comp-push (car args))
- (emit-code src (make-glil-call 'tail-call/cc 1)))
- ((vals)
- (comp-vals
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args)
- MVRA)
- (maybe-emit-return))
- ((push)
- (comp-push (car args))
- (emit-code src (make-glil-call 'call/cc 1))
- (maybe-emit-return))
- ((drop)
- ;; Crap. Just like `apply' in drop context.
- (comp-drop
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args))
- (maybe-emit-return))))
-
- ;; A hack for variable-set, the opcode for which takes its args
- ;; reversed, relative to the variable-set! function
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) 'variable-set!)
- (= (length args) 2))
- (comp-push (cadr args))
- (comp-push (car args))
- (emit-code src (make-glil-call 'variable-set 2))
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((and (primitive-ref? proc)
- (or (hash-ref *primcall-ops*
- (cons (primitive-ref-name proc) (length args)))
- (hash-ref *primcall-ops* (primitive-ref-name proc))))
- => (lambda (op)
- (for-each comp-push args)
- (emit-code src (make-glil-call op (length args)))
- (case (instruction-pushes op)
- ((0)
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
- ((1)
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
- ((-1)
- ;; A control instruction, like return/values. Here we
- ;; just have to hope that the author of the tree-il
- ;; knew what they were doing.
- *unspecified*)
- (else
- (error "bad primitive op: too many pushes"
- op (instruction-pushes op))))))
-
;; call to the same lambda-case in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
@@ -543,6 +358,158 @@
(emit-branch #f 'br RA)
(emit-label POST)))))))))
+ ((<primcall> src name args)
+ (pmatch (cons name args)
+ ((@apply ,proc . ,args)
+ (cond
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)) (not (eq? context 'vals)))
+ ;; tail: (lambda () (apply values '(1 2)))
+ ;; drop: (lambda () (apply values '(1 2)) 3)
+ ;; push: (lambda () (list (apply values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values* (length args))))))
+
+ (else
+ (case context
+ ((tail)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
+ ((push)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'apply (1+ (length args))))
+ (maybe-emit-return))
+ (else
+ (comp-tail (make-primcall src 'apply (cons proc args))))))))
+
+ ((values . _)
+ ;; tail: (lambda () (values '(1 2)))
+ ;; drop: (lambda () (values '(1 2)) 3)
+ ;; push: (lambda () (list (values '(10 12)) 1))
+ ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((push)
+ (case (length args)
+ ((0)
+ ;; FIXME: This is surely an error. We need to add a
+ ;; values-mismatch warning pass.
+ (comp-push (make-call src (make-primitive-ref #f 'values)
+ '())))
+ ((1)
+ (comp-push (car args)))
+ (else
+ ;; Taking advantage of unspecified order of evaluation of
+ ;; arguments.
+ (for-each comp-drop (cdr args))
+ (comp-push (car args)))))
+ ((vals)
+ (for-each comp-push args)
+ (emit-code #f (make-glil-const (length args)))
+ (emit-branch src 'br MVRA))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (let ((len (length args)))
+ (if (= len 1)
+ (make-glil-call 'return 1)
+ (make-glil-call 'return/values len)))))))
+
+ ((@call-with-values ,producer ,consumer)
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (case context
+ ((vals)
+ ;; Fall back.
+ (comp-tail (make-primcall src 'call-with-values args)))
+ (else
+ (let ((MV (make-label)) (POST (make-label)))
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
+ (comp-push consumer)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push producer)
+ (emit-code src (make-glil-mv-call 0 MV))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call 1)))
+ (else (emit-code src (make-glil-call 'call 1))
+ (emit-branch #f 'br POST)))
+ (emit-label MV)
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
+ (else (emit-code src (make-glil-call 'call/nargs 0))
+ (emit-label POST)
+ (if (eq? context 'drop)
+ (emit-code #f (make-glil-call 'drop 1)))
+ (maybe-emit-return)))))))
+
+ ((@call-with-current-continuation ,proc)
+ (case context
+ ((tail)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'tail-call/cc 1)))
+ ((vals)
+ (comp-vals
+ (make-primcall src 'call-with-current-continuation args)
+ MVRA)
+ (maybe-emit-return))
+ ((push)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'call/cc 1))
+ (maybe-emit-return))
+ ((drop)
+ ;; Fall back.
+ (comp-tail
+ (make-primcall src 'call-with-current-continuation args)))))
+
+ ;; A hack for variable-set, the opcode for which takes its args
+ ;; reversed, relative to the variable-set! function
+ ((variable-set! ,var ,val)
+ (comp-push val)
+ (comp-push var)
+ (emit-code src (make-glil-call 'variable-set 2))
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ (else
+ (cond
+ ((or (hash-ref *primcall-ops* (cons name (length args)))
+ (hash-ref *primcall-ops* name))
+ => (lambda (op)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call op (length args)))
+ (case (instruction-pushes op)
+ ((0)
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+ ((1)
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
+ ((-1)
+ ;; A control instruction, like return/values. Here we
+ ;; just have to hope that the author of the tree-il
+ ;; knew what they were doing.
+ *unspecified*)
+ (else
+ (error "bad primitive op: too many pushes"
+ op (instruction-pushes op))))))
+ (else
+ ;; Fall back to the normal compilation strategy.
+ (comp-tail (make-call src (make-primitive-ref #f name) args)))))))
+
((<conditional> src test consequent alternate)
;; TEST
;; (br-if-not L1)
@@ -551,54 +518,33 @@
;; L1: alternate
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
- ;; need a pattern matcher
(record-case test
- ((<application> proc args)
- (record-case proc
- ((<primitive-ref> name)
- (let ((len (length args)))
- (cond
-
- ((and (eq? name 'eq?) (= len 2))
- (comp-push (car args))
- (comp-push (cadr args))
- (emit-branch src 'br-if-not-eq L1))
-
- ((and (eq? name 'null?) (= len 1))
- (comp-push (car args))
- (emit-branch src 'br-if-not-null L1))
-
- ((and (eq? name 'not) (= len 1))
- (let ((app (car args)))
- (record-case app
- ((<application> proc args)
- (let ((len (length args)))
- (record-case proc
- ((<primitive-ref> name)
- (cond
-
- ((and (eq? name 'eq?) (= len 2))
- (comp-push (car args))
- (comp-push (cadr args))
- (emit-branch src 'br-if-eq L1))
-
- ((and (eq? name 'null?) (= len 1))
- (comp-push (car args))
- (emit-branch src 'br-if-null L1))
-
- (else
- (comp-push app)
- (emit-branch src 'br-if L1))))
- (else
- (comp-push app)
- (emit-branch src 'br-if L1)))))
- (else
- (comp-push app)
- (emit-branch src 'br-if L1)))))
-
- (else
- (comp-push test)
- (emit-branch src 'br-if-not L1)))))
+ ((<primcall> name args)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-not-eq L1))
+ ((null? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-not-null L1))
+ ((not ,x)
+ (record-case x
+ ((<primcall> name args)
+ (pmatch (cons name args)
+ ((eq? ,a ,b)
+ (comp-push a)
+ (comp-push b)
+ (emit-branch src 'br-if-eq L1))
+ ((null? ,x)
+ (comp-push x)
+ (emit-branch src 'br-if-null L1))
+ (else
+ (comp-push x)
+ (emit-branch src 'br-if L1))))
+ (else
+ (comp-push x)
+ (emit-branch src 'br-if L1))))
(else
(comp-push test)
(emit-branch src 'br-if-not L1))))
@@ -975,10 +921,10 @@
;; to have body's return value(s) on the stack while the unwinder runs,
;; then proceed with returning or dropping or what-have-you, interacting
;; with RA and MVRA. What have you, I say.
- ((<dynwind> src body winder unwinder)
+ ((<dynwind> src winder pre body post unwinder)
(comp-push winder)
(comp-push unwinder)
- (comp-drop (make-application src winder '()))
+ (comp-drop pre)
(emit-code #f (make-glil-call 'wind 2))
(case context
@@ -987,14 +933,14 @@
(comp-vals body MV)
;; one value: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; ...and return the val
(emit-code #f (make-glil-call 'return 1))
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and return the values.
(emit-code #f (make-glil-call 'return/nvalues 1))))
@@ -1003,7 +949,7 @@
(comp-push body)
;; and unwind, leaving the val on the stack
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '())))
+ (comp-drop post))
((vals)
(let ((MV (make-label)))
@@ -1014,7 +960,7 @@
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and goto the MVRA.
(emit-branch #f 'br MVRA)))
@@ -1022,7 +968,7 @@
;; compile body, discarding values. then unwind...
(comp-drop body)
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and fall through, or goto RA if there is one.
(if RA
(emit-branch #f 'br RA)))))
diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm
index 78f132416..a32fc4153 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -215,9 +215,11 @@
(for-each (cut visit <> env) fluids)
(for-each (cut visit <> env) vals)
(visit body env))))
- (($ <dynwind> src winder body unwinder)
+ (($ <dynwind> src winder pre body post unwinder)
(visit winder env)
+ (visit pre env)
(visit body env)
+ (visit post env)
(visit unwinder env))
(($ <dynref> src fluid)
(visit fluid env))
@@ -228,21 +230,24 @@
(visit condition env)
(visit subsequent env)
(visit alternate env))
- (($ <application> src proc args)
+ (($ <primcall> src name args)
(cond
+ ((not (symbol? name))
+ (error "expected symbolic operator" exp))
((not (list? args))
(error "expected list of args" args))
(else
- (visit proc env)
(for-each (cut visit <> env) args))))
- (($ <sequence> src exps)
+ (($ <call> src proc args)
(cond
- ((not (list? exps))
- (error "expected list of exps" exp))
- ((null? exps)
- (error "expected more than one exp" exp))
+ ((not (list? args))
+ (error "expected list of args" args))
(else
- (for-each (cut visit <> env) exps))))
+ (visit proc env)
+ (for-each (cut visit <> env) args))))
+ (($ <seq> src head tail)
+ (visit head env)
+ (visit tail env))
(($ <prompt> src tag body handler)
(visit tag env)
(visit body env)
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index f387df193..f83d77e76 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -41,12 +41,11 @@
(and (simple-expression? test bound-vars simple-primitive?)
(simple-expression? consequent bound-vars simple-primitive?)
(simple-expression? alternate bound-vars simple-primitive?)))
- ((<sequence> exps)
- (and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
- exps))
- ((<application> proc args)
- (and (primitive-ref? proc)
- (simple-primitive? (primitive-ref-name proc))
+ ((<seq> head tail)
+ (and (simple-expression? head bound-vars simple-primitive?)
+ (simple-expression? tail bound-vars simple-primitive?)))
+ ((<primcall> name args)
+ (and (simple-primitive? name)
;; FIXME: check arity?
(and-map (lambda (x)
(simple-expression? x bound-vars simple-primitive?))
@@ -191,7 +190,7 @@
;; expression, called for effect.
((<lexical-set> gensym exp)
(if (memq gensym unref)
- (make-sequence #f (list exp (make-void #f)))
+ (make-seq #f exp (make-void #f))
x))
((<letrec> src in-order? names gensyms vals body)
@@ -219,7 +218,7 @@
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
- (make-sequence
+ (list->seq
src
(append
;; The right-hand-sides of the unreferenced
@@ -246,7 +245,7 @@
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
- (make-sequence
+ (list->seq
#f
(map (lambda (x tmp)
(make-lexical-set
@@ -263,7 +262,7 @@
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
- (make-sequence
+ (list->seq
src
(append
;; unreferenced bindings, called for effect.
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index a6bb954e2..1a355a030 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1,6 +1,6 @@
;;; Tree-IL partial evaluator
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; 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
@@ -108,9 +108,8 @@
(($ <primitive-ref>) #t)
(($ <module-ref>) #t)
(($ <toplevel-ref>) #t)
- (($ <application> _
- ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
- (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+ (($ <primcall> _ (? singly-valued-primitive?)) #t)
+ (($ <primcall> _ 'values (val)) #t)
(($ <lambda>) #t)
(else #f)))
@@ -118,9 +117,7 @@
"Discard all but the first value of X."
(if (singly-valued-expression? x)
x
- (make-application (tree-il-src x)
- (make-primitive-ref #f 'values)
- (list x))))
+ (make-primcall (tree-il-src x) 'values (list x))))
;; Peval will do a one-pass analysis on the source program to determine
;; the set of assigned lexicals, and to identify unreferenced and
@@ -318,7 +315,7 @@
(%set-operand-residual-value!
op
(match val
- (($ <application> src ($ <primitive-ref> _ 'values) (first))
+ (($ <primcall> src 'values (first))
;; The continuation of a residualized binding does not need the
;; introduced `values' node, so undo the effects of truncation.
first)
@@ -386,18 +383,15 @@ top-level bindings from ENV and return the resulting expression."
(define local-toplevel-env
;; The top-level environment of the module being compiled.
- (match exp
- (($ <toplevel-define> _ name)
- (vhash-consq name #t env))
- (($ <sequence> _ exps)
- (fold (lambda (x r)
- (match x
- (($ <toplevel-define> _ name)
- (vhash-consq name #t r))
- (_ r)))
- env
- exps))
- (_ env)))
+ (let ()
+ (define (env-folder x env)
+ (match x
+ (($ <toplevel-define> _ name)
+ (vhash-consq name #t env))
+ (($ <seq> _ head tail)
+ (env-folder tail (env-folder head env)))
+ (_ env)))
+ (env-folder exp vlist-null)))
(define (local-toplevel? name)
(vhash-assq name local-toplevel-env))
@@ -445,7 +439,7 @@ top-level bindings from ENV and return the resulting expression."
(define* (residualize-lexical op #:optional ctx val)
(log 'residualize op)
(set-operand-residualize?! op #t)
- (if (memq ctx '(value values))
+ (if (eq? ctx 'value)
(set-operand-residual-value! op val))
(make-lexical-ref #f (var-name (operand-var op)) (operand-sym op)))
@@ -461,15 +455,13 @@ top-level bindings from ENV and return the resulting expression."
(values #t results))))
(lambda _
(values #f '()))))
-
(define (make-values src values)
(match values
((single) single) ; 1 value
((_ ...) ; 0, or 2 or more values
- (make-application src (make-primitive-ref src 'values)
- values))))
+ (make-primcall src 'values values))))
(define (residualize-call)
- (make-application src (make-primitive-ref #f name) args))
+ (make-primcall src name args))
(cond
((every const? args)
(let-values (((success? values)
@@ -511,13 +503,12 @@ top-level bindings from ENV and return the resulting expression."
($ <dynset>)) ;
(and (= (length names) 1)
(make-let src names gensyms (list exp) body)))
- (($ <application> src
- ($ <primitive-ref> _ (? singly-valued-primitive? name)))
+ (($ <primcall> src (? singly-valued-primitive? name))
(and (= (length names) 1)
(make-let src names gensyms (list exp) body)))
;; Statically-known number of values.
- (($ <application> src ($ <primitive-ref> _ 'values) vals)
+ (($ <primcall> src 'values vals)
(and (= (length names) (length vals))
(make-let src names gensyms vals body)))
@@ -525,7 +516,8 @@ top-level bindings from ENV and return the resulting expression."
(($ <conditional>) #f)
;; Bail on other applications.
- (($ <application>) #f)
+ (($ <call>) #f)
+ (($ <primcall>) #f)
;; Bail on prompt and abort.
(($ <prompt>) #f)
@@ -551,20 +543,17 @@ top-level bindings from ENV and return the resulting expression."
(make-let-values src exp
(make-lambda-case src2 req opt rest kw
inits gensyms body #f)))))
- (($ <dynwind> src winder body unwinder)
+ (($ <dynwind> src winder pre body post unwinder)
(let ((body (loop body)))
(and body
- (make-dynwind src winder body unwinder))))
+ (make-dynwind src winder pre body post unwinder))))
(($ <dynlet> src fluids vals body)
(let ((body (loop body)))
(and body
(make-dynlet src fluids vals body))))
- (($ <sequence> src exps)
- (match exps
- ((head ... tail)
- (let ((tail (loop tail)))
- (and tail
- (make-sequence src (append head (list tail)))))))))))
+ (($ <seq> src head tail)
+ (let ((tail (loop tail)))
+ (and tail (make-seq src head tail)))))))
(define (constant-expression? x)
;; Return true if X is constant, for the purposes of copying or
@@ -585,19 +574,20 @@ top-level bindings from ENV and return the resulting expression."
(($ <primitive-ref>) #t)
(($ <conditional> _ condition subsequent alternate)
(and (loop condition) (loop subsequent) (loop alternate)))
- (($ <application> _ ($ <primitive-ref> _ 'values) exps)
+ (($ <primcall> _ 'values exps)
(and (not (null? exps))
(every loop exps)))
- (($ <application> _ ($ <primitive-ref> _ name) args)
+ (($ <primcall> _ name args)
(and (effect-free-primitive? name)
(not (constructor-primitive? name))
- (not (accessor-primitive? name))
(types-check? name args)
- (every loop args)))
- (($ <application> _ ($ <lambda> _ _ body) args)
+ (if (accessor-primitive? name)
+ (every const? args)
+ (every loop args))))
+ (($ <call> _ ($ <lambda> _ _ body) args)
(and (loop body) (every loop args)))
- (($ <sequence> _ exps)
- (every loop exps))
+ (($ <seq> _ head tail)
+ (and (loop head) (loop tail)))
(($ <let> _ _ syms vals body)
(and (not (any assigned-lexical? syms))
(every loop vals) (loop body)))
@@ -646,7 +636,7 @@ top-level bindings from ENV and return the resulting expression."
(if (null? effects)
body
(let ((effect-vals (map operand-residual-value effects)))
- (make-sequence #f (reverse (cons body effect-vals)))))))
+ (list->seq #f (reverse (cons body effect-vals)))))))
(if (null? values)
body
(let ((values (reverse values)))
@@ -833,7 +823,7 @@ top-level bindings from ENV and return the resulting expression."
(let ((exp (for-effect exp)))
(if (void? exp)
exp
- (make-sequence src (list exp (make-void #f)))))
+ (make-seq src exp (make-void #f))))
(begin
(set-operand-residualize?! op #t)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
@@ -847,14 +837,14 @@ top-level bindings from ENV and return the resulting expression."
(body (loop body env counter ctx)))
(cond
((const? body)
- (for-tail (make-sequence src (append vals (list body)))))
+ (for-tail (list->seq src (append vals (list body)))))
((and (lexical-ref? body)
(memq (lexical-ref-gensym body) new))
(let ((sym (lexical-ref-gensym body))
(pairs (map cons new vals)))
;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
(for-tail
- (make-sequence
+ (list->seq
src
(append (map cdr (alist-delete sym pairs eq?))
(list (assq-ref pairs sym)))))))
@@ -911,40 +901,10 @@ top-level bindings from ENV and return the resulting expression."
(else #f)))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynwind> src winder body unwinder)
- (let ((pre (for-value winder))
- (body (for-tail body))
- (post (for-value unwinder)))
- (cond
- ((not (constant-expression? pre))
- (cond
- ((not (constant-expression? post))
- (let ((pre-sym (gensym "pre ")) (post-sym (gensym "post ")))
- (record-new-temporary! 'pre pre-sym 1)
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(pre post) (list pre-sym post-sym) (list pre post)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (let ((pre-sym (gensym "pre ")))
- (record-new-temporary! 'pre pre-sym 1)
- (make-let src '(pre) (list pre-sym) (list pre)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- post))))))
- ((not (constant-expression? post))
- (let ((post-sym (gensym "post ")))
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(post) (list post-sym) (list post)
- (make-dynwind src
- pre
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (make-dynwind src pre body post)))))
+ (($ <dynwind> src winder pre body post unwinder)
+ (make-dynwind src (for-value winder) (for-effect pre)
+ (for-tail body)
+ (for-effect post) (for-value unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
@@ -953,12 +913,7 @@ top-level bindings from ENV and return the resulting expression."
(($ <dynset> src fluid exp)
(make-dynset src (for-value fluid) (for-value exp)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
- (if (local-toplevel? name)
- exp
- (let ((exp (resolve-primitives! exp cenv)))
- (if (primitive-ref? exp)
- (for-tail exp)
- exp))))
+ exp)
(($ <toplevel-ref>)
;; todo: open private local bindings.
exp)
@@ -993,17 +948,59 @@ top-level bindings from ENV and return the resulting expression."
(make-conditional src condition
(for-tail subsequent)
(for-tail alternate)))))
- (($ <application> src
- ($ <primitive-ref> _ '@call-with-values)
+ (($ <primcall> src '@call-with-values
(producer
($ <lambda> _ _
(and consumer
;; No optional or kwargs.
($ <lambda-case>
_ req #f rest #f () gensyms body #f)))))
- (for-tail (make-let-values src (make-application src producer '())
+ (for-tail (make-let-values src (make-call src producer '())
consumer)))
- (($ <application> src ($ <primitive-ref> _ 'values) exps)
+ (($ <primcall> src 'dynamic-wind (w thunk u))
+ (for-tail
+ (cond
+ ((not (constant-expression? w))
+ (cond
+ ((not (constant-expression? u))
+ (let ((w-sym (gensym "w ")) (u-sym (gensym "u ")))
+ (record-new-temporary! 'w w-sym 2)
+ (record-new-temporary! 'u u-sym 2)
+ (make-let src '(w u) (list w-sym u-sym) (list w u)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'w w-sym)
+ (make-call #f (make-lexical-ref #f 'w w-sym) '())
+ (make-call #f thunk '())
+ (make-call #f (make-lexical-ref #f 'u u-sym) '())
+ (make-lexical-ref #f 'u u-sym)))))
+ (else
+ (let ((w-sym (gensym "w ")))
+ (record-new-temporary! 'w w-sym 2)
+ (make-let src '(w) (list w-sym) (list w)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'w w-sym)
+ (make-call #f (make-lexical-ref #f 'w w-sym) '())
+ (make-call #f thunk '())
+ (make-call #f u '())
+ u))))))
+ ((not (constant-expression? u))
+ (let ((u-sym (gensym "u ")))
+ (record-new-temporary! 'u u-sym 2)
+ (make-let src '(u) (list u-sym) (list u)
+ (make-dynwind
+ src
+ w
+ (make-call #f w '())
+ (make-call #f thunk '())
+ (make-call #f (make-lexical-ref #f 'u u-sym) '())
+ (make-lexical-ref #f 'u u-sym)))))
+ (else
+ (make-dynwind src w (make-call #f w '()) (make-call #f thunk '())
+ (make-call #f u '()) u)))))
+
+ (($ <primcall> src 'values exps)
(cond
((null? exps)
(if (eq? ctx 'effect)
@@ -1013,113 +1010,109 @@ top-level bindings from ENV and return the resulting expression."
(let ((vals (map for-value exps)))
(if (and (memq ctx '(value test effect))
(every singly-valued-expression? vals))
- (for-tail (make-sequence src (append (cdr vals) (list (car vals)))))
- (make-application src (make-primitive-ref #f 'values) vals))))))
- (($ <application> src orig-proc orig-args)
+ (for-tail (list->seq src (append (cdr vals) (list (car vals)))))
+ (make-primcall src 'values vals))))))
+
+ (($ <primcall> src (? constructor-primitive? name) args)
+ (cond
+ ((and (memq ctx '(effect test))
+ (match (cons name args)
+ ((or ('cons _ _)
+ ('list . _)
+ ('vector . _)
+ ('make-prompt-tag)
+ ('make-prompt-tag ($ <const> _ (? string?))))
+ #t)
+ (_ #f)))
+ ;; Some expressions can be folded without visiting the
+ ;; arguments for value.
+ (let ((res (if (eq? ctx 'effect)
+ (make-void #f)
+ (make-const #f #t))))
+ (for-tail (list->seq src (append args (list res))))))
+ (else
+ (match (cons name (map for-value args))
+ (('cons x ($ <const> _ (? (cut eq? <> '()))))
+ (make-primcall src 'list (list x)))
+ (('cons x ($ <primcall> _ 'list elts))
+ (make-primcall src 'list (cons x elts)))
+ ((name . args)
+ (make-primcall src name args))))))
+
+ (($ <primcall> src (? accessor-primitive? name) args)
+ (match (cons name (map for-value args))
+ ;; FIXME: these for-tail recursions could take place outside
+ ;; an effort counter.
+ (('car ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src tail head)))
+ (('cdr ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src head tail)))
+ (('car ($ <primcall> src 'list (head . tail)))
+ (for-tail (list->seq src (append tail (list head)))))
+ (('cdr ($ <primcall> src 'list (head . tail)))
+ (for-tail (make-seq src head (make-primcall #f 'list tail))))
+
+ (('car ($ <const> src (head . tail)))
+ (for-tail (make-const src head)))
+ (('cdr ($ <const> src (head . tail)))
+ (for-tail (make-const src tail)))
+ (((or 'memq 'memv) k ($ <const> _ (elts ...)))
+ ;; FIXME: factor
+ (case ctx
+ ((effect)
+ (for-tail
+ (make-seq src k (make-void #f))))
+ ((test)
+ (cond
+ ((const? k)
+ ;; A shortcut. The `else' case would handle it, but
+ ;; this way is faster.
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (and (member (const-exp k) elts) #t))))
+ ((null? elts)
+ (for-tail
+ (make-seq src k (make-const #f #f))))
+ (else
+ (let ((t (gensym "t "))
+ (eq (if (eq? name 'memq) 'eq? 'eqv?)))
+ (record-new-temporary! 't t (length elts))
+ (for-tail
+ (make-let
+ src (list 't) (list t) (list k)
+ (let lp ((elts elts))
+ (define test
+ (make-primcall #f eq
+ (list (make-lexical-ref #f 't t)
+ (make-const #f (car elts)))))
+ (if (null? (cdr elts))
+ test
+ (make-conditional src test
+ (make-const #f #t)
+ (lp (cdr elts)))))))))))
+ (else
+ (cond
+ ((const? k)
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (member (const-exp k) elts))))
+ ((null? elts)
+ (for-tail (make-seq src k (make-const #f #f))))
+ (else
+ (make-primcall src name (list k (make-const #f elts))))))))
+ ((name . args)
+ (fold-constants src name args ctx))))
+
+ (($ <primcall> src (? effect-free-primitive? name) args)
+ (fold-constants src name (map for-value args) ctx))
+
+ (($ <primcall> src name args)
+ (make-primcall src name (map for-value args)))
+
+ (($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
(let ((proc (visit orig-proc 'operator)))
(match proc
- (($ <primitive-ref> _ (? constructor-primitive? name))
- (cond
- ((and (memq ctx '(effect test))
- (match (cons name orig-args)
- ((or ('cons _ _)
- ('list . _)
- ('vector . _)
- ('make-prompt-tag)
- ('make-prompt-tag ($ <const> _ (? string?))))
- #t)
- (_ #f)))
- ;; Some expressions can be folded without visiting the
- ;; arguments for value.
- (let ((res (if (eq? ctx 'effect)
- (make-void #f)
- (make-const #f #t))))
- (for-tail (make-sequence src (append orig-args (list res))))))
- (else
- (match (cons name (map for-value orig-args))
- (('cons head tail)
- (match tail
- (($ <const> src (? (cut eq? <> '())))
- (make-application src (make-primitive-ref #f 'list)
- (list head)))
- (($ <application> src ($ <primitive-ref> _ 'list) elts)
- (make-application src (make-primitive-ref #f 'list)
- (cons head elts)))
- (_ (make-application src proc (list head tail)))))
- ((_ . args)
- (make-application src proc args))))))
- (($ <primitive-ref> _ (? accessor-primitive? name))
- (match (cons name (map for-value orig-args))
- ;; FIXME: these for-tail recursions could take place outside
- ;; an effort counter.
- (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list tail head))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list head tail))))
- (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence src (append tail (list head)))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence
- src
- (list head
- (make-application
- src (make-primitive-ref #f 'list) tail)))))
-
- (('car ($ <const> src (head . tail)))
- (for-tail (make-const src head)))
- (('cdr ($ <const> src (head . tail)))
- (for-tail (make-const src tail)))
- (((or 'memq 'memv) k ($ <const> _ (elts ...)))
- ;; FIXME: factor
- (case ctx
- ((effect)
- (for-tail
- (make-sequence src (list k (make-void #f)))))
- ((test)
- (cond
- ((const? k)
- ;; A shortcut. The `else' case would handle it, but
- ;; this way is faster.
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (and (member (const-exp k) elts) #t))))
- ((null? elts)
- (for-tail
- (make-sequence src (list k (make-const #f #f)))))
- (else
- (let ((t (gensym "t "))
- (eq (if (eq? name 'memq) 'eq? 'eqv?)))
- (record-new-temporary! 't t (length elts))
- (for-tail
- (make-let
- src (list 't) (list t) (list k)
- (let lp ((elts elts))
- (define test
- (make-application
- #f (make-primitive-ref #f eq)
- (list (make-lexical-ref #f 't t)
- (make-const #f (car elts)))))
- (if (null? (cdr elts))
- test
- (make-conditional src test
- (make-const #f #t)
- (lp (cdr elts)))))))))))
- (else
- (cond
- ((const? k)
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (member (const-exp k) elts))))
- ((null? elts)
- (for-tail (make-sequence src (list k (make-const #f #f)))))
- (else
- (make-application src proc (list k (make-const #f elts))))))))
- ((_ . args)
- (or (fold-constants src name args ctx)
- (make-application src proc args)))))
- (($ <primitive-ref> _ (? effect-free-primitive? name))
- (let ((args (map for-value orig-args)))
- (or (fold-constants src name args ctx)
- (make-application src proc args))))
+ (($ <primitive-ref> _ name)
+ (for-tail (make-primcall src name orig-args)))
(($ <lambda> _ _
($ <lambda-case> _ req opt #f #f inits gensyms body #f))
;; Simple case: no rest, no keyword arguments.
@@ -1131,8 +1124,7 @@ top-level bindings from ENV and return the resulting expression."
(cond
((or (< nargs nreq) (> nargs (+ nreq nopt)))
;; An error, or effecting arguments.
- (make-application src (for-call orig-proc)
- (map for-value orig-args)))
+ (make-call src (for-call orig-proc) (map for-value orig-args)))
((or (and=> (find-counter key counter) counter-recursive?)
(lambda? orig-proc))
;; A recursive call, or a lambda in the operator
@@ -1169,8 +1161,8 @@ top-level bindings from ENV and return the resulting expression."
(let/ec k
(define (abort)
(log 'inline-abort exp)
- (k (make-application src (for-call orig-proc)
- (map for-value orig-args))))
+ (k (make-call src (for-call orig-proc)
+ (map for-value orig-args))))
(define new-counter
(cond
;; These first two cases will transfer effort
@@ -1206,8 +1198,7 @@ top-level bindings from ENV and return the resulting expression."
(log 'inline-end result exp)
result)))))
(_
- (make-application src (for-call orig-proc)
- (map for-value orig-args))))))
+ (make-call src (for-call orig-proc) (map for-value orig-args))))))
(($ <lambda> src meta body)
(case ctx
((effect) (make-void #f))
@@ -1232,24 +1223,17 @@ top-level bindings from ENV and return the resulting expression."
new
(loop body env counter ctx)
(and alt (for-tail alt)))))
- (($ <sequence> src exps)
- (let lp ((exps exps) (effects '()))
- (match exps
- ((last)
- (if (null? effects)
- (for-tail last)
- (make-sequence
- src
- (reverse (cons (for-tail last) effects)))))
- ((head . rest)
- (let ((head (for-effect head)))
- (cond
- ((sequence? head)
- (lp (append (sequence-exps head) rest) effects))
- ((void? head)
- (lp rest effects))
- (else
- (lp rest (cons head effects)))))))))
+ (($ <seq> src head tail)
+ (let ((head (for-effect head))
+ (tail (for-tail tail)))
+ (if (void? head)
+ tail
+ (make-seq src
+ (if (and (seq? head)
+ (void? (seq-tail head)))
+ (seq-head head)
+ head)
+ tail))))
(($ <prompt> src tag body handler)
(define (singly-used-definition x)
(cond
@@ -1261,8 +1245,7 @@ top-level bindings from ENV and return the resulting expression."
(singly-used-definition (visit-operand x counter 'value 10 10))))
(else x)))
(match (singly-used-definition tag)
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
- (or () ((? constant-expression?))))
+ (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
;; There is no way that an <abort> could know the tag
;; for this <prompt>, so we can elide the <prompt>
;; entirely.
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index f7bb5cab2..8e9d2eb6e 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -60,7 +60,7 @@
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
+ vector-length vector-ref vector-set!
variable-ref variable-set!
variable-bound?
@@ -141,7 +141,7 @@
+ * - / 1- 1+ quotient remainder modulo
not
pair? null? list? symbol? vector? struct? string?
- string-length
+ string-length vector-length
;; These all should get expanded out by expand-primitives!.
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
@@ -232,12 +232,25 @@
(hashq-ref *singly-valued-primitive-table* prim))
(define (resolve-primitives! x mod)
+ (define local-definitions
+ (make-hash-table))
+
+ (let collect-local-definitions ((x x))
+ (record-case x
+ ((<toplevel-define> name)
+ (hashq-set! local-definitions name #t))
+ ((<seq> head tail)
+ (collect-local-definitions head)
+ (collect-local-definitions tail))
+ (else #f)))
+
(post-order!
(lambda (x)
(record-case x
((<toplevel-ref> src name)
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable mod name))
+ (and=> (and (not (hashq-ref local-definitions name))
+ (hashq-ref *interesting-primitive-vars*
+ (module-variable mod name)))
(lambda (name) (make-primitive-ref src name))))
((<module-ref> src mod name public?)
;; for the moment, we're disabling primitive resolution for
@@ -247,6 +260,9 @@
(and=> (hashq-ref *interesting-primitive-vars*
(module-variable m name))
(lambda (name) (make-primitive-ref src name))))))
+ ((<call> src proc args)
+ (and (primitive-ref? proc)
+ (make-primcall src (primitive-ref-name proc) args)))
(else #f)))
x))
@@ -258,11 +274,9 @@
(pre-order!
(lambda (x)
(record-case x
- ((<application> src proc args)
- (and (primitive-ref? proc)
- (let ((expand (hashq-ref *primitive-expand-table*
- (primitive-ref-name proc))))
- (and expand (apply expand src args)))))
+ ((<primcall> src name args)
+ (let ((expand (hashq-ref *primitive-expand-table* name)))
+ (and expand (apply expand src args))))
(else #f)))
x))
@@ -278,8 +292,8 @@
(lp (cdr in)
(cons (if (eq? (caar in) 'quote)
`(make-const src ,@(cdar in))
- `(make-application src (make-primitive-ref src ',(caar in))
- ,(inline-args (cdar in))))
+ `(make-primcall src ',(caar in)
+ ,(inline-args (cdar in))))
out)))
((symbol? (car in))
;; assume it's locally bound
@@ -297,8 +311,8 @@
,(consequent then)
,(consequent else)))
(else
- `(make-application src (make-primitive-ref src ',(car exp))
- ,(inline-args (cdr exp))))))
+ `(make-primcall src ',(car exp)
+ ,(inline-args (cdr exp))))))
((symbol? exp)
;; assume locally bound
exp)
@@ -470,25 +484,6 @@
(bytevector-ieee-double-native-set! vec (* i 8) x))
(hashq-set! *primitive-expand-table*
- 'dynamic-wind
- (case-lambda
- ((src pre thunk post)
- (let ((PRE (gensym " pre"))
- (THUNK (gensym " thunk"))
- (POST (gensym " post")))
- (make-let
- src
- '(pre thunk post)
- (list PRE THUNK POST)
- (list pre thunk post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
- (make-lexical-ref #f 'post POST)))))
- (else #f)))
-
-(hashq-set! *primitive-expand-table*
'@dynamic-wind
(case-lambda
((src pre expr post)
@@ -502,7 +497,9 @@
(make-dynwind
src
(make-lexical-ref #f 'pre PRE)
+ (make-call #f (make-lexical-ref #f 'pre PRE) '())
expr
+ (make-call #f (make-lexical-ref #f 'post POST) '())
(make-lexical-ref #f 'post POST)))))))
(hashq-set! *primitive-expand-table*
@@ -528,9 +525,9 @@
;; trickery here.
(make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-application #f (make-primitive-ref #f 'apply)
- (list handler
- (make-lexical-ref #f 'args args-sym)))
+ (make-primcall #f 'apply
+ (list handler
+ (make-lexical-ref #f 'args args-sym)))
#f))))
(else #f)))
@@ -544,14 +541,14 @@
((lambda? handler)
(let ((args-sym (gensym)))
(make-prompt
- src tag (make-application #f thunk '())
+ src tag (make-call #f thunk '())
;; If handler itself is a lambda, the inliner can do some
;; trickery here.
(make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-application #f (make-primitive-ref #f 'apply)
- (list handler
- (make-lexical-ref #f 'args args-sym)))
+ (make-primcall #f 'apply
+ (list handler
+ (make-lexical-ref #f 'args args-sym)))
#f))))
(else #f)))
(else #f)))
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index 38e6d311c..3ad372709 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -1,6 +1,6 @@
;;; Tree Intermediate Language
-;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -33,7 +33,9 @@
(pmatch exps
(() (make-void #f))
((,x) x)
- (else (make-sequence #f exps))))
+ ((,x . ,rest)
+ (make-seq #f x (join rest env)))
+ (else (error "what!" exps env))))
(define-language tree-il
#:title "Tree Intermediate Language"
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index e4424f382..cd811b3bb 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -26,54 +26,112 @@
;;;;
(define-module (oop goops)
- :use-module (srfi srfi-1)
- :export-syntax (define-class class standard-define-class
- define-generic define-accessor define-method
- define-extended-generic define-extended-generics
- method)
- :export (is-a? class-of
- ensure-metaclass ensure-metaclass-with-supers
- make-class
- make-generic ensure-generic
- make-extended-generic
- make-accessor ensure-accessor
- add-method!
- class-slot-ref class-slot-set! slot-unbound slot-missing
- slot-definition-name slot-definition-options
- slot-definition-allocation
- slot-definition-getter slot-definition-setter
- slot-definition-accessor
- slot-definition-init-value slot-definition-init-form
- slot-definition-init-thunk slot-definition-init-keyword
- slot-init-function class-slot-definition
- method-source
- compute-cpl compute-std-cpl compute-get-n-set compute-slots
- compute-getter-method compute-setter-method
- allocate-instance initialize make-instance make
- no-next-method no-applicable-method no-method
- change-class update-instance-for-different-class
- shallow-clone deep-clone
- class-redefinition
- apply-generic apply-method apply-methods
- compute-applicable-methods %compute-applicable-methods
- method-more-specific? sort-applicable-methods
- class-subclasses class-methods
- goops-error
- min-fixnum max-fixnum
- ;;; *fixme* Should go into goops.c
- instance? slot-ref-using-class
- slot-set-using-class! slot-bound-using-class?
- slot-exists-using-class? slot-ref slot-set! slot-bound?
- class-name class-direct-supers class-direct-subclasses
- class-direct-methods class-direct-slots class-precedence-list
- class-slots
- generic-function-name
- generic-function-methods method-generic-function
- method-specializers method-formals
- primitive-generic-generic enable-primitive-generic!
- method-procedure accessor-method-slot-definition
- slot-exists? make find-method get-keyword)
- :no-backtrace)
+ #:use-module (srfi srfi-1)
+ #:export-syntax (define-class class standard-define-class
+ define-generic define-accessor define-method
+ define-extended-generic define-extended-generics
+ method)
+ #:export ( ;; The root of everything.
+ <top>
+ <class> <object>
+
+ ;; Slot types.
+ <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
+ <read-only-slot> <self-slot> <protected-opaque-slot>
+ <protected-hidden-slot> <protected-read-only-slot>
+ <scm-slot> <int-slot> <float-slot> <double-slot>
+
+ ;; Methods are implementations of generic functions.
+ <method> <accessor-method>
+
+ ;; Applicable objects, either procedures or applicable structs.
+ <procedure-class> <applicable>
+ <procedure> <primitive-generic>
+
+ ;; Applicable structs.
+ <applicable-struct-class>
+ <applicable-struct>
+ <generic> <extended-generic>
+ <generic-with-setter> <extended-generic-with-setter>
+ <accessor> <extended-accessor>
+
+ ;; Types with their own allocated typecodes.
+ <boolean> <char> <list> <pair> <null> <string> <symbol>
+ <vector> <bytevector> <uvec> <foreign> <hashtable>
+ <fluid> <dynamic-state> <frame> <objcode> <vm> <vm-continuation>
+
+ ;; Numbers.
+ <number> <complex> <real> <integer> <fraction>
+
+ ;; Unknown.
+ <unknown>
+
+ ;; Particular SMOB data types. All SMOB types have
+ ;; corresponding classes, which may be obtained via class-of,
+ ;; once you have an instance. Perhaps FIXME to provide a
+ ;; smob-type-name->class procedure.
+ <arbiter> <promise> <thread> <mutex> <condition-variable>
+ <regexp> <hook> <bitvector> <random-state> <async>
+ <directory> <keyword> <array> <character-set>
+ <dynamic-object> <guardian> <macro>
+
+ ;; Modules.
+ <module>
+
+ ;; Ports.
+ <port> <input-port> <output-port> <input-output-port>
+
+ ;; Like SMOB types, all port types have their own classes,
+ ;; which can be accessed via `class-of' once you have an
+ ;; instance. Here we export bindings just for file ports.
+ <file-port>
+ <file-input-port> <file-output-port> <file-input-output-port>
+
+ is-a? class-of
+ ensure-metaclass ensure-metaclass-with-supers
+ make-class
+ make-generic ensure-generic
+ make-extended-generic
+ make-accessor ensure-accessor
+ add-method!
+ class-slot-ref class-slot-set! slot-unbound slot-missing
+ slot-definition-name slot-definition-options
+ slot-definition-allocation
+
+ slot-definition-getter slot-definition-setter
+ slot-definition-accessor
+ slot-definition-init-value slot-definition-init-form
+ slot-definition-init-thunk slot-definition-init-keyword
+ slot-init-function class-slot-definition
+ method-source
+ compute-cpl compute-std-cpl compute-get-n-set compute-slots
+ compute-getter-method compute-setter-method
+ allocate-instance initialize make-instance make
+ no-next-method no-applicable-method no-method
+ change-class update-instance-for-different-class
+ shallow-clone deep-clone
+ class-redefinition
+ apply-generic apply-method apply-methods
+ compute-applicable-methods %compute-applicable-methods
+ method-more-specific? sort-applicable-methods
+ class-subclasses class-methods
+ goops-error
+ min-fixnum max-fixnum
+
+;;; *fixme* Should go into goops.c
+ instance? slot-ref-using-class
+ slot-set-using-class! slot-bound-using-class?
+ slot-exists-using-class? slot-ref slot-set! slot-bound?
+ class-name class-direct-supers class-direct-subclasses
+ class-direct-methods class-direct-slots class-precedence-list
+ class-slots
+ generic-function-name
+ generic-function-methods method-generic-function
+ method-specializers method-formals
+ primitive-generic-generic enable-primitive-generic!
+ method-procedure accessor-method-slot-definition
+ slot-exists? make find-method get-keyword)
+ #:no-backtrace)
(define *goops-module* (current-module))
@@ -97,6 +155,7 @@
(oop goops compile))
+;; FIXME: deprecate.
(eval-when (eval load compile)
(define min-fixnum (- (expt 2 29)))
(define max-fixnum (- (expt 2 29) 1)))
@@ -815,6 +874,20 @@
;;; Handling of duplicate bindings in the module system
;;;
+(define (find-subclass super name)
+ (let lp ((classes (class-direct-subclasses super)))
+ (cond
+ ((null? classes)
+ (error "class not found" name))
+ ((and (slot-bound? (car classes) 'name)
+ (eq? (class-name (car classes)) name))
+ (car classes))
+ (else
+ (lp (cdr classes))))))
+
+;; A record type.
+(define <module> (find-subclass <top> '<module>))
+
(define-method (merge-generics (module <module>)
(name <symbol>)
(int1 <module>)
@@ -1660,3 +1733,34 @@
;; Tell C code that the main bulk of Goops has been loaded
(%goops-loaded)
+
+
+
+
+;;;
+;;; {SMOB and port classes}
+;;;
+
+(define <arbiter> (find-subclass <top> '<arbiter>))
+(define <promise> (find-subclass <top> '<promise>))
+(define <thread> (find-subclass <top> '<thread>))
+(define <mutex> (find-subclass <top> '<mutex>))
+(define <condition-variable> (find-subclass <top> '<condition-variable>))
+(define <regexp> (find-subclass <top> '<regexp>))
+(define <hook> (find-subclass <top> '<hook>))
+(define <bitvector> (find-subclass <top> '<bitvector>))
+(define <random-state> (find-subclass <top> '<random-state>))
+(define <async> (find-subclass <top> '<async>))
+(define <directory> (find-subclass <top> '<directory>))
+(define <keyword> (find-subclass <top> '<keyword>))
+(define <array> (find-subclass <top> '<array>))
+(define <character-set> (find-subclass <top> '<character-set>))
+(define <dynamic-object> (find-subclass <top> '<dynamic-object>))
+(define <guardian> (find-subclass <applicable> '<guardian>))
+(define <macro> (find-subclass <top> '<macro>))
+
+(define (define-class-subtree class)
+ (define! (class-name class) class)
+ (for-each define-class-subtree (class-direct-subclasses class)))
+
+(define-class-subtree (find-subclass <port> '<file-port>))
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index d2b9c9420..8f86bce57 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -48,14 +48,14 @@
;; The vtable of all condition types.
;; vtable fields: vtable, self, printer
;; user fields: id, parent, all-field-names
- (make-vtable-vtable "prprpr" 0
- (lambda (ct port)
- (if (eq? ct %condition-type-vtable)
- (display "#<condition-type-vtable>")
- (format port "#<condition-type ~a ~a>"
- (condition-type-id ct)
- (number->string (object-address ct)
- 16))))))
+ (let ((s (make-vtable (string-append standard-vtable-fields "prprpr")
+ (lambda (ct port)
+ (format port "#<condition-type ~a ~a>"
+ (condition-type-id ct)
+ (number->string (object-address ct)
+ 16))))))
+ (set-struct-vtable-name! s 'condition-type)
+ s))
(define (%make-condition-type layout id parent all-fields)
(let ((struct (make-struct %condition-type-vtable 0
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index 37f9b41ac..e6e965545 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -192,10 +192,6 @@ which does the reverse. PRINT must name a user-defined object printer."
;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
(let ((ptr->obj (make-weak-value-hash-table 3000)))
(lambda (ptr)
- ;; XXX: We can't use `hash-create-handle!' +
- ;; `set-cdr!' here because the former would create a
- ;; weak-cdr pair but the latter wouldn't register a
- ;; disappearing link (see `scm_hash_fn_set_x'.)
(or (hash-ref ptr->obj ptr)
(let ((o (%wrap ptr)))
(hash-set! ptr->obj ptr o)
diff --git a/test-suite/standalone/test-num2integral.c b/test-suite/standalone/test-num2integral.c
index 0246a3303..c8dc3a7e4 100644
--- a/test-suite/standalone/test-num2integral.c
+++ b/test-suite/standalone/test-num2integral.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010,
+/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010, 2011
* 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -25,6 +25,7 @@
#include <stdio.h>
#include <assert.h>
+#include <limits.h>
SCM out_of_range_handler (void *data, SCM key, SCM args);
SCM call_num2long_long_body (void *data);
@@ -56,14 +57,14 @@ static void
test_long_long ()
{
{
- SCM n = scm_from_long_long (SCM_I_LLONG_MIN);
+ SCM n = scm_from_long_long (LLONG_MIN);
long long result = scm_to_long_long(n);
- assert (result == SCM_I_LLONG_MIN);
+ assert (result == LLONG_MIN);
}
/* LLONG_MIN - 1 */
{
- SCM n = scm_difference (scm_from_long_long (SCM_I_LLONG_MIN), scm_from_int (1));
+ SCM n = scm_difference (scm_from_long_long (LLONG_MIN), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
@@ -71,8 +72,8 @@ test_long_long ()
/* SCM_I_LLONG_MIN + SCM_I_LLONG_MIN/2 */
{
- SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MIN),
- scm_from_long_long (SCM_I_LLONG_MIN / 2));
+ SCM n = scm_sum (scm_from_long_long (LLONG_MIN),
+ scm_from_long_long (LLONG_MIN / 2));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
@@ -80,7 +81,7 @@ test_long_long ()
/* SCM_I_LLONG_MAX + 1 */
{
- SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MAX), scm_from_int (1));
+ SCM n = scm_sum (scm_from_long_long (LLONG_MAX), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
@@ -108,9 +109,9 @@ static void
test_ulong_long ()
{
{
- SCM n = scm_from_ulong_long (SCM_I_ULLONG_MAX);
+ SCM n = scm_from_ulong_long (ULLONG_MAX);
unsigned long long result = scm_to_ulong_long(n);
- assert (result == SCM_I_ULLONG_MAX);
+ assert (result == ULLONG_MAX);
}
/* -1 */
@@ -123,7 +124,7 @@ test_ulong_long ()
/* SCM_I_ULLONG_MAX + 1 */
{
- SCM n = scm_sum (scm_from_ulong_long (SCM_I_ULLONG_MAX), scm_from_int (1));
+ SCM n = scm_sum (scm_from_ulong_long (ULLONG_MAX), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index edb9bfd99..1132a41b1 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -130,7 +130,7 @@
(string=? (target-os) os)))))))
(define %objcode-cookie-size
- (string-length "GOOF----LE-8-2.0"))
+ (string-length "GOOF----LE-8"))
(define (test-target triplet endian word-size)
(pass-if (format #f "target `~a' honored" triplet)
@@ -153,7 +153,7 @@
#f)))
(write-objcode (bytecode->objcode b) p)
(let ((cookie (make-bytevector %objcode-cookie-size))
- (expected (format #f "GOOF----~a-~a-~a"
+ (expected (format #f "GOOF----~a-~a"
(cond ((eq? endian (endianness little))
"LE")
((eq? endian (endianness big))
@@ -161,8 +161,7 @@
(else
(error "unknown endianness"
endian)))
- word-size
- (effective-version))))
+ word-size)))
(bytevector-copy! (get-objcode) 0 cookie 0
%objcode-cookie-size)
(string=? (utf8->string cookie) expected)))))))))
diff --git a/test-suite/tests/r6rs-records-syntactic.test b/test-suite/tests/r6rs-records-syntactic.test
index 9f9d37368..edc88aa72 100644
--- a/test-suite/tests/r6rs-records-syntactic.test
+++ b/test-suite/tests/r6rs-records-syntactic.test
@@ -30,12 +30,14 @@
(define-record-type simple-rtd)
(define-record-type
(specified-rtd specified-rtd-constructor specified-rtd-predicate))
-(define-record-type parent-rtd (fields x y))
+;; Can't be named as `parent-rtd', as that shadows the `parent-rtd'
+;; literal.
+(define-record-type *parent-rtd (fields x y))
(define-record-type child-parent-rtd-rtd
- (parent-rtd (record-type-descriptor parent-rtd)
- (record-constructor-descriptor parent-rtd))
+ (parent-rtd (record-type-descriptor *parent-rtd)
+ (record-constructor-descriptor *parent-rtd))
(fields z))
-(define-record-type child-parent-rtd (parent parent-rtd) (fields z))
+(define-record-type child-parent-rtd (parent *parent-rtd) (fields z))
(define-record-type mutable-fields-rtd
(fields (mutable mutable-bar)
(mutable mutable-baz mutable-baz-accessor mutable-baz-mutator)))
@@ -69,10 +71,10 @@
(defined? 'specified-rtd-constructor)))
(pass-if "parent-rtd clause includes specified parent"
- (eq? (record-type-parent child-parent-rtd-rtd) parent-rtd))
+ (eq? (record-type-parent child-parent-rtd-rtd) *parent-rtd))
(pass-if "parent clause includes specified parent"
- (eq? (record-type-parent child-parent-rtd) parent-rtd))
+ (eq? (record-type-parent child-parent-rtd) *parent-rtd))
(pass-if "protocol clause includes specified protocol"
(let ((protocol-record (make-protocol-rtd 1 2)))
diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test
index 8217a4156..c2b65a64c 100644
--- a/test-suite/tests/regexp.test
+++ b/test-suite/tests/regexp.test
@@ -145,6 +145,8 @@
(with-latin1-locale body ...)
(begin body ...)))))
+(define char-code-limit 256)
+
;; Since `regexp-quote' uses string ports, and since it is used below
;; with non-ASCII characters, these ports must be Unicode-capable.
(define-syntax with-unicode
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index fcc0349ba..5163bac00 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -799,7 +799,73 @@
(pass-if-syntax-error "(define)"
exception:generic-syncase-error
(eval '(define)
- (interaction-environment)))))
+ (interaction-environment))))
+
+ (pass-if "module scoping"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-1)
+ #:export (define-10))
+ (define-syntax-rule (define-10 name)
+ (begin
+ (define t 10)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-2)
+ #:use-module (top-level-define/module-scoping-1))
+ (define-10 foo)
+ (foo))
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, same symbolic name"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-3))
+ (define a 10)
+ (define-module (top-level-define/module-scoping-4)
+ #:use-module (top-level-define/module-scoping-3))
+ (define a (@@ (top-level-define/module-scoping-3) a))
+ a)
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, introduced names"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-5)
+ #:export (define-constant))
+ (define-syntax-rule (define-constant name val)
+ (begin
+ (define t val)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-6)
+ #:use-module (top-level-define/module-scoping-5))
+ (define-constant foo 10)
+ (define-constant bar 20)
+ (foo))
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, duplicate introduced name"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-7)
+ #:export (define-constant))
+ (define-syntax-rule (define-constant name val)
+ (begin
+ (define t val)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-8)
+ #:use-module (top-level-define/module-scoping-7))
+ (define-constant foo 10)
+ (define-constant foo 20)
+ (foo))
+ (current-module))
+ 20)))
(with-test-prefix "internal define"
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 0b00f6f8a..e8945c6cc 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -74,12 +74,9 @@
(@@ (language tree-il optimize) peval))
(define-syntax pass-if-peval
- (syntax-rules (resolve-primitives)
+ (syntax-rules ()
((_ in pat)
(pass-if-peval in pat
- (compile 'in #:from 'scheme #:to 'tree-il)))
- ((_ resolve-primitives in pat)
- (pass-if-peval in pat
(expand-primitives!
(resolve-primitives!
(compile 'in #:from 'scheme #:to 'tree-il)
@@ -116,15 +113,15 @@
(begin (void) (const 1))
(program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
(assert-tree-il->glil
- (apply (primitive +) (void) (const 1))
+ (primcall + (void) (const 1))
(program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
- (apply (toplevel foo) (const 1))
+ (call (toplevel foo) (const 1))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
(assert-tree-il->glil
- (begin (apply (toplevel foo) (const 1)) (void))
+ (begin (call (toplevel foo) (const 1)) (void))
(program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2)
(label ,l3) (mv-bind 0 #f)
@@ -132,7 +129,7 @@
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
- (apply (toplevel foo) (apply (toplevel bar)))
+ (call (toplevel foo) (call (toplevel bar)))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
(call tail-call 1))))
@@ -151,7 +148,7 @@
(eq? l1 l3) (eq? l2 l4))
(assert-tree-il->glil
- (apply (primitive null?) (if (toplevel foo) (const 1) (const 2)))
+ (primcall null? (if (toplevel foo) (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
(const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4)
@@ -168,7 +165,7 @@
(program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (primitive +))
+ (primcall null? (primitive +))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
(call return 1))))
@@ -188,7 +185,7 @@
(unbind)))
(assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
+ (let (x) (y) ((const 1)) (primcall null? (lexical x y)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1)
@@ -198,7 +195,7 @@
(assert-tree-il->glil
;; unreferenced sets may be optimized away -- make sure they are ref'd
(let (x) (y) ((const 1))
- (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
+ (set! (lexical x y) (primcall 1+ (lexical x y))))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
@@ -207,7 +204,7 @@
(assert-tree-il->glil
(let (x) (y) ((const 1))
- (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
+ (begin (set! (lexical x y) (primcall 1+ (lexical x y)))
(lexical x y)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
@@ -217,8 +214,8 @@
(assert-tree-il->glil
(let (x) (y) ((const 1))
- (apply (primitive null?)
- (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
+ (primcall null?
+ (set! (lexical x y) (primcall 1+ (lexical x y)))))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
@@ -239,7 +236,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (@ (foo) bar))
+ (primcall null? (@ (foo) bar))
(program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar)
(call null? 1) (call return 1)))
@@ -257,7 +254,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (@@ (foo) bar))
+ (primcall null? (@@ (foo) bar))
(program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar)
(call null? 1) (call return 1))))
@@ -276,7 +273,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
+ (primcall null? (set! (@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1)))
@@ -294,7 +291,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
+ (primcall null? (set! (@@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1))))
@@ -313,7 +310,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (toplevel bar))
+ (primcall null? (toplevel bar))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar)
(call null? 1) (call return 1))))
@@ -332,7 +329,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (set! (toplevel bar) (const 2)))
+ (primcall null? (set! (toplevel bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(void) (call null? 1) (call return 1))))
@@ -351,7 +348,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (define bar (const 2)))
+ (primcall null? (define bar (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(void) (call null? 1) (call return 1))))
@@ -369,7 +366,7 @@
(assert-tree-il->glil
;; This gets simplified by `peval'.
- (apply (primitive null?) (const 2))
+ (primcall null? (const 2))
(program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1))))
@@ -377,7 +374,7 @@
;; simple bindings -> let
(assert-tree-il->glil without-partial-evaluation
(letrec (x y) (x1 y1) ((const 10) (const 20))
- (apply (toplevel foo) (lexical x x1) (lexical y y1)))
+ (call (toplevel foo) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
(const 10) (const 20)
(bind (x #f 0) (y #f 1))
@@ -389,8 +386,8 @@
;; complex bindings -> box and set! within let
(assert-tree-il->glil without-partial-evaluation
- (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
+ (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
+ (primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 4 #f) (label _)
(void) (void) ;; what are these?
(bind (x #t 0) (y #t 1))
@@ -407,8 +404,8 @@
;; complex bindings in letrec* -> box and set! in order
(assert-tree-il->glil without-partial-evaluation
- (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
+ (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
+ (primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
(void) (void) ;; what are these?
(bind (x #t 0) (y #t 1))
@@ -527,27 +524,27 @@
(assert-tree-il->glil
;; This gets simplified by `peval'.
- (apply (primitive null?) (begin (const #f) (const 2)))
+ (primcall null? (begin (const #f) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1))))
(with-test-prefix "values"
(assert-tree-il->glil
- (apply (primitive values)
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values
+ (primcall values (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 1) (call return 1)))
(assert-tree-il->glil
- (apply (primitive values)
- (apply (primitive values) (const 1) (const 2))
- (const 3))
+ (primcall values
+ (primcall values (const 1) (const 2))
+ (const 3))
(program () (std-prelude 0 0 #f) (label _)
(const 1) (const 3) (call return/values 2)))
(assert-tree-il->glil
- (apply (primitive +)
- (apply (primitive values) (const 1) (const 2)))
+ (primcall +
+ (primcall values (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 1) (call return 1))))
@@ -589,10 +586,10 @@
(with-test-prefix "apply"
(assert-tree-il->glil
- (apply (primitive @apply) (toplevel foo) (toplevel bar))
+ (primcall @apply (toplevel foo) (toplevel bar))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
(assert-tree-il->glil
- (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
+ (begin (primcall @apply (toplevel foo) (toplevel bar)) (void))
(program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@@ -600,7 +597,7 @@
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
- (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
+ (call (toplevel foo) (call (toplevel @apply) (toplevel bar) (toplevel baz)))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
@@ -608,10 +605,10 @@
(with-test-prefix "call/cc"
(assert-tree-il->glil
- (apply (primitive @call-with-current-continuation) (toplevel foo))
+ (primcall @call-with-current-continuation (toplevel foo))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
(assert-tree-il->glil
- (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
+ (begin (primcall @call-with-current-continuation (toplevel foo)) (void))
(program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@@ -619,8 +616,8 @@
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
- (apply (toplevel foo)
- (apply (toplevel @call-with-current-continuation) (toplevel bar)))
+ (call (toplevel foo)
+ (call (toplevel @call-with-current-continuation) (toplevel bar)))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
@@ -654,7 +651,7 @@
(f)))
(const 3))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, let-values (requires primitive expansion for
;; `call-with-values'.)
(let ((x 0))
@@ -664,19 +661,19 @@
(+ a b))))
(const 3))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values.
(let ((x 1) (y 2))
(values x y))
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values truncated.
(let ((x (values 1 'a)) (y 2))
(values x y))
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values truncated.
(or (values 1 2) 3)
(const 1))
@@ -684,23 +681,23 @@
(pass-if-peval
;; First order, coalesced, mutability preserved.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+ (primcall list
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
;; First order, coalesced, mutability preserved.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
;; This must not be a constant.
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+ (primcall list
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
;; First order, coalesced, immutability preserved.
(cons 0 (cons 1 (cons 2 '(3 4 5))))
- (apply (primitive cons) (const 0)
- (apply (primitive cons) (const 1)
- (apply (primitive cons) (const 2)
- (const (3 4 5))))))
+ (primcall cons (const 0)
+ (primcall cons (const 1)
+ (primcall cons (const 2)
+ (const (3 4 5))))))
;; These two tests doesn't work any more because we changed the way we
;; deal with constants -- now the algorithm will see a construction as
@@ -725,10 +722,10 @@
(if (zero? i)
r
(loop (1- i) (cons (cons i i) r))))
- (apply (primitive list)
- (apply (primitive cons) (const 1) (const 1))
- (apply (primitive cons) (const 2) (const 2))
- (apply (primitive cons) (const 3) (const 3))))
+ (primcall list
+ (primcall cons (const 1) (const 1))
+ (primcall cons (const 2) (const 2))
+ (primcall cons (const 3) (const 3))))
;;
;; See above.
#;
@@ -749,15 +746,15 @@
r
(loop (1- i) (cons (cons i i) r))))
(let (r) (_)
- ((apply (primitive list)
- (apply (primitive cons) (const 3) (const 3))))
+ ((primcall list
+ (primcall cons (const 3) (const 3))))
(let (r) (_)
- ((apply (primitive cons)
- (apply (primitive cons) (const 2) (const 2))
- (lexical r _)))
- (apply (primitive cons)
- (apply (primitive cons) (const 1) (const 1))
- (lexical r _)))))
+ ((primcall cons
+ (primcall cons (const 2) (const 2))
+ (lexical r _)))
+ (primcall cons
+ (primcall cons (const 1) (const 1))
+ (lexical r _)))))
;; See above.
(pass-if-peval
@@ -767,21 +764,21 @@
(car r)
(loop (1- i) (cons i r))))
(let (r) (_)
- ((apply (primitive list) (const 4)))
+ ((primcall list (const 4)))
(let (r) (_)
- ((apply (primitive cons)
- (const 3)
- (lexical r _)))
+ ((primcall cons
+ (const 3)
+ (lexical r _)))
(let (r) (_)
- ((apply (primitive cons)
- (const 2)
- (lexical r _)))
+ ((primcall cons
+ (const 2)
+ (lexical r _)))
(let (r) (_)
- ((apply (primitive cons)
- (const 1)
- (lexical r _)))
- (apply (primitive car)
- (lexical r _)))))))
+ ((primcall cons
+ (const 1)
+ (lexical r _)))
+ (primcall car
+ (lexical r _)))))))
;; Static sums.
(pass-if-peval
@@ -791,7 +788,7 @@
(loop (cdr l) (+ sum (car l)))))
(const 10))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(let ((string->chars
(lambda (s)
(define (char-at n)
@@ -804,7 +801,7 @@
(loop (1+ i)))
'())))))
(string->chars "yo"))
- (apply (primitive list) (const #\y) (const #\o)))
+ (primcall list (const #\y) (const #\o)))
(pass-if-peval
;; Primitives in module-refs are resolved (the expansion of `pmatch'
@@ -815,14 +812,13 @@
(pmatch '(a b c d)
((a b . _)
#t)))
- (begin
- (apply . _)
- (const #t)))
+ (seq (call . _)
+ (const #t)))
(pass-if-peval
;; Mutability preserved.
((lambda (x y z) (list x y z)) 1 2 3)
- (apply (primitive list) (const 1) (const 2) (const 3)))
+ (primcall list (const 1) (const 2) (const 3)))
(pass-if-peval
;; Don't propagate effect-free expressions that operate on mutable
@@ -831,10 +827,10 @@
(y (car x)))
(set-car! x 0)
y)
- (let (x) (_) ((apply (primitive list) (const 1)))
- (let (y) (_) ((apply (primitive car) (lexical x _)))
- (begin
- (apply (toplevel set-car!) (lexical x _) (const 0))
+ (let (x) (_) ((primcall list (const 1)))
+ (let (y) (_) ((primcall car (lexical x _)))
+ (seq
+ (primcall set-car! (lexical x _) (const 0))
(lexical y _)))))
(pass-if-peval
@@ -843,9 +839,9 @@
(let ((y (car x)))
(set-car! x 0)
y)
- (let (y) (_) ((apply (primitive car) (toplevel x)))
- (begin
- (apply (toplevel set-car!) (toplevel x) (const 0))
+ (let (y) (_) ((primcall car (toplevel x)))
+ (seq
+ (primcall set-car! (toplevel x) (const 0))
(lexical y _))))
(pass-if-peval
@@ -855,8 +851,8 @@
((lambda _
(lambda-case
(((x) _ _ _ _ _)
- (apply (lexical x _) (lexical x _))))))
- (apply (lexical x _) (lexical x _))))
+ (call (lexical x _) (lexical x _))))))
+ (call (lexical x _) (lexical x _))))
(pass-if-peval
;; First order, aliased primitive.
@@ -868,28 +864,28 @@
(begin
(define (+ x y) (pk x y))
(+ 1 2))
- (begin
+ (seq
(define +
(lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
- (apply (toplevel pk) (lexical x _) (lexical y _))))))
- (apply (toplevel +) (const 1) (const 2))))
+ (call (toplevel pk) (lexical x _) (lexical y _))))))
+ (call (toplevel +) (const 1) (const 2))))
(pass-if-peval
;; First-order, effects preserved.
(let ((x 2))
(do-something!)
x)
- (begin
- (apply (toplevel do-something!))
+ (seq
+ (call (toplevel do-something!))
(const 2)))
(pass-if-peval
;; First order, residual bindings removed.
(let ((x 2) (y 3))
(* (+ x y) z))
- (apply (primitive *) (const 5) (toplevel z)))
+ (primcall * (const 5) (toplevel z)))
(pass-if-peval
;; First order, with lambda.
@@ -900,7 +896,7 @@
(lambda (_)
(lambda-case
(((x) #f #f #f () (_))
- (apply (primitive +) (lexical x _) (const 9)))))))
+ (primcall + (lexical x _) (const 9)))))))
(pass-if-peval
;; First order, with lambda inlined & specialized twice.
@@ -910,22 +906,22 @@
(y 3))
(+ (* x (f x y))
(f something x)))
- (apply (primitive +)
- (apply (primitive *)
- (const 2)
- (apply (primitive +) ; (f 2 3)
- (apply (primitive *)
- (const 2)
- (toplevel top))
- (const 3)))
- (let (x) (_) ((toplevel something)) ; (f something 2)
- ;; `something' is not const, so preserve order of
- ;; effects with a lexical binding.
- (apply (primitive +)
- (apply (primitive *)
- (lexical x _)
- (toplevel top))
- (const 2)))))
+ (primcall +
+ (primcall *
+ (const 2)
+ (primcall + ; (f 2 3)
+ (primcall *
+ (const 2)
+ (toplevel top))
+ (const 3)))
+ (let (x) (_) ((toplevel something)) ; (f something 2)
+ ;; `something' is not const, so preserve order of
+ ;; effects with a lexical binding.
+ (primcall +
+ (primcall *
+ (lexical x _)
+ (toplevel top))
+ (const 2)))))
(pass-if-peval
;; First order, with lambda inlined & specialized 3 times.
@@ -935,15 +931,22 @@
(f -1 y)
(f 2 y)
(f z y)))
- (apply (primitive +)
- (const -1) ; (f -1 0)
- (const 0) ; (f 1 0)
- (begin (toplevel y) (const -1)) ; (f -1 y)
- (toplevel y) ; (f 2 y)
- (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
- (if (apply (primitive >) (lexical x _) (const 0))
- (lexical y _)
- (lexical x _)))))
+ (primcall
+ +
+ (const -1) ; (f -1 0)
+ (primcall
+ +
+ (const 0) ; (f 1 0)
+ (primcall
+ +
+ (seq (toplevel y) (const -1)) ; (f -1 y)
+ (primcall
+ +
+ (toplevel y) ; (f 2 y)
+ (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
+ (if (primcall > (lexical x _) (const 0))
+ (lexical y _)
+ (lexical x _))))))))
(pass-if-peval
;; First order, conditional.
@@ -955,7 +958,7 @@
(lambda ()
(lambda-case
(((x) #f #f #f () (_))
- (apply (toplevel display) (lexical x _))))))
+ (call (toplevel display) (lexical x _))))))
(pass-if-peval
;; First order, recursive procedure.
@@ -974,8 +977,8 @@
(foo)
x)
(let (x) (_) ((toplevel top))
- (begin
- (apply (toplevel foo))
+ (seq
+ (call (toplevel foo))
(lexical x _))))
(pass-if-peval
@@ -1014,8 +1017,8 @@
(lambda (x)
(+ x 1))
'(2 3))
- (let (y) (_) ((apply (toplevel foo)))
- (apply (primitive +) (lexical y _) (const 7))))
+ (let (y) (_) ((call (toplevel foo)))
+ (primcall + (lexical y _) (const 7))))
(pass-if-peval
;; Higher order with optional argument (caller-supplied value).
@@ -1037,7 +1040,7 @@
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
(let ((fold (lambda (f g) (f (g top)))))
(fold 1+ (lambda (x) x)))
- (apply (primitive 1+) (toplevel top)))
+ (primcall 1+ (toplevel top)))
(pass-if-peval
;; Procedure not inlined when residual code contains recursive calls.
@@ -1048,7 +1051,7 @@
(f (car x3) (fold f (cdr x3) b null? car cdr))))))
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
(letrec (fold) (_) (_)
- (apply (lexical fold _)
+ (call (lexical fold _)
(primitive *)
(toplevel x)
(const 1)
@@ -1060,7 +1063,7 @@
(lambda ()
(lambda-case
(((x2) #f #f #f () (_))
- (apply (primitive -) (lexical x2 _) (const 1))))))))
+ (primcall 1- (lexical x2 _))))))))
(pass-if "inlined lambdas are alpha-renamed"
;; In this example, `make-adder' is inlined more than once; thus,
@@ -1071,24 +1074,27 @@
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
(pmatch (unparse-tree-il
- (peval (compile
- '(let ((make-adder
- (lambda (x) (lambda (y) (+ x y)))))
- (cons (make-adder 1) (make-adder 2)))
- #:to 'tree-il)))
- ((apply (primitive cons)
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym1))
- (apply (primitive +)
- (const 1)
- (lexical y ,ref1)))))
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym2))
- (apply (primitive +)
- (const 2)
- (lexical y ,ref2))))))
+ (peval (expand-primitives!
+ (resolve-primitives!
+ (compile
+ '(let ((make-adder
+ (lambda (x) (lambda (y) (+ x y)))))
+ (cons (make-adder 1) (make-adder 2)))
+ #:to 'tree-il)
+ (current-module)))))
+ ((primcall cons
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym1))
+ (primcall +
+ (const 1)
+ (lexical y ,ref1)))))
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym2))
+ (primcall +
+ (const 2)
+ (lexical y ,ref2))))))
(and (eq? gensym1 ref1)
(eq? gensym2 ref2)
(not (eq? gensym1 gensym2))))
@@ -1108,8 +1114,8 @@
(b (lambda () (a)))
(c (lambda (x) x)))
(c 10))
- (begin (apply (toplevel foo!))
- (const 10)))
+ (seq (call (toplevel foo!))
+ (const 10)))
(pass-if-peval
;; Higher order, mutually recursive procedures.
@@ -1130,9 +1136,9 @@
;; Memv with non-constant list. It could fold but doesn't
;; currently.
(memv 1 (list 3 2 1))
- (apply (primitive memv)
- (const 1)
- (apply (primitive list) (const 3) (const 2) (const 1))))
+ (primcall memv
+ (const 1)
+ (primcall list (const 3) (const 2) (const 1))))
(pass-if-peval
;; Memv with non-constant key, constant list, test context
@@ -1140,11 +1146,11 @@
((3 2 1) 'a)
(else 'b))
(if (let (t) (_) ((toplevel foo))
- (if (apply (primitive eqv?) (lexical t _) (const 3))
+ (if (primcall eqv? (lexical t _) (const 3))
(const #t)
- (if (apply (primitive eqv?) (lexical t _) (const 2))
+ (if (primcall eqv? (lexical t _) (const 2))
(const #t)
- (apply (primitive eqv?) (lexical t _) (const 1)))))
+ (primcall eqv? (lexical t _) (const 1)))))
(const a)
(const b)))
@@ -1154,7 +1160,7 @@
(case foo
(() 'a)
(else 'b))
- (if (begin (toplevel foo) (const #f))
+ (if (seq (toplevel foo) (const #f))
(const a)
(const b)))
@@ -1168,12 +1174,12 @@
(lambda (n)
(vector-set! v n n)))
(let (v) (_)
- ((apply (toplevel make-vector) (const 6) (const #f)))
+ ((call (toplevel make-vector) (const 6) (const #f)))
(lambda ()
(lambda-case
(((n) #f #f #f () (_))
- (apply (toplevel vector-set!)
- (lexical v _) (lexical n _) (lexical n _)))))))
+ (primcall vector-set!
+ (lexical v _) (lexical n _) (lexical n _)))))))
(pass-if-peval
;; Mutable lexical is not propagated.
@@ -1181,7 +1187,7 @@
(lambda ()
v))
(let (v) (_)
- ((apply (primitive vector) (const 1) (const 2) (const 3)))
+ ((primcall vector (const 1) (const 2) (const 3)))
(lambda ()
(lambda-case
((() #f #f #f () ())
@@ -1192,12 +1198,13 @@
(let* ((x (if (> p q) (frob!) (display 'chbouib)))
(y (* x 2)))
(+ x x y))
- (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
- (apply (toplevel frob!))
- (apply (toplevel display) (const chbouib))))
- (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
- (apply (primitive +)
- (lexical x _) (lexical x _) (lexical y _)))))
+ (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
+ (call (toplevel frob!))
+ (call (toplevel display) (const chbouib))))
+ (let (y) (_) ((primcall * (lexical x _) (const 2)))
+ (primcall +
+ (lexical x _)
+ (primcall + (lexical x _) (lexical y _))))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.
@@ -1209,16 +1216,16 @@
(make-list 10)
(list 1 2 3))
(let (x y z) (_ _ _)
- ((apply (primitive vector) (const 1) (const 2) (const 3))
- (apply (toplevel make-list) (const 10))
- (apply (primitive list) (const 1) (const 2) (const 3)))
- (begin
- (apply (toplevel vector-set!)
- (lexical x _) (const 0) (const 0))
- (apply (toplevel set-car!)
- (lexical y _) (const 0))
- (apply (toplevel set-cdr!)
- (lexical z _) (const ())))))
+ ((primcall vector (const 1) (const 2) (const 3))
+ (call (toplevel make-list) (const 10))
+ (primcall list (const 1) (const 2) (const 3)))
+ (seq
+ (primcall vector-set!
+ (lexical x _) (const 0) (const 0))
+ (seq (primcall set-car!
+ (lexical y _) (const 0))
+ (primcall set-cdr!
+ (lexical z _) (const ()))))))
(pass-if-peval
(let ((foo top-foo) (bar top-bar))
@@ -1226,9 +1233,9 @@
(f (lambda (g x) (g x x))))
(+ (f g foo) (f g bar))))
(let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
- (apply (primitive +)
- (apply (primitive +) (lexical foo _) (lexical foo _))
- (apply (primitive +) (lexical bar _) (lexical bar _)))))
+ (primcall +
+ (primcall + (lexical foo _) (lexical foo _))
+ (primcall + (lexical bar _) (lexical bar _)))))
(pass-if-peval
;; Fresh objects are not turned into constants, nor are constants
@@ -1237,8 +1244,8 @@
(x (cons 1 c))
(y (cons 0 x)))
y)
- (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
- (apply (primitive cons) (const 0) (lexical x _))))
+ (let (x) (_) ((primcall cons (const 1) (const (2 3))))
+ (primcall cons (const 0) (lexical x _))))
(pass-if-peval
;; Bindings mutated.
@@ -1246,7 +1253,7 @@
(set! x 3)
x)
(let (x) (_) ((const 2))
- (begin
+ (seq
(set! (lexical x _) (const 3))
(lexical x _))))
@@ -1259,8 +1266,8 @@
(frob f) ; may mutate `x'
x)
(letrec (x) (_) ((const 0))
- (begin
- (apply (toplevel frob) (lambda _ _))
+ (seq
+ (call (toplevel frob) (lambda _ _))
(lexical x _))))
(pass-if-peval
@@ -1276,9 +1283,9 @@
(let ((x (make-foo)))
(frob! x) ; may mutate `x'
x)
- (let (x) (_) ((apply (toplevel make-foo)))
- (begin
- (apply (toplevel frob!) (lexical x _))
+ (let (x) (_) ((call (toplevel make-foo)))
+ (seq
+ (call (toplevel frob!) (lexical x _))
(lexical x _))))
(pass-if-peval
@@ -1289,10 +1296,10 @@
(lambda-case
(((x) #f #f #f () (_))
(if _ _
- (apply (lexical loop _)
- (apply (primitive 1-)
- (lexical x _))))))))
- (apply (lexical loop _) (toplevel x))))
+ (call (lexical loop _)
+ (primcall 1-
+ (lexical x _))))))))
+ (call (lexical loop _) (toplevel x))))
(pass-if-peval
;; Recursion on the 2nd argument is fully evaluated.
@@ -1301,8 +1308,8 @@
(if (> y 0)
(loop x (1- y))
(foo x y))))
- (let (x) (_) ((apply (toplevel top)))
- (apply (toplevel foo) (lexical x _) (const 0))))
+ (let (x) (_) ((call (toplevel top)))
+ (call (toplevel foo) (lexical x _) (const 0))))
(pass-if-peval
;; Inlining aborted when residual code contains recursive calls.
@@ -1317,10 +1324,10 @@
(letrec (loop) (_) ((lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
- (if (apply (primitive >)
- (lexical y _) (const 0))
+ (if (primcall >
+ (lexical y _) (const 0))
_ _)))))
- (apply (lexical loop _) (toplevel x) (const 0))))
+ (call (lexical loop _) (toplevel x) (const 0))))
(pass-if-peval
;; Infinite recursion: `peval' gives up and leaves it as is.
@@ -1337,7 +1344,7 @@
(and (< x top)
(loop (1+ x))))
(letrec (loop) (_) ((lambda . _))
- (apply (lexical loop _) (const 0))))
+ (call (lexical loop _) (const 0))))
(pass-if-peval
;; This test checks that the `start' binding is indeed residualized.
@@ -1347,10 +1354,10 @@
(let ((here (let ((start pos)) (lambda () start))))
(here)))
(let (pos) (_) ((const 0))
- (begin
+ (seq
(set! (lexical pos _) (const 1))
(let (here) (_) (_)
- (apply (lexical here _))))))
+ (call (lexical here _))))))
(pass-if-peval
;; FIXME: should this one residualize the binding?
@@ -1387,7 +1394,7 @@
((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical a _)))))
+ (call (lexical a _)))))
(lambda _
(lambda-case
(((x) #f #f #f () (_))
@@ -1395,12 +1402,11 @@
(lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical a _))))))
+ (call (lexical a _))))))
(let (d)
(_)
- ((apply (toplevel foo) (lexical b _)))
- (apply (lexical c _)
- (lexical d _)))))
+ ((call (toplevel foo) (lexical b _)))
+ (call (lexical c _) (lexical d _)))))
(pass-if-peval
;; In this case, we can prune the bindings. `a' ends up being copied
@@ -1409,20 +1415,20 @@
(letrec* ((a (lambda (x) (top x)))
(b (lambda () a)))
(foo (b) (b)))
- (apply (toplevel foo)
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))))
+ (call (toplevel foo)
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))))
(pass-if-peval
;; Constant folding: cons of #nil does not make list
(cons 1 #nil)
- (apply (primitive cons) (const 1) (const '#nil)))
+ (primcall cons (const 1) (const '#nil)))
(pass-if-peval
;; Constant folding: cons
@@ -1432,7 +1438,7 @@
(pass-if-peval
;; Constant folding: cons
(begin (cons (foo) 2) #f)
- (begin (apply (toplevel foo)) (const #f)))
+ (seq (call (toplevel foo)) (const #f)))
(pass-if-peval
;; Constant folding: cons
@@ -1452,12 +1458,12 @@
(pass-if-peval
;; Constant folding: car+cons, impure
(car (cons 1 (bar)))
- (begin (apply (toplevel bar)) (const 1)))
+ (seq (call (toplevel bar)) (const 1)))
(pass-if-peval
;; Constant folding: cdr+cons, impure
(cdr (cons (bar) 0))
- (begin (apply (toplevel bar)) (const 0)))
+ (seq (call (toplevel bar)) (const 0)))
(pass-if-peval
;; Constant folding: car+list
@@ -1467,40 +1473,43 @@
(pass-if-peval
;; Constant folding: cdr+list
(cdr (list 1 0))
- (apply (primitive list) (const 0)))
+ (primcall list (const 0)))
(pass-if-peval
;; Constant folding: car+list, impure
(car (list 1 (bar)))
- (begin (apply (toplevel bar)) (const 1)))
+ (seq (call (toplevel bar)) (const 1)))
(pass-if-peval
;; Constant folding: cdr+list, impure
(cdr (list (bar) 0))
- (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
+ (seq (call (toplevel bar)) (primcall list (const 0))))
(pass-if-peval
- resolve-primitives
;; Non-constant guards get lexical bindings.
(dynamic-wind foo (lambda () bar) baz)
- (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
- (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+ (let (w u) (_ _) ((toplevel foo) (toplevel baz))
+ (dynwind (lexical w _)
+ (call (lexical w _))
+ (toplevel bar)
+ (call (lexical u _))
+ (lexical u _))))
(pass-if-peval
- resolve-primitives
;; Constant guards don't need lexical bindings.
(dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
(dynwind
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel foo))))
+ (toplevel foo)
(toplevel bar)
+ (toplevel baz)
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel baz))))))
(pass-if-peval
- resolve-primitives
;; Prompt is removed if tag is unreferenced
(let ((tag (make-prompt-tag)))
(call-with-prompt tag
@@ -1509,7 +1518,6 @@
(const 1))
(pass-if-peval
- resolve-primitives
;; Prompt is removed if tag is unreferenced, with explicit stem
(let ((tag (make-prompt-tag "foo")))
(call-with-prompt tag
@@ -1518,7 +1526,6 @@
(const 1))
(pass-if-peval
- resolve-primitives
;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get
;; elided.
@@ -1531,9 +1538,9 @@
((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical loop _))))))
- (apply (lexical loop _)))))))
- (apply (lexical lp _)))))
+ (call (lexical loop _))))))
+ (call (lexical loop _)))))))
+ (call (lexical lp _)))))
@@ -1567,9 +1574,9 @@
'(lambda ()
(lambda-case
(((x y) #f #f #f () (x1 y1))
- (apply (toplevel +)
- (lexical x x1)
- (lexical y y1)))
+ (call (toplevel +)
+ (lexical x x1)
+ (lexical y y1)))
#f))))))
(and (equal? (map strip-source leaves)
(list (make-lexical-ref #f 'y 'y1)
diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test
index d939284c1..d9bbbebce 100644
--- a/test-suite/tests/vlist.test
+++ b/test-suite/tests/vlist.test
@@ -220,11 +220,11 @@
(and (fold (lambda (k v result)
(and result
(equal? (cons k v)
- (vhash-assq k vh))))
+ (vhash-assoc k vh))))
#t
keys
values)
- (not (vhash-assq 'x vh)))))
+ (not (vhash-assoc 'x vh)))))
(pass-if "vhash as vlist"
(let* ((keys '(a b c d e f g h i))
diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test
index d0f6c5ef5..9475eed55 100644
--- a/test-suite/tests/weaks.test
+++ b/test-suite/tests/weaks.test
@@ -68,28 +68,28 @@
exception:wrong-type-arg
(list->weak-vector 32)))
- (with-test-prefix "make-weak-key-alist-vector"
+ (with-test-prefix "make-weak-key-hash-table"
(pass-if "create"
- (make-weak-key-alist-vector 17)
+ (make-weak-key-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-weak-key-alist-vector '(bad arg))))
- (with-test-prefix "make-weak-value-alist-vector"
+ (make-weak-key-hash-table '(bad arg))))
+ (with-test-prefix "make-weak-value-hash-table"
(pass-if "create"
- (make-weak-value-alist-vector 17)
+ (make-weak-value-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-weak-value-alist-vector '(bad arg))))
+ (make-weak-value-hash-table '(bad arg))))
- (with-test-prefix "make-doubly-weak-alist-vector"
+ (with-test-prefix "make-doubly-weak-hash-table"
(pass-if "create"
- (make-doubly-weak-alist-vector 17)
+ (make-doubly-weak-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-doubly-weak-alist-vector '(bad arg)))))
+ (make-doubly-weak-hash-table '(bad arg)))))
@@ -138,9 +138,9 @@
(or (not value)
(equal? value initial-value)))
- (let ((x (make-weak-key-alist-vector 17))
- (y (make-weak-value-alist-vector 17))
- (z (make-doubly-weak-alist-vector 17))
+ (let ((x (make-weak-key-hash-table 17))
+ (y (make-weak-value-hash-table 17))
+ (z (make-doubly-weak-hash-table 17))
(test-key "foo")
(test-value "bar"))
(with-test-prefix