diff options
180 files changed, 25348 insertions, 30695 deletions
diff --git a/.gitignore b/.gitignore index 1d2bfe9aa..ddef18b0a 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 0cfe96165..a32ff4b8a 100644 --- a/configure.ac +++ b/configure.ac @@ -1259,7 +1259,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 @@ -1655,8 +1655,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 f7521b456..1e0ba2be3 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 0a1425026..cf4e135ec 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 1817100fd..502ae56fa 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 f5551ad7a..ee73855c6 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,151 +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) -#define SCM_ASRTGO(_cond, _label) -#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) -#define SCM_ASRTGO(_cond, _label) \ - do { if (SCM_UNLIKELY (!(_cond))) \ - goto _label; } 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 @@ -689,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 d442bdf4e..395fa11a0 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 Free Software Foundation, Inc. +/* Copyright (C) 1996,1998,2000,2001,2004,2005, 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 @@ -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 d99081caf..bcc351cb1 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -472,7 +472,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, int ndim, i, k; SCM_VALIDATE_REST_ARGUMENT (args); - SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); + SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME); if (scm_is_generalized_vector (ra)) { @@ -727,15 +727,15 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, else { ssize_t i; - scm_putc ('(', port); + scm_putc_unlocked ('(', port); for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd; i++, pos += h->dims[dim].inc) { scm_i_print_array_dimension (h, dim+1, pos, port, pstate); if (i < h->dims[dim].ubnd) - scm_putc (' ', port); + scm_putc_unlocked (' ', port); } - scm_putc (')', port); + scm_putc_unlocked (')', port); } return 1; } @@ -752,7 +752,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) scm_array_get_handle (array, &h); - scm_putc ('#', port); + scm_putc_unlocked ('#', port); if (h.ndims != 1 || h.dims[0].lbnd != 0) scm_intprint (h.ndims, 10, port); if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) @@ -773,12 +773,12 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) { if (print_lbnds) { - scm_putc ('@', port); + scm_putc_unlocked ('@', port); scm_intprint (h.dims[i].lbnd, 10, port); } if (print_lens) { - scm_putc (':', port); + scm_putc_unlocked (':', port); scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1, 10, port); } @@ -806,9 +806,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 @@ -832,14 +832,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) @@ -862,7 +862,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)); } @@ -870,11 +870,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; @@ -899,7 +899,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; @@ -924,7 +924,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); } @@ -932,7 +932,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, @@ -954,7 +954,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 db22c17e9..351e600a1 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; } @@ -207,14 +207,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; @@ -223,7 +223,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 { @@ -328,19 +328,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 @@ -355,9 +355,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 { @@ -372,7 +372,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)) { @@ -383,10 +383,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 @@ -413,7 +413,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 { @@ -511,9 +511,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; @@ -544,7 +544,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; } @@ -574,7 +574,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 c569ebfe1..5b5a1b8e2 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -53,12 +53,12 @@ bitvector_print (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 4ba305e80..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 @@ -2630,8 +81,6 @@ scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr, 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 82415ea2e..d11667191 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -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,625 +92,48 @@ 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); - 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 11dce99a1..5e270a25c 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -365,7 +365,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 1e5bd6822..779c63d0a 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 f60032818..3856b4412 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1027,7 +1027,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 @@ -1797,12 +1797,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 f92c5dddc..0c9c03ff8 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 6c05d7800..a734f2d1e 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; @@ -269,8 +266,8 @@ SCM_DEFINE (scm_pointer_to_bytevector, "pointer->bytevector", 2, 2, 0, blen = scm_to_size_t (len); - ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype); - register_weak_reference (ret, pointer); + ret = scm_c_take_typed_bytevector (ptr + boffset, blen, btype, pointer); + return ret; } #undef FUNC_NAME @@ -320,7 +317,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, @@ -333,9 +330,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); } @@ -1127,7 +1124,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)); @@ -1158,7 +1155,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) { @@ -1304,7 +1301,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 1348b8b5c..683c25bde 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -215,7 +215,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) { @@ -534,7 +534,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. */ @@ -553,26 +553,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 @@ -641,7 +636,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)) { @@ -650,8 +645,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) @@ -663,11 +658,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; } @@ -722,7 +717,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 b7781f3e7..fb844ff63 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -44,7 +44,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" @@ -245,106 +244,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 33b034040..0d271afce 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> @@ -48,7 +46,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" @@ -85,14 +82,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) @@ -954,6 +947,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 31fa17975..df1a64f7f 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 @@ -170,7 +162,6 @@ static SCM class_bytevector; static SCM class_uvec; 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 @@ -198,17 +189,15 @@ scm_i_define_class_for_vtable (SCM vtable) { SCM class; - scm_i_pthread_mutex_lock (&vtable_class_map_lock); - + scm_i_pthread_mutex_lock (&scm_i_misc_mutex); if (scm_is_false (vtable_class_map)) - vtable_class_map = scm_make_weak_key_hash_table (SCM_UNDEFINED); + vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); if (scm_is_false (scm_struct_vtable_p (vtable))) abort (); - class = scm_hashq_ref (vtable_class_map, vtable, SCM_BOOL_F); - - scm_i_pthread_mutex_unlock (&vtable_class_map_lock); + class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F); if (scm_is_false (class)) { @@ -227,9 +216,7 @@ scm_i_define_class_for_vtable (SCM vtable) /* Don't worry about races. This only happens when creating a vtable, which happens by definition in one thread. */ - scm_i_pthread_mutex_lock (&vtable_class_map_lock); - scm_hashq_set_x (vtable_class_map, vtable, class); - scm_i_pthread_mutex_unlock (&vtable_class_map_lock); + scm_weak_table_putq_x (vtable_class_map, vtable, class); } return class; @@ -928,7 +915,6 @@ SCM_SYMBOL (sym_cpl, "cpl"); SCM_SYMBOL (sym_default_slot_definition_class, "default-slot-definition-class"); SCM_SYMBOL (sym_slots, "slots"); SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters"); -SCM_SYMBOL (sym_keyword_access, "keyword-access"); SCM_SYMBOL (sym_nfields, "nfields"); @@ -963,7 +949,6 @@ build_class_class_slots (void) scm_list_1 (sym_default_slot_definition_class), scm_list_1 (sym_slots), scm_list_1 (sym_getters_n_setters), - scm_list_1 (sym_keyword_access), scm_list_1 (sym_nfields), SCM_UNDEFINED); } @@ -976,7 +961,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)); @@ -994,21 +979,21 @@ create_basic_classes (void) prep_hashsets (scm_class_class); - DEFVAR(name, scm_class_class); + scm_module_define (scm_module_goops, name, scm_class_class); /**** <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)); @@ -1727,36 +1712,6 @@ SCM_KEYWORD (k_name, "name"); SCM_GLOBAL_SYMBOL (scm_sym_args, "args"); -SCM -scm_apply_generic (SCM gf, SCM args) -{ - return scm_apply (SCM_STRUCT_PROCEDURE (gf), args, SCM_EOL); -} - -SCM -scm_call_generic_0 (SCM gf) -{ - return scm_call_0 (SCM_STRUCT_PROCEDURE (gf)); -} - -SCM -scm_call_generic_1 (SCM gf, SCM a1) -{ - return scm_call_1 (SCM_STRUCT_PROCEDURE (gf), a1); -} - -SCM -scm_call_generic_2 (SCM gf, SCM a1, SCM a2) -{ - return scm_call_2 (SCM_STRUCT_PROCEDURE (gf), a1, a2); -} - -SCM -scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) -{ - return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3); -} - SCM_SYMBOL (sym_delayed_compile, "delayed-compile"); static SCM make_dispatch_procedure (SCM gf) @@ -1900,6 +1855,47 @@ setup_extended_primitive_generics () } } +/* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is + * assumed that 'gf' is zero if uninitialized. It would be cleaner if + * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen. + */ + +SCM +scm_wta_dispatch_0 (SCM gf, const char *subr) +{ + if (!SCM_UNPACK (gf)) + scm_error_num_args_subr (subr); + + return scm_call_0 (gf); +} + +SCM +scm_wta_dispatch_1 (SCM gf, SCM a1, int pos, const char *subr) +{ + if (!SCM_UNPACK (gf)) + scm_wrong_type_arg (subr, pos, a1); + + return scm_call_1 (gf, a1); +} + +SCM +scm_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos, const char *subr) +{ + if (!SCM_UNPACK (gf)) + scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2); + + return scm_call_2 (gf, a1, a2); +} + +SCM +scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr) +{ + if (!SCM_UNPACK (gf)) + scm_wrong_type_arg (subr, pos, scm_list_ref (args, scm_from_int (pos))); + + return scm_apply_0 (gf, args); +} + /****************************************************************************** * * Protocol for calling a generic fumction @@ -2361,12 +2357,12 @@ fix_cpl (SCM c, SCM before, SCM after) static void make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) { - SCM tmp = scm_from_locale_symbol (name); + SCM tmp = scm_from_utf8_symbol (name); *var = scm_basic_make_class (meta, tmp, scm_is_pair (super) ? super : scm_list_1 (super), slots); - DEFVAR(tmp, *var); + scm_module_define (scm_module_goops, tmp, *var); } @@ -2562,30 +2558,25 @@ create_standard_classes (void) static SCM make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep) { - SCM class, name; + SCM name; if (type_name) { char buffer[100]; sprintf (buffer, template, type_name); - name = scm_from_locale_symbol (buffer); + name = scm_from_utf8_symbol (buffer); } else name = SCM_GOOPS_UNBOUND; - class = scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class, - name, supers, SCM_EOL); - - /* Only define name if doesn't already exist. */ - if (!SCM_GOOPS_UNBOUNDP (name) - && scm_is_false (scm_module_variable (scm_module_goops, name))) - DEFVAR (name, class); - return class; + return scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class, + name, supers, SCM_EOL); } static SCM make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep) { - SCM class, name; + SCM name; + if (scm_is_true (type_name_sym)) { name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"), @@ -2596,14 +2587,8 @@ make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep) else name = SCM_GOOPS_UNBOUND; - class = scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class, - name, supers, SCM_EOL); - - /* Only define name if doesn't already exist. */ - if (!SCM_GOOPS_UNBOUNDP (name) - && scm_is_false (scm_module_variable (scm_module_goops, name))) - DEFVAR (name, class); - return class; + return scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class, + name, supers, SCM_EOL); } SCM @@ -2711,7 +2696,7 @@ create_port_classes (void) { long i; - for (i = 0; i < scm_numptob; ++i) + for (i = scm_c_num_port_types () - 1; i >= 0; i--) scm_make_port_classes (i, SCM_PTOBNAME (i)); } @@ -2833,7 +2818,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 a40031898..b28e30b2a 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -663,11 +663,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; @@ -682,10 +682,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 ()); @@ -714,16 +714,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; } @@ -732,22 +732,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 ()); } @@ -765,7 +765,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; @@ -784,9 +784,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); } @@ -933,7 +933,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); @@ -998,7 +998,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 6a366aeea..bd8aee8ea 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 @@ -46,9 +46,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 536094fe2..5db8ed3e2 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -377,17 +377,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 @@ -423,9 +420,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; } @@ -434,9 +432,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 2551bdf91..d8dd24c06 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; @@ -648,10 +653,7 @@ 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_bytevector: @@ -659,7 +661,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) break; case scm_tc7_vector: ENTER_NESTED_DATA (pstate, exp, circref); - scm_puts ("#(", port); + scm_puts_unlocked ("#(", port); common_vector_printer: { register long i; @@ -671,43 +673,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; } @@ -852,7 +837,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; } @@ -913,7 +898,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. */ @@ -948,7 +933,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; } @@ -1028,7 +1013,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) { @@ -1038,7 +1023,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) { @@ -1048,7 +1033,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) { @@ -1060,7 +1045,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 @@ -1083,7 +1068,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 @@ -1093,7 +1078,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); } @@ -1164,14 +1149,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. @@ -1180,19 +1165,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); } @@ -1203,7 +1188,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; @@ -1233,18 +1218,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; @@ -1265,7 +1250,7 @@ fancy_printing: { if (n == 0) { - scm_puts (" ...", port); + scm_puts_unlocked (" ...", port); goto skip_tail; } else @@ -1273,14 +1258,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: @@ -1291,7 +1276,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; } @@ -1316,7 +1301,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; } @@ -1331,7 +1320,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; } @@ -1444,7 +1437,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 @@ -1489,7 +1482,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 @@ -1534,14 +1527,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 8e2cd6a5f..93ee7f033 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -22,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" @@ -43,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; @@ -58,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)) { @@ -72,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); @@ -106,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 @@ -147,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)) { @@ -159,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 @@ -174,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_assq (alist, scm_sym_arity)) - 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; } @@ -194,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 @@ -215,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)) @@ -229,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; } @@ -242,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 c414913fc..cb6f803a2 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -108,14 +108,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; } @@ -418,16 +418,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; @@ -441,15 +438,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; } } @@ -475,8 +470,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) @@ -484,7 +479,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 @@ -521,7 +516,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, @@ -546,7 +541,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 ()'). */ @@ -565,33 +560,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)); @@ -602,6 +579,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 () @@ -628,7 +672,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 666a9516b..b9963010f 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. */ @@ -1446,6 +1446,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) @@ -1481,19 +1498,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) @@ -1567,7 +1572,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 @@ -2131,66 +2210,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 b1fc51a38..0c163db5a 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 26ec16425..54b74e0a2 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 +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011 * 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,8 +438,8 @@ 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_unused_9 85 -#define scm_tc7_unused_10 87 +#define scm_tc7_weak_set 85 +#define scm_tc7_weak_table 87 #define scm_tc7_unused_20 93 #define scm_tc7_unused_11 95 #define scm_tc7_unused_12 101 @@ -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 f71c83c5a..aeadcfe6d 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -56,7 +56,6 @@ #include "libguile/init.h" #include "libguile/scmsigs.h" #include "libguile/strings.h" -#include "libguile/weaks.h" #include <full-read.h> @@ -368,11 +367,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; } @@ -631,10 +630,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; @@ -655,9 +650,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); @@ -671,7 +666,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); @@ -835,7 +830,7 @@ scm_init_guile () else { fprintf (stderr, "Failed to get stack base for current thread.\n"); - exit (1); + exit (EXIT_FAILURE); } } @@ -1276,9 +1271,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; } @@ -1381,7 +1376,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); } @@ -1525,6 +1521,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) @@ -1569,7 +1584,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); } @@ -1603,7 +1618,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, } t->block_asyncs--; - scm_async_click (); + scm_async_tick (); scm_remember_upto_here_2 (cond, mutex); @@ -1617,7 +1632,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); } @@ -1713,9 +1728,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 ab7773141..005be5063 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, ©); + 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], ©); + + 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], ©); + + 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], ©); + + if (!copy.key) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (set, k); + set->n_items--; + } + } + } + + if (set->n_items < set->lower) + resize_set (set); +} + + + + +static SCM +weak_set_lookup (scm_t_weak_set *set, unsigned long hash, + scm_t_set_predicate_fn pred, void *closure, + SCM dflt) +{ + unsigned long k, distance, size; + scm_t_weak_entry *entries; + + size = set->size; + entries = set->entries; + + hash = (hash << 1) | 0x1; + k = hash_to_index (hash, size); + + for (distance = 0; distance < size; distance++, k = (k + 1) % size) + { + unsigned long other_hash; + + retry: + other_hash = entries[k].hash; + + if (!other_hash) + /* Not found. */ + return dflt; + + if (hash == other_hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (set, k); + set->n_items--; + goto retry; + } + + if (pred (SCM_PACK (copy.key), closure)) + /* Found. */ + return SCM_PACK (copy.key); + } + + /* If the entry's distance is less, our key is not in the set. */ + if (entry_distance (other_hash, k, size) < distance) + return dflt; + } + + /* If we got here, then we were unfortunate enough to loop through the + whole set. Shouldn't happen, but hey. */ + return dflt; +} + + +static SCM +weak_set_add_x (scm_t_weak_set *set, unsigned long hash, + scm_t_set_predicate_fn pred, void *closure, + SCM obj) +{ + unsigned long k, distance, size; + scm_t_weak_entry *entries; + + size = set->size; + entries = set->entries; + + hash = (hash << 1) | 0x1; + k = hash_to_index (hash, size); + + for (distance = 0; ; distance++, k = (k + 1) % size) + { + unsigned long other_hash; + + retry: + other_hash = entries[k].hash; + + if (!other_hash) + /* Found an empty entry. */ + break; + + if (other_hash == hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (set, k); + set->n_items--; + goto retry; + } + + if (pred (SCM_PACK (copy.key), closure)) + /* Found an entry with this key. */ + return SCM_PACK (copy.key); + } + + if (set->n_items > set->upper) + /* Full set, time to resize. */ + { + resize_set (set); + return weak_set_add_x (set, hash >> 1, pred, closure, obj); + } + + /* Displace the entry if our distance is less, otherwise keep + looking. */ + if (entry_distance (other_hash, k, size) < distance) + { + rob_from_rich (set, k); + break; + } + } + + set->n_items++; + entries[k].hash = hash; + entries[k].key = SCM_UNPACK (obj); + + if (SCM_HEAP_OBJECT_P (obj)) + SCM_I_REGISTER_DISAPPEARING_LINK ((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], ©); + + 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], ©); + + 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, ©); + to->hash = copy.hash; + to->key = copy.key; + to->value = copy.value; + + move_disappearing_links (from, to, + SCM_PACK (copy.key), SCM_PACK (copy.value), + kind); + } + else + { + to->hash = 0; + to->key = 0; + to->value = 0; + } +} + + +typedef struct { + scm_t_weak_entry *entries; /* the data */ + scm_i_pthread_mutex_t lock; /* the lock */ + scm_t_weak_table_kind kind; /* what kind of table it is */ + unsigned long size; /* total number of slots. */ + unsigned long n_items; /* number of items in table */ + unsigned long lower; /* when to shrink */ + unsigned long upper; /* when to grow */ + int size_index; /* index into hashtable_size */ + int min_size_index; /* minimum size_index */ +} scm_t_weak_table; + + +#define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_table)) +#define SCM_VALIDATE_WEAK_TABLE(pos, arg) \ + SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_TABLE_P, "weak-table") +#define SCM_WEAK_TABLE(x) ((scm_t_weak_table *) SCM_CELL_WORD_1 (x)) + + +static unsigned long +hash_to_index (unsigned long hash, unsigned long size) +{ + return (hash >> 1) % size; +} + +static unsigned long +entry_distance (unsigned long hash, unsigned long k, unsigned long size) +{ + unsigned long origin = hash_to_index (hash, size); + + if (k >= origin) + return k - origin; + else + /* The other key was displaced and wrapped around. */ + return size - origin + k; +} + +static void +rob_from_rich (scm_t_weak_table *table, unsigned long k) +{ + unsigned long empty, size; + + size = table->size; + + /* If we are to free up slot K in the table, we need room to do so. */ + assert (table->n_items < size); + + empty = k; + do + empty = (empty + 1) % size; + while (table->entries[empty].hash); + + do + { + unsigned long last = empty ? (empty - 1) : (size - 1); + move_weak_entry (&table->entries[last], &table->entries[empty], + table->kind); + empty = last; + } + while (empty != k); + + table->entries[empty].hash = 0; + table->entries[empty].key = 0; + table->entries[empty].value = 0; +} + +static void +give_to_poor (scm_t_weak_table *table, unsigned long k) +{ + /* Slot K was just freed up; possibly shuffle others down. */ + unsigned long size = table->size; + + while (1) + { + unsigned long next = (k + 1) % size; + unsigned long hash; + scm_t_weak_entry copy; + + hash = table->entries[next].hash; + + if (!hash || hash_to_index (hash, size) == next) + break; + + copy_weak_entry (&table->entries[next], ©); + + if (!copy.key || !copy.value) + /* Lost weak reference. */ + { + give_to_poor (table, next); + table->n_items--; + continue; + } + + move_weak_entry (&table->entries[next], &table->entries[k], + table->kind); + + k = next; + } + + /* We have shuffled down any entries that should be shuffled down; now + free the end. */ + table->entries[k].hash = 0; + table->entries[k].key = 0; + table->entries[k].value = 0; +} + + + + +/* The GC "kinds" for singly-weak tables. */ +static int weak_key_gc_kind; +static int weak_value_gc_kind; + +static struct GC_ms_entry * +mark_weak_key_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, + struct GC_ms_entry *mark_stack_limit, GC_word env) +{ + scm_t_weak_entry *entries = (scm_t_weak_entry*) addr; + unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry); + + for (k = 0; k < size; k++) + if (entries[k].hash && entries[k].key) + { + SCM value = SCM_PACK (entries[k].value); + mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) 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], ©); + + if (!copy.key || !copy.value) + continue; + + new_k = hash_to_index (copy.hash, new_size); + + for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size) + { + unsigned long other_hash = new_entries[new_k].hash; + + if (!other_hash) + /* Found an empty entry. */ + break; + + /* Displace the entry if our distance is less, otherwise keep + looking. */ + if (entry_distance (other_hash, new_k, new_size) < distance) + { + rob_from_rich (table, new_k); + break; + } + } + + table->n_items++; + new_entries[new_k].hash = copy.hash; + new_entries[new_k].key = copy.key; + new_entries[new_k].value = copy.value; + + register_disappearing_links (&new_entries[new_k], + SCM_PACK (copy.key), SCM_PACK (copy.value), + table->kind); + } +} + +/* Run after GC via do_vacuum_weak_table, this function runs over the + whole table, removing lost weak references, reshuffling the table as it + goes. It might resize the table if it reaps enough entries. */ +static void +vacuum_weak_table (scm_t_weak_table *table) +{ + scm_t_weak_entry *entries = table->entries; + unsigned long size = table->size; + unsigned long k; + + for (k = 0; k < size; k++) + { + unsigned long hash = entries[k].hash; + + if (hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key || !copy.value) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (table, k); + table->n_items--; + } + } + } + + if (table->n_items < table->lower) + resize_table (table); +} + + + + +static SCM +weak_table_ref (scm_t_weak_table *table, unsigned long hash, + scm_t_table_predicate_fn pred, void *closure, + SCM dflt) +{ + unsigned long k, distance, size; + scm_t_weak_entry *entries; + + size = table->size; + entries = table->entries; + + hash = (hash << 1) | 0x1; + k = hash_to_index (hash, size); + + for (distance = 0; distance < size; distance++, k = (k + 1) % size) + { + unsigned long other_hash; + + retry: + other_hash = entries[k].hash; + + if (!other_hash) + /* Not found. */ + return dflt; + + if (hash == other_hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key || !copy.value) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (table, k); + table->n_items--; + goto retry; + } + + if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) + /* Found. */ + return SCM_PACK (copy.value); + } + + /* If the entry's distance is less, our key is not in the table. */ + if (entry_distance (other_hash, k, size) < distance) + return dflt; + } + + /* If we got here, then we were unfortunate enough to loop through the + whole table. Shouldn't happen, but hey. */ + return dflt; +} + + +static void +weak_table_put_x (scm_t_weak_table *table, unsigned long hash, + scm_t_table_predicate_fn pred, void *closure, + SCM key, SCM value) +{ + unsigned long k, distance, size; + scm_t_weak_entry *entries; + + size = table->size; + entries = table->entries; + + hash = (hash << 1) | 0x1; + k = hash_to_index (hash, size); + + for (distance = 0; ; distance++, k = (k + 1) % size) + { + unsigned long other_hash; + + retry: + other_hash = entries[k].hash; + + if (!other_hash) + /* Found an empty entry. */ + break; + + if (other_hash == hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key || !copy.value) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (table, k); + table->n_items--; + goto retry; + } + + if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) + /* Found an entry with this key. */ + break; + } + + if (table->n_items > table->upper) + /* Full table, time to resize. */ + { + resize_table (table); + return weak_table_put_x (table, hash >> 1, pred, closure, key, value); + } + + /* Displace the entry if our distance is less, otherwise keep + looking. */ + if (entry_distance (other_hash, k, size) < distance) + { + rob_from_rich (table, k); + break; + } + } + + if (entries[k].hash) + unregister_disappearing_links (&entries[k], table->kind); + else + table->n_items++; + + entries[k].hash = hash; + entries[k].key = SCM_UNPACK (key); + entries[k].value = SCM_UNPACK (value); + + register_disappearing_links (&entries[k], key, value, table->kind); +} + + +static void +weak_table_remove_x (scm_t_weak_table *table, unsigned long hash, + scm_t_table_predicate_fn pred, void *closure) +{ + unsigned long k, distance, size; + scm_t_weak_entry *entries; + + size = table->size; + entries = table->entries; + + hash = (hash << 1) | 0x1; + k = hash_to_index (hash, size); + + for (distance = 0; distance < size; distance++, k = (k + 1) % size) + { + unsigned long other_hash; + + retry: + other_hash = entries[k].hash; + + if (!other_hash) + /* Not found. */ + return; + + if (other_hash == hash) + { + scm_t_weak_entry copy; + + copy_weak_entry (&entries[k], ©); + + if (!copy.key || !copy.value) + /* Lost weak reference; reshuffle. */ + { + give_to_poor (table, k); + table->n_items--; + goto retry; + } + + if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure)) + /* Found an entry with this key. */ + { + entries[k].hash = 0; + entries[k].key = 0; + entries[k].value = 0; + + unregister_disappearing_links (&entries[k], table->kind); + + if (--table->n_items < table->lower) + resize_table (table); + else + give_to_poor (table, k); + + return; + } + } + + /* If the entry's distance is less, our key is not in the table. */ + if (entry_distance (other_hash, k, size) < distance) + return; + } +} + + + +static SCM +make_weak_table (unsigned long k, scm_t_weak_table_kind kind) +{ + scm_t_weak_table *table; + + int i = 0, n = k ? k : 31; + while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i]) + ++i; + n = hashtable_size[i]; + + table = scm_gc_malloc (sizeof (*table), "weak-table"); + table->entries = allocate_entries (n, kind); + table->kind = kind; + table->n_items = 0; + table->size = n; + table->lower = 0; + table->upper = 9 * n / 10; + table->size_index = i; + table->min_size_index = i; + scm_i_pthread_mutex_init (&table->lock, NULL); + + return scm_cell (scm_tc7_weak_table, (scm_t_bits)table); +} + +void +scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate) +{ + scm_puts_unlocked ("#<", port); + scm_puts_unlocked ("weak-table ", port); + scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port); + scm_putc_unlocked ('/', port); + scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port); + scm_puts_unlocked (">", port); +} + +static void +do_vacuum_weak_table (SCM table) +{ + scm_t_weak_table *t; + + t = SCM_WEAK_TABLE (table); + + 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], ©); + + 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 f706f0e68..3bc84fd34 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -68,6 +68,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 03dad9b0d..5395ed1f9 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -865,15 +865,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))))) @@ -952,16 +948,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)))) @@ -1572,7 +1565,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))) @@ -2049,33 +2042,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} @@ -3268,13 +3234,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) @@ -3804,13 +3763,13 @@ module '(ice-9 q) '(make-q q-length))}." ((args ...) (generate-temporaries #'(formals ...)))) #`(begin (define (proc-name formals ...) - (fluid-let-syntax ((name (identifier-syntax proc-name))) + (syntax-parameterize ((name (identifier-syntax proc-name))) body ...)) - (define-syntax name + (define-syntax-parameter name (lambda (x) (syntax-case x () ((_ args ...) - #'((fluid-let-syntax ((name (identifier-syntax proc-name))) + #'((syntax-parameterize ((name (identifier-syntax proc-name))) (lambda (formals ...) body ...)) args ...)) diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index 4628bab98..6b39e7a7c 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -16,856 +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)) - - -;;;; 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))))))) + #: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 f7e315def..43a2cf567 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -2,1652 +2,1999 @@ (if #f #f) (letrec* - ((#{top-level-eval-hook 4262}# - (lambda (#{x 27369}# #{mod 27370}#) - (primitive-eval #{x 27369}#))) - (#{maybe-name-value! 4267}# - (lambda (#{name 16133}# #{val 16134}#) - (if (if (struct? #{val 16134}#) - (eq? (struct-vtable #{val 16134}#) - (vector-ref %expanded-vtables 13)) + ((#{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 16141}# (struct-ref #{val 16134}# 1))) - (if (not (assq 'name #{meta 16141}#)) - (let ((#{v 16146}# - (cons (cons 'name #{name 16133}#) #{meta 16141}#))) - (struct-set! #{val 16134}# 1 #{v 16146}#))))))) - (#{build-application 4269}# - (lambda (#{source 15858}# - #{fun-exp 15859}# - #{arg-exps 15860}#) + (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 15858}# - #{fun-exp 15859}# - #{arg-exps 15860}#))) - (#{build-conditional 4270}# - (lambda (#{source 15866}# - #{test-exp 15867}# - #{then-exp 15868}# - #{else-exp 15869}#) + #{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 15866}# - #{test-exp 15867}# - #{then-exp 15868}# - #{else-exp 15869}#))) - (#{build-dynlet 4271}# - (lambda (#{source 15876}# - #{fluids 15877}# - #{vals 15878}# - #{body 15879}#) + #{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 17) - #{source 15876}# - #{fluids 15877}# - #{vals 15878}# - #{body 15879}#))) - (#{build-lexical-reference 4272}# - (lambda (#{type 27371}# - #{source 27372}# - #{name 27373}# - #{var 27374}#) + (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 27372}# - #{name 27373}# - #{var 27374}#))) - (#{build-lexical-assignment 4273}# - (lambda (#{source 15886}# - #{name 15887}# - #{var 15888}# - #{exp 15889}#) + #{source 59001}# + #{name 59002}# + #{var 59003}#))) + (#{build-lexical-assignment 28209}# + (lambda (#{source 42324}# + #{name 42325}# + #{var 42326}# + #{exp 42327}#) (begin - (if (if (struct? #{exp 15889}#) - (eq? (struct-vtable #{exp 15889}#) - (vector-ref %expanded-vtables 13)) + (if (if (struct? #{exp 42327}#) + (eq? (struct-vtable #{exp 42327}#) + (vector-ref %expanded-vtables 14)) #f) - (let ((#{meta 15905}# (struct-ref #{exp 15889}# 1))) - (if (not (assq 'name #{meta 15905}#)) - (let ((#{v 15912}# - (cons (cons 'name #{name 15887}#) #{meta 15905}#))) - (struct-set! #{exp 15889}# 1 #{v 15912}#))))) + (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 4) - #{source 15886}# - #{name 15887}# - #{var 15888}# - #{exp 15889}#)))) - (#{analyze-variable 4274}# - (lambda (#{mod 27380}# - #{var 27381}# - #{modref-cont 27382}# - #{bare-cont 27383}#) - (if (not #{mod 27380}#) - (#{bare-cont 27383}# #{var 27381}#) - (let ((#{kind 27384}# (car #{mod 27380}#)) - (#{mod 27385}# (cdr #{mod 27380}#))) - (if (eqv? #{kind 27384}# 'public) - (#{modref-cont 27382}# - #{mod 27385}# - #{var 27381}# + #{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 27384}# 'private) + (if (eqv? #{kind 59013}# 'private) (if (not (equal? - #{mod 27385}# + #{mod 59014}# (module-name (current-module)))) - (#{modref-cont 27382}# - #{mod 27385}# - #{var 27381}# + (#{modref-cont 59011}# + #{mod 59014}# + #{var 59010}# #f) - (#{bare-cont 27383}# #{var 27381}#)) - (if (eqv? #{kind 27384}# 'bare) - (#{bare-cont 27383}# #{var 27381}#) - (if (eqv? #{kind 27384}# 'hygiene) + (#{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 27385}# + #{mod 59014}# (module-name (current-module)))) (module-variable - (resolve-module #{mod 27385}#) - #{var 27381}#) + (resolve-module #{mod 59014}#) + #{var 59010}#) #f) - (#{modref-cont 27382}# - #{mod 27385}# - #{var 27381}# + (#{modref-cont 59011}# + #{mod 59014}# + #{var 59010}# #f) - (#{bare-cont 27383}# #{var 27381}#)) + (#{bare-cont 59012}# #{var 59010}#)) (syntax-violation #f "bad module kind" - #{var 27381}# - #{mod 27385}#))))))))) - (#{build-global-reference 4275}# - (lambda (#{source 27400}# #{var 27401}# #{mod 27402}#) - (#{analyze-variable 4274}# - #{mod 27402}# - #{var 27401}# - (lambda (#{mod 27405}# #{var 27406}# #{public? 27407}#) + #{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 27400}# - #{mod 27405}# - #{var 27406}# - #{public? 27407}#)) - (lambda (#{var 27415}#) + #{source 59029}# + #{mod 59034}# + #{var 59035}# + #{public? 59036}#)) + (lambda (#{var 59043}#) (make-struct/no-tail (vector-ref %expanded-vtables 7) - #{source 27400}# - #{var 27415}#))))) - (#{build-global-assignment 4276}# - (lambda (#{source 15921}# - #{var 15922}# - #{exp 15923}# - #{mod 15924}#) + #{source 59029}# + #{var 59043}#))))) + (#{build-global-assignment 28212}# + (lambda (#{source 42359}# + #{var 42360}# + #{exp 42361}# + #{mod 42362}#) (begin - (if (if (struct? #{exp 15923}#) - (eq? (struct-vtable #{exp 15923}#) - (vector-ref %expanded-vtables 13)) + (if (if (struct? #{exp 42361}#) + (eq? (struct-vtable #{exp 42361}#) + (vector-ref %expanded-vtables 14)) #f) - (let ((#{meta 15940}# (struct-ref #{exp 15923}# 1))) - (if (not (assq 'name #{meta 15940}#)) - (let ((#{v 15947}# - (cons (cons 'name #{var 15922}#) #{meta 15940}#))) - (struct-set! #{exp 15923}# 1 #{v 15947}#))))) - (#{analyze-variable 4274}# - #{mod 15924}# - #{var 15922}# - (lambda (#{mod 15952}# #{var 15953}# #{public? 15954}#) + (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 6) - #{source 15921}# - #{mod 15952}# - #{var 15953}# - #{public? 15954}# - #{exp 15923}#)) - (lambda (#{var 15962}#) + #{source 42359}# + #{mod 42390}# + #{var 42391}# + #{public? 42392}# + #{exp 42361}#)) + (lambda (#{var 42400}#) (make-struct/no-tail (vector-ref %expanded-vtables 8) - #{source 15921}# - #{var 15962}# - #{exp 15923}#)))))) - (#{build-global-definition 4277}# - (lambda (#{source 27421}# #{var 27422}# #{exp 27423}#) + #{source 42359}# + #{var 42400}# + #{exp 42361}#)))))) + (#{build-global-definition 28213}# + (lambda (#{source 59048}# #{var 59049}# #{exp 59050}#) (begin - (if (if (struct? #{exp 27423}#) - (eq? (struct-vtable #{exp 27423}#) - (vector-ref %expanded-vtables 13)) + (if (if (struct? #{exp 59050}#) + (eq? (struct-vtable #{exp 59050}#) + (vector-ref %expanded-vtables 14)) #f) - (let ((#{meta 27439}# (struct-ref #{exp 27423}# 1))) - (if (not (assq 'name #{meta 27439}#)) - (let ((#{v 27446}# - (cons (cons 'name #{var 27422}#) #{meta 27439}#))) - (struct-set! #{exp 27423}# 1 #{v 27446}#))))) + (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 27421}# - #{var 27422}# - #{exp 27423}#)))) - (#{build-simple-lambda 4278}# - (lambda (#{src 15968}# - #{req 15969}# - #{rest 15970}# - #{vars 15971}# - #{meta 15972}# - #{exp 15973}#) - (let ((#{body 15979}# + #{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 14) - #{src 15968}# - #{req 15969}# + (vector-ref %expanded-vtables 15) + #{src 42406}# + #{req 42407}# #f - #{rest 15970}# + #{rest 42408}# #f '() - #{vars 15971}# - #{exp 15973}# + #{vars 42409}# + #{exp 42411}# #f))) (make-struct/no-tail - (vector-ref %expanded-vtables 13) - #{src 15968}# - #{meta 15972}# - #{body 15979}#)))) - (#{build-sequence 4283}# - (lambda (#{src 27454}# #{exps 27455}#) - (if (null? (cdr #{exps 27455}#)) - (car #{exps 27455}#) - (make-struct/no-tail - (vector-ref %expanded-vtables 12) - #{src 27454}# - #{exps 27455}#)))) - (#{build-let 4284}# - (lambda (#{src 15991}# - #{ids 15992}# - #{vars 15993}# - #{val-exps 15994}# - #{body-exp 15995}#) - (begin - (for-each - #{maybe-name-value! 4267}# - #{ids 15992}# - #{val-exps 15994}#) - (if (null? #{vars 15993}#) - #{body-exp 15995}# + (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 + (cdr #{exps 59082}#)))) (make-struct/no-tail - (vector-ref %expanded-vtables 15) - #{src 15991}# - #{ids 15992}# - #{vars 15993}# - #{val-exps 15994}# - #{body-exp 15995}#))))) - (#{build-named-let 4285}# - (lambda (#{src 16019}# - #{ids 16020}# - #{vars 16021}# - #{val-exps 16022}# - #{body-exp 16023}#) - (let ((#{f 16024}# (car #{vars 16021}#)) - (#{f-name 16025}# (car #{ids 16020}#)) - (#{vars 16026}# (cdr #{vars 16021}#)) - (#{ids 16027}# (cdr #{ids 16020}#))) - (let ((#{proc 16028}# - (let ((#{body 16048}# + (vector-ref %expanded-vtables 13) + #{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 14) - #{src 16019}# - #{ids 16027}# + (vector-ref %expanded-vtables 15) + #{src 42437}# + #{ids 42445}# #f #f #f '() - #{vars 16026}# - #{body-exp 16023}# + #{vars 42444}# + #{body-exp 42441}# #f))) (make-struct/no-tail - (vector-ref %expanded-vtables 13) - #{src 16019}# + (vector-ref %expanded-vtables 14) + #{src 42437}# '() - #{body 16048}#)))) + #{body 42466}#)))) (begin - (if (if (struct? #{proc 16028}#) - (eq? (struct-vtable #{proc 16028}#) - (vector-ref %expanded-vtables 13)) + (if (if (struct? #{proc 42446}#) + (eq? (struct-vtable #{proc 42446}#) + (vector-ref %expanded-vtables 14)) #f) - (let ((#{meta 16072}# (struct-ref #{proc 16028}# 1))) - (if (not (assq 'name #{meta 16072}#)) - (let ((#{v 16079}# - (cons (cons 'name #{f-name 16025}#) - #{meta 16072}#))) - (struct-set! #{proc 16028}# 1 #{v 16079}#))))) + (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! 4267}# - #{ids 16027}# - #{val-exps 16022}#) - (let ((#{names 16103}# (list #{f-name 16025}#)) - (#{gensyms 16104}# (list #{f 16024}#)) - (#{vals 16105}# (list #{proc 16028}#)) - (#{body 16106}# - (let ((#{fun-exp 16110}# + #{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 16019}# - #{f-name 16025}# - #{f 16024}#))) + #{src 42437}# + #{f-name 42443}# + #{f 42442}#))) (make-struct/no-tail (vector-ref %expanded-vtables 11) - #{src 16019}# - #{fun-exp 16110}# - #{val-exps 16022}#)))) + #{src 42437}# + #{fun-exp 42528}# + #{val-exps 42440}#)))) (make-struct/no-tail - (vector-ref %expanded-vtables 16) - #{src 16019}# + (vector-ref %expanded-vtables 17) + #{src 42437}# #f - #{names 16103}# - #{gensyms 16104}# - #{vals 16105}# - #{body 16106}#))))))) - (#{build-letrec 4286}# - (lambda (#{src 16126}# - #{in-order? 16127}# - #{ids 16128}# - #{vars 16129}# - #{val-exps 16130}# - #{body-exp 16131}#) - (if (null? #{vars 16129}#) - #{body-exp 16131}# + #{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! 4267}# - #{ids 16128}# - #{val-exps 16130}#) + #{maybe-name-value! 28203}# + #{ids 42546}# + #{val-exps 42548}#) (make-struct/no-tail - (vector-ref %expanded-vtables 16) - #{src 16126}# - #{in-order? 16127}# - #{ids 16128}# - #{vars 16129}# - #{val-exps 16130}# - #{body-exp 16131}#))))) - (#{source-annotation 4295}# - (lambda (#{x 16157}#) - (if (if (vector? #{x 16157}#) - (if (= (vector-length #{x 16157}#) 4) - (eq? (vector-ref #{x 16157}# 0) 'syntax-object) + (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 4295}# - (vector-ref #{x 16157}# 1)) - (if (pair? #{x 16157}#) - (let ((#{props 16172}# (source-properties #{x 16157}#))) - (if (pair? #{props 16172}#) #{props 16172}# #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 4296}# - (lambda (#{labels 16174}# #{bindings 16175}# #{r 16176}#) - (if (null? #{labels 16174}#) - #{r 16176}# - (#{extend-env 4296}# - (cdr #{labels 16174}#) - (cdr #{bindings 16175}#) - (cons (cons (car #{labels 16174}#) - (car #{bindings 16175}#)) - #{r 16176}#))))) - (#{extend-var-env 4297}# - (lambda (#{labels 16177}# #{vars 16178}# #{r 16179}#) - (if (null? #{labels 16177}#) - #{r 16179}# - (#{extend-var-env 4297}# - (cdr #{labels 16177}#) - (cdr #{vars 16178}#) - (cons (cons (car #{labels 16177}#) - (cons 'lexical (car #{vars 16178}#))) - #{r 16179}#))))) - (#{macros-only-env 4298}# - (lambda (#{r 16180}#) - (if (null? #{r 16180}#) + (#{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 16181}# (car #{r 16180}#))) - (if (eq? (car (cdr #{a 16181}#)) 'macro) - (cons #{a 16181}# - (#{macros-only-env 4298}# (cdr #{r 16180}#))) - (#{macros-only-env 4298}# (cdr #{r 16180}#))))))) - (#{global-extend 4300}# - (lambda (#{type 16183}# #{sym 16184}# #{val 16185}#) + (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 16184}# + #{sym 42605}# (make-syntax-transformer - #{sym 16184}# - #{type 16183}# - #{val 16185}#)))) - (#{id? 4302}# - (lambda (#{x 10359}#) - (if (symbol? #{x 10359}#) + #{sym 42605}# + #{type 42604}# + #{val 42606}#)))) + (#{id? 28238}# + (lambda (#{x 35679}#) + (if (symbol? #{x 35679}#) #t - (if (if (vector? #{x 10359}#) - (if (= (vector-length #{x 10359}#) 4) - (eq? (vector-ref #{x 10359}# 0) 'syntax-object) + (if (if (vector? #{x 35679}#) + (if (= (vector-length #{x 35679}#) 4) + (eq? (vector-ref #{x 35679}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{x 10359}# 1)) + (symbol? (vector-ref #{x 35679}# 1)) #f)))) - (#{gen-labels 4305}# - (lambda (#{ls 16195}#) - (if (null? #{ls 16195}#) + (#{gen-labels 28241}# + (lambda (#{ls 42616}#) + (if (null? #{ls 42616}#) '() (cons (symbol->string (gensym "i")) - (#{gen-labels 4305}# (cdr #{ls 16195}#)))))) - (#{make-binding-wrap 4316}# - (lambda (#{ids 16199}# #{labels 16200}# #{w 16201}#) - (if (null? #{ids 16199}#) - #{w 16201}# - (cons (car #{w 16201}#) - (cons (let ((#{labelvec 16202}# - (list->vector #{labels 16200}#))) - (let ((#{n 16203}# (vector-length #{labelvec 16202}#))) - (let ((#{symnamevec 16204}# (make-vector #{n 16203}#)) - (#{marksvec 16205}# (make-vector #{n 16203}#))) + (#{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 16206}# - (lambda (#{ids 16209}# #{i 16210}#) - (if (not (null? #{ids 16209}#)) + ((#{f 42627}# + (lambda (#{ids 42824}# #{i 42825}#) + (if (not (null? #{ids 42824}#)) (call-with-values (lambda () - (let ((#{x 16213}# - (car #{ids 16209}#))) - (if (if (vector? #{x 16213}#) + (let ((#{x 42828}# + (car #{ids 42824}#))) + (if (if (vector? #{x 42828}#) (if (= (vector-length - #{x 16213}#) + #{x 42828}#) 4) (eq? (vector-ref - #{x 16213}# + #{x 42828}# 0) 'syntax-object) #f) #f) (values - (vector-ref #{x 16213}# 1) - (let ((#{m1 16229}# - (car #{w 16201}#)) - (#{m2 16230}# + (vector-ref #{x 42828}# 1) + (let ((#{m1 42844}# + (car #{w 42622}#)) + (#{m2 42845}# (car (vector-ref - #{x 16213}# + #{x 42828}# 2)))) - (if (null? #{m2 16230}#) - #{m1 16229}# + (if (null? #{m2 42845}#) + #{m1 42844}# (append - #{m1 16229}# - #{m2 16230}#)))) + #{m1 42844}# + #{m2 42845}#)))) (values - #{x 16213}# - (car #{w 16201}#))))) - (lambda (#{symname 16250}# - #{marks 16251}#) + #{x 42828}# + (car #{w 42622}#))))) + (lambda (#{symname 42865}# + #{marks 42866}#) (begin (vector-set! - #{symnamevec 16204}# - #{i 16210}# - #{symname 16250}#) + #{symnamevec 42625}# + #{i 42825}# + #{symname 42865}#) (vector-set! - #{marksvec 16205}# - #{i 16210}# - #{marks 16251}#) - (#{f 16206}# - (cdr #{ids 16209}#) - (#{1+}# #{i 16210}#))))))))) - (#{f 16206}# #{ids 16199}# 0)) + #{marksvec 42626}# + #{i 42825}# + #{marks 42866}#) + (#{f 42627}# + (cdr #{ids 42824}#) + (#{1+}# #{i 42825}#))))))))) + (#{f 42627}# #{ids 42620}# 0)) (vector 'ribcage - #{symnamevec 16204}# - #{marksvec 16205}# - #{labelvec 16202}#))))) - (cdr #{w 16201}#)))))) - (#{join-wraps 4318}# - (lambda (#{w1 16260}# #{w2 16261}#) - (let ((#{m1 16262}# (car #{w1 16260}#)) - (#{s1 16263}# (cdr #{w1 16260}#))) - (if (null? #{m1 16262}#) - (if (null? #{s1 16263}#) - #{w2 16261}# - (cons (car #{w2 16261}#) - (let ((#{m2 16270}# (cdr #{w2 16261}#))) - (if (null? #{m2 16270}#) - #{s1 16263}# - (append #{s1 16263}# #{m2 16270}#))))) - (cons (let ((#{m2 16279}# (car #{w2 16261}#))) - (if (null? #{m2 16279}#) - #{m1 16262}# - (append #{m1 16262}# #{m2 16279}#))) - (let ((#{m2 16288}# (cdr #{w2 16261}#))) - (if (null? #{m2 16288}#) - #{s1 16263}# - (append #{s1 16263}# #{m2 16288}#)))))))) - (#{same-marks? 4320}# - (lambda (#{x 16293}# #{y 16294}#) - (if (eq? #{x 16293}# #{y 16294}#) - (eq? #{x 16293}# #{y 16294}#) - (if (not (null? #{x 16293}#)) - (if (not (null? #{y 16294}#)) - (if (eq? (car #{x 16293}#) (car #{y 16294}#)) - (#{same-marks? 4320}# - (cdr #{x 16293}#) - (cdr #{y 16294}#)) + #{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 4321}# - (lambda (#{id 16302}# #{w 16303}#) + (#{id-var-name 28257}# + (lambda (#{id 59097}# #{w 59098}# #{mod 59099}#) (letrec* - ((#{search 16304}# - (lambda (#{sym 16365}# #{subst 16366}# #{marks 16367}#) - (if (null? #{subst 16366}#) - (values #f #{marks 16367}#) - (let ((#{fst 16368}# (car #{subst 16366}#))) - (if (eq? #{fst 16368}# 'shift) - (#{search 16304}# - #{sym 16365}# - (cdr #{subst 16366}#) - (cdr #{marks 16367}#)) - (let ((#{symnames 16370}# (vector-ref #{fst 16368}# 1))) - (if (vector? #{symnames 16370}#) - (let ((#{n 16382}# (vector-length #{symnames 16370}#))) - (letrec* - ((#{f 16383}# - (lambda (#{i 16385}#) - (if (= #{i 16385}# #{n 16382}#) - (#{search 16304}# - #{sym 16365}# - (cdr #{subst 16366}#) - #{marks 16367}#) - (if (if (eq? (vector-ref - #{symnames 16370}# - #{i 16385}#) - #{sym 16365}#) - (#{same-marks? 4320}# - #{marks 16367}# - (vector-ref - (vector-ref #{fst 16368}# 2) - #{i 16385}#)) - #f) - (values - (vector-ref - (vector-ref #{fst 16368}# 3) - #{i 16385}#) - #{marks 16367}#) - (#{f 16383}# (#{1+}# #{i 16385}#))))))) - (#{f 16383}# 0))) - (letrec* - ((#{f 16418}# - (lambda (#{symnames 16420}# #{i 16421}#) - (if (null? #{symnames 16420}#) - (#{search 16304}# - #{sym 16365}# - (cdr #{subst 16366}#) - #{marks 16367}#) - (if (if (eq? (car #{symnames 16420}#) - #{sym 16365}#) - (#{same-marks? 4320}# - #{marks 16367}# - (list-ref - (vector-ref #{fst 16368}# 2) - #{i 16421}#)) - #f) - (values - (list-ref - (vector-ref #{fst 16368}# 3) - #{i 16421}#) - #{marks 16367}#) - (#{f 16418}# - (cdr #{symnames 16420}#) - (#{1+}# #{i 16421}#))))))) - (#{f 16418}# #{symnames 16370}# 0)))))))))) - (if (symbol? #{id 16302}#) - (let ((#{t 16307}# - (#{search 16304}# - #{id 16302}# - (cdr #{w 16303}#) - (car #{w 16303}#)))) - (if #{t 16307}# #{t 16307}# #{id 16302}#)) - (if (if (vector? #{id 16302}#) - (if (= (vector-length #{id 16302}#) 4) - (eq? (vector-ref #{id 16302}# 0) 'syntax-object) + ((#{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) - (let ((#{id 16322}# (vector-ref #{id 16302}# 1)) - (#{w1 16323}# (vector-ref #{id 16302}# 2))) - (let ((#{marks 16324}# - (let ((#{m1 16334}# (car #{w 16303}#)) - (#{m2 16335}# (car #{w1 16323}#))) - (if (null? #{m2 16335}#) - #{m1 16334}# - (append #{m1 16334}# #{m2 16335}#))))) + (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 16304}# - #{id 16322}# - (cdr #{w 16303}#) - #{marks 16324}#)) - (lambda (#{new-id 16351}# #{marks 16352}#) - (if #{new-id 16351}# - #{new-id 16351}# - (let ((#{t 16360}# - (#{search 16304}# - #{id 16322}# - (cdr #{w1 16323}#) - #{marks 16352}#))) - (if #{t 16360}# #{t 16360}# #{id 16322}#))))))) + (#{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 16302}#)))))) - (#{valid-bound-ids? 4324}# - (lambda (#{ids 16443}#) + #{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) + (#{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) + (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) + (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) + #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) + #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? 16444}# - (lambda (#{ids 16606}#) - (if (null? #{ids 16606}#) - (null? #{ids 16606}#) - (if (let ((#{x 16617}# (car #{ids 16606}#))) - (if (symbol? #{x 16617}#) + ((#{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 16617}#) - (if (= (vector-length #{x 16617}#) 4) - (eq? (vector-ref #{x 16617}# 0) + (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 16617}# 1)) + (symbol? (vector-ref #{x 43642}# 1)) #f))) - (#{all-ids? 16444}# (cdr #{ids 16606}#)) + (#{all-ids? 43434}# (cdr #{ids 43631}#)) #f))))) - (#{all-ids? 16444}# #{ids 16443}#)) - (#{distinct-bound-ids? 4325}# #{ids 16443}#) + (#{all-ids? 43434}# #{ids 43433}#)) + (#{distinct-bound-ids? 28262}# #{ids 43433}#) #f))) - (#{distinct-bound-ids? 4325}# - (lambda (#{ids 16745}#) + (#{distinct-bound-ids? 28262}# + (lambda (#{ids 43763}#) (letrec* - ((#{distinct? 16746}# - (lambda (#{ids 16858}#) - (if (null? #{ids 16858}#) - (null? #{ids 16858}#) - (if (not (#{bound-id-member? 4326}# - (car #{ids 16858}#) - (cdr #{ids 16858}#))) - (#{distinct? 16746}# (cdr #{ids 16858}#)) + ((#{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? 16746}# #{ids 16745}#)))) - (#{bound-id-member? 4326}# - (lambda (#{x 17068}# #{list 17069}#) - (if (not (null? #{list 17069}#)) - (let ((#{t 17070}# - (let ((#{j 17151}# (car #{list 17069}#))) - (if (if (if (vector? #{x 17068}#) - (if (= (vector-length #{x 17068}#) 4) - (eq? (vector-ref #{x 17068}# 0) 'syntax-object) - #f) - #f) - (if (vector? #{j 17151}#) - (if (= (vector-length #{j 17151}#) 4) - (eq? (vector-ref #{j 17151}# 0) 'syntax-object) - #f) - #f) - #f) - (if (eq? (vector-ref #{x 17068}# 1) - (vector-ref #{j 17151}# 1)) - (#{same-marks? 4320}# - (car (vector-ref #{x 17068}# 2)) - (car (vector-ref #{j 17151}# 2))) - #f) - (eq? #{x 17068}# #{j 17151}#))))) - (if #{t 17070}# - #{t 17070}# - (#{bound-id-member? 4326}# - #{x 17068}# - (cdr #{list 17069}#)))) + (#{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))) - (#{wrap 4327}# - (lambda (#{x 17195}# #{w 17196}# #{defmod 17197}#) - (if (if (null? (car #{w 17196}#)) - (null? (cdr #{w 17196}#)) - #f) - #{x 17195}# - (if (if (vector? #{x 17195}#) - (if (= (vector-length #{x 17195}#) 4) - (eq? (vector-ref #{x 17195}# 0) 'syntax-object) - #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) - (let ((#{expression 17211}# (vector-ref #{x 17195}# 1)) - (#{wrap 17212}# - (#{join-wraps 4318}# - #{w 17196}# - (vector-ref #{x 17195}# 2))) - (#{module 17213}# (vector-ref #{x 17195}# 3))) - (vector - 'syntax-object - #{expression 17211}# - #{wrap 17212}# - #{module 17213}#)) - (if (null? #{x 17195}#) - #{x 17195}# - (vector - 'syntax-object - #{x 17195}# - #{w 17196}# - #{defmod 17197}#)))))) - (#{source-wrap 4328}# - (lambda (#{x 17230}# - #{w 17231}# - #{s 17232}# - #{defmod 17233}#) - (#{wrap 4327}# - (begin - (if (if (pair? #{x 17230}#) #{s 17232}# #f) - (set-source-properties! #{x 17230}# #{s 17232}#)) - #{x 17230}#) - #{w 17231}# - #{defmod 17233}#))) - (#{expand-sequence 4329}# - (lambda (#{body 27460}# - #{r 27461}# - #{w 27462}# - #{s 27463}# - #{mod 27464}#) - (#{build-sequence 4283}# - #{s 27463}# + #{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 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 44184}# + #{wrap 44185}# + #{module 44186}#)) + (if (null? #{x 44152}#) + #{x 44152}# + (vector + 'syntax-object + #{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* - ((#{dobody 27544}# - (lambda (#{body 27894}# - #{r 27895}# - #{w 27896}# - #{mod 27897}#) - (if (null? #{body 27894}#) + ((#{dobody 59762}# + (lambda (#{body 59845}# + #{r 59846}# + #{w 59847}# + #{mod 59848}#) + (if (null? #{body 59845}#) '() - (let ((#{first 27898}# - (let ((#{e 27902}# (car #{body 27894}#))) - (call-with-values - (lambda () - (#{syntax-type 4333}# - #{e 27902}# - #{r 27895}# - #{w 27896}# - (#{source-annotation 4295}# #{e 27902}#) - #f - #{mod 27897}# - #f)) - (lambda (#{type 27909}# - #{value 27910}# - #{e 27911}# - #{w 27912}# - #{s 27913}# - #{mod 27914}#) - (#{expand-expr 4335}# - #{type 27909}# - #{value 27910}# - #{e 27911}# - #{r 27895}# - #{w 27912}# - #{s 27913}# - #{mod 27914}#)))))) - (cons #{first 27898}# - (#{dobody 27544}# - (cdr #{body 27894}#) - #{r 27895}# - #{w 27896}# - #{mod 27897}#))))))) - (#{dobody 27544}# - #{body 27460}# - #{r 27461}# - #{w 27462}# - #{mod 27464}#))))) - (#{expand-top-sequence 4330}# - (lambda (#{body 17251}# - #{r 17252}# - #{w 17253}# - #{s 17254}# - #{m 17255}# - #{esew 17256}# - #{mod 17257}#) - (letrec* - ((#{scan 17258}# - (lambda (#{body 17389}# - #{r 17390}# - #{w 17391}# - #{s 17392}# - #{m 17393}# - #{esew 17394}# - #{mod 17395}# - #{exps 17396}#) - (if (null? #{body 17389}#) - #{exps 17396}# - (call-with-values - (lambda () + (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 () - (let ((#{e 17397}# (car #{body 17389}#))) - (#{syntax-type 4333}# - #{e 17397}# - #{r 17390}# - #{w 17391}# - (let ((#{t 17401}# - (#{source-annotation 4295}# #{e 17397}#))) - (if #{t 17401}# #{t 17401}# #{s 17392}#)) - #f - #{mod 17395}# - #f))) - (lambda (#{type 17636}# - #{value 17637}# - #{e 17638}# - #{w 17639}# - #{s 17640}# - #{mod 17641}#) - (if (eqv? #{type 17636}# 'begin-form) - (let ((#{tmp 17646}# - ($sc-dispatch #{e 17638}# '(_)))) - (if #{tmp 17646}# - (@apply (lambda () #{exps 17396}#) #{tmp 17646}#) - (let ((#{tmp 17650}# + (#{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 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 28198}# + #{e 46269}# + #{mod 44821}#) + (list (lambda () #{e 46269}#)))) + (begin + (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 17638}# - '(_ any . each-any)))) - (if #{tmp 17650}# + #{e 44818}# + '(_ . each-any)))) + (if #{tmp 46879}# (@apply - (lambda (#{e1 17654}# #{e2 17655}#) - (#{scan 17258}# - (cons #{e1 17654}# #{e2 17655}#) - #{r 17390}# - #{w 17639}# - #{s 17640}# - #{m 17393}# - #{esew 17394}# - #{mod 17641}# - #{exps 17396}#)) - #{tmp 17650}#) + (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 17638}#))))) - (if (eqv? #{type 17636}# 'local-syntax-form) - (#{expand-local-syntax 4339}# - #{value 17637}# - #{e 17638}# - #{r 17390}# - #{w 17639}# - #{s 17640}# - #{mod 17641}# - (lambda (#{body 17670}# - #{r 17671}# - #{w 17672}# - #{s 17673}# - #{mod 17674}#) - (#{scan 17258}# - #{body 17670}# - #{r 17671}# - #{w 17672}# - #{s 17673}# - #{m 17393}# - #{esew 17394}# - #{mod 17674}# - #{exps 17396}#))) - (if (eqv? #{type 17636}# 'eval-when-form) - (let ((#{tmp 17679}# - ($sc-dispatch - #{e 17638}# - '(_ each-any any . each-any)))) - (if #{tmp 17679}# - (@apply - (lambda (#{x 17683}# - #{e1 17684}# - #{e2 17685}#) - (let ((#{when-list 17686}# - (#{parse-when-list 4332}# - #{e 17638}# - #{x 17683}#)) - (#{body 17687}# - (cons #{e1 17684}# - #{e2 17685}#))) - (if (eq? #{m 17393}# 'e) - (if (memq 'eval #{when-list 17686}#) - (#{scan 17258}# - #{body 17687}# - #{r 17390}# - #{w 17639}# - #{s 17640}# - (if (memq 'expand - #{when-list 17686}#) - 'c&e - 'e) - '(eval) - #{mod 17641}# - #{exps 17396}#) + #{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 - (if (memq 'expand - #{when-list 17686}#) - (let ((#{x 17764}# - (#{expand-top-sequence 4330}# - #{body 17687}# - #{r 17390}# - #{w 17639}# - #{s 17640}# - 'e - '(eval) - #{mod 17641}#))) - (primitive-eval - #{x 17764}#))) - (values #{exps 17396}#))) - (if (memq 'load #{when-list 17686}#) - (if (let ((#{t 17790}# - (memq 'compile - #{when-list 17686}#))) - (if #{t 17790}# - #{t 17790}# - (let ((#{t 17839}# - (memq 'expand - #{when-list 17686}#))) - (if #{t 17839}# - #{t 17839}# - (if (eq? #{m 17393}# - 'c&e) - (memq 'eval - #{when-list 17686}#) - #f))))) - (#{scan 17258}# - #{body 17687}# - #{r 17390}# - #{w 17639}# - #{s 17640}# - 'c&e - '(compile load) - #{mod 17641}# - #{exps 17396}#) - (if (if (eq? #{m 17393}# 'c) - #t - (eq? #{m 17393}# 'c&e)) - (#{scan 17258}# - #{body 17687}# - #{r 17390}# - #{w 17639}# - #{s 17640}# - 'c - '(load) - #{mod 17641}# - #{exps 17396}#) - (values #{exps 17396}#))) - (if (let ((#{t 17968}# - (memq 'compile - #{when-list 17686}#))) - (if #{t 17968}# - #{t 17968}# - (let ((#{t 18017}# - (memq 'expand - #{when-list 17686}#))) - (if #{t 18017}# - #{t 18017}# - (if (eq? #{m 17393}# - 'c&e) - (memq 'eval - #{when-list 17686}#) - #f))))) - (begin - (let ((#{x 18141}# - (#{expand-top-sequence 4330}# - #{body 17687}# - #{r 17390}# - #{w 17639}# - #{s 17640}# - 'e - '(eval) - #{mod 17641}#))) - (primitive-eval #{x 18141}#)) - (values #{exps 17396}#)) - (values #{exps 17396}#)))))) - #{tmp 17679}#) - (syntax-violation - #f - "source expression failed to match any pattern" - #{e 17638}#))) - (if (eqv? #{type 17636}# 'define-syntax-form) - (let ((#{n 18182}# - (#{id-var-name 4321}# - #{value 17637}# - #{w 17639}#)) - (#{r 18183}# - (#{macros-only-env 4298}# - #{r 17390}#))) - (if (eqv? #{m 17393}# 'c) - (if (memq 'compile #{esew 17394}#) - (let ((#{e 18187}# - (#{expand-install-global 4331}# - #{n 18182}# - (#{expand 4334}# - #{e 17638}# - #{r 18183}# - #{w 17639}# - #{mod 17641}#)))) - (begin - (#{top-level-eval-hook 4262}# - #{e 18187}# - #{mod 17641}#) - (if (memq 'load #{esew 17394}#) - (values - (cons #{e 18187}# - #{exps 17396}#)) - (values #{exps 17396}#)))) - (if (memq 'load #{esew 17394}#) - (values - (cons (#{expand-install-global 4331}# - #{n 18182}# - (#{expand 4334}# - #{e 17638}# - #{r 18183}# - #{w 17639}# - #{mod 17641}#)) - #{exps 17396}#)) - (values #{exps 17396}#))) - (if (eqv? #{m 17393}# 'c&e) - (let ((#{e 18634}# - (#{expand-install-global 4331}# - #{n 18182}# - (#{expand 4334}# - #{e 17638}# - #{r 18183}# - #{w 17639}# - #{mod 17641}#)))) - (begin - (#{top-level-eval-hook 4262}# - #{e 18634}# - #{mod 17641}#) - (values - (cons #{e 18634}# - #{exps 17396}#)))) - (begin - (if (memq 'eval #{esew 17394}#) - (#{top-level-eval-hook 4262}# - (#{expand-install-global 4331}# - #{n 18182}# - (#{expand 4334}# - #{e 17638}# - #{r 18183}# - #{w 17639}# - #{mod 17641}#)) - #{mod 17641}#)) - (values #{exps 17396}#))))) - (if (eqv? #{type 17636}# 'define-form) - (let ((#{n 19269}# - (#{id-var-name 4321}# - #{value 17637}# - #{w 17639}#))) - (let ((#{type 19270}# - (car (let ((#{t 20014}# - (assq #{n 19269}# - #{r 17390}#))) - (if #{t 20014}# - (cdr #{t 20014}#) - (if (symbol? #{n 19269}#) - (let ((#{t 20019}# - (begin - (if (if (not #{mod 17641}#) - (current-module) - #f) - (warn "module system is booted, we should have a module" - #{n 19269}#)) - (let ((#{v 20056}# - (module-variable - (if #{mod 17641}# - (resolve-module - (cdr #{mod 17641}#)) - (current-module)) - #{n 19269}#))) - (if #{v 20056}# - (if (variable-bound? - #{v 20056}#) - (let ((#{val 20065}# - (variable-ref - #{v 20056}#))) - (if (macro? - #{val 20065}#) - (if (macro-type - #{val 20065}#) - (cons (macro-type - #{val 20065}#) - (macro-binding - #{val 20065}#)) - #f) - #f)) - #f) - #f))))) - (if #{t 20019}# - #{t 20019}# - '(global))) - '(displaced-lexical))))))) - (if (let ((#{t 19304}# #{type 19270}#)) - (if (eqv? #{t 19304}# 'global) - #t - (if (eqv? #{t 19304}# 'core) - #t - (if (eqv? #{t 19304}# 'macro) - #t - (eqv? #{t 19304}# - 'module-ref))))) - (begin - (if (if (if (eq? #{m 17393}# 'c) - #t - (eq? #{m 17393}# 'c&e)) - (if (not (module-local-variable - (current-module) - #{n 19269}#)) - (current-module) - #f) - #f) - (let ((#{old 19468}# - (module-variable - (current-module) - #{n 19269}#))) - (if (if (variable? #{old 19468}#) - (variable-bound? - #{old 19468}#) - #f) - (module-define! - (current-module) - #{n 19269}# - (variable-ref #{old 19468}#)) - (module-add! - (current-module) - #{n 19269}# - (make-undefined-variable))))) - (values - (cons (if (eq? #{m 17393}# 'c&e) - (let ((#{x 19470}# - (#{build-global-definition 4277}# - #{s 17640}# - #{n 19269}# - (#{expand 4334}# - #{e 17638}# - #{r 17390}# - #{w 17639}# - #{mod 17641}#)))) - (begin - (#{top-level-eval-hook 4262}# - #{x 19470}# - #{mod 17641}#) - #{x 19470}#)) - (lambda () - (#{build-global-definition 4277}# - #{s 17640}# - #{n 19269}# - (#{expand 4334}# - #{e 17638}# - #{r 17390}# - #{w 17639}# - #{mod 17641}#)))) - #{exps 17396}#))) - (if (let ((#{t 19941}# #{type 19270}#)) - (eqv? #{t 19941}# - 'displaced-lexical)) - (syntax-violation - #f - "identifier out of context" - #{e 17638}# - (#{wrap 4327}# - #{value 17637}# - #{w 17639}# - #{mod 17641}#)) - (syntax-violation - #f - "cannot define keyword at top level" - #{e 17638}# - (#{wrap 4327}# - #{value 17637}# - #{w 17639}# - #{mod 17641}#)))))) - (values - (cons (if (eq? #{m 17393}# 'c&e) - (let ((#{x 20076}# - (#{expand-expr 4335}# - #{type 17636}# - #{value 17637}# - #{e 17638}# - #{r 17390}# - #{w 17639}# - #{s 17640}# - #{mod 17641}#))) - (begin - (primitive-eval #{x 20076}#) - #{x 20076}#)) - (lambda () - (#{expand-expr 4335}# - #{type 17636}# - #{value 17637}# - #{e 17638}# - #{r 17390}# - #{w 17639}# - #{s 17640}# - #{mod 17641}#))) - #{exps 17396}#)))))))))) - (lambda (#{exps 20085}#) - (#{scan 17258}# - (cdr #{body 17389}#) - #{r 17390}# - #{w 17391}# - #{s 17392}# - #{m 17393}# - #{esew 17394}# - #{mod 17395}# - #{exps 20085}#))))))) - (call-with-values - (lambda () - (#{scan 17258}# - #{body 17251}# - #{r 17252}# - #{w 17253}# - #{s 17254}# - #{m 17255}# - #{esew 17256}# - #{mod 17257}# - '())) - (lambda (#{exps 17261}#) - (if (null? #{exps 17261}#) - (make-struct/no-tail - (vector-ref %expanded-vtables 0) - #{s 17254}#) - (#{build-sequence 4283}# - #{s 17254}# - (letrec* - ((#{lp 17301}# - (lambda (#{in 17385}# #{out 17386}#) - (if (null? #{in 17385}#) - #{out 17386}# - (let ((#{e 17387}# (car #{in 17385}#))) - (#{lp 17301}# - (cdr #{in 17385}#) - (cons (if (procedure? #{e 17387}#) - (#{e 17387}#) - #{e 17387}#) - #{out 17386}#))))))) - (#{lp 17301}# #{exps 17261}# '()))))))))) - (#{expand-install-global 4331}# - (lambda (#{name 20086}# #{e 20087}#) - (let ((#{exp 20093}# - (let ((#{fun-exp 20103}# - (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 20104}# - (list (make-struct/no-tail - (vector-ref %expanded-vtables 1) - #f - #{name 20086}#) - (make-struct/no-tail - (vector-ref %expanded-vtables 1) - #f - 'macro) - #{e 20087}#))) + (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 47760}#) + (make-struct/no-tail + (vector-ref %expanded-vtables 1) + #f + 'macro) + #{e 47762}#)))) (make-struct/no-tail - (vector-ref %expanded-vtables 11) + (vector-ref %expanded-vtables 12) #f - #{fun-exp 20103}# - #{arg-exps 20104}#)))) + 'make-syntax-transformer + #{args 47779}#)))) (begin - (if (if (struct? #{exp 20093}#) - (eq? (struct-vtable #{exp 20093}#) - (vector-ref %expanded-vtables 13)) + (if (if (struct? #{exp 47768}#) + (eq? (struct-vtable #{exp 47768}#) + (vector-ref %expanded-vtables 14)) #f) - (let ((#{meta 20145}# (struct-ref #{exp 20093}# 1))) - (if (not (assq 'name #{meta 20145}#)) - (let ((#{v 20152}# - (cons (cons 'name #{name 20086}#) #{meta 20145}#))) - (struct-set! #{exp 20093}# 1 #{v 20152}#))))) + (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 20086}# - #{exp 20093}#))))) - (#{parse-when-list 4332}# - (lambda (#{e 20163}# #{when-list 20164}#) - (let ((#{result 20165}# - (#{strip 4347}# #{when-list 20164}# '(())))) + #{name 47760}# + #{exp 47768}#))))) + (#{parse-when-list 28269}# + (lambda (#{e 47847}# #{when-list 47848}#) + (let ((#{result 47849}# + (#{strip 28284}# #{when-list 47848}# '(())))) (letrec* - ((#{lp 20166}# - (lambda (#{l 20220}#) - (if (null? #{l 20220}#) - #{result 20165}# - (if (let ((#{t 20222}# (car #{l 20220}#))) - (if (eq? #{t 20222}# 'compile) + ((#{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 20222}# 'load) + (if (eq? #{t 47918}# 'load) #t - (if (eq? #{t 20222}# 'eval) + (if (eq? #{t 47918}# 'eval) #t - (eq? #{t 20222}# 'expand))))) - (#{lp 20166}# (cdr #{l 20220}#)) + (eq? #{t 47918}# 'expand))))) + (#{lp 47850}# (cdr #{l 47916}#)) (syntax-violation 'eval-when "invalid situation" - #{e 20163}# - (car #{l 20220}#))))))) - (#{lp 20166}# #{result 20165}#))))) - (#{syntax-type 4333}# - (lambda (#{e 20224}# - #{r 20225}# - #{w 20226}# - #{s 20227}# - #{rib 20228}# - #{mod 20229}# - #{for-car? 20230}#) - (if (symbol? #{e 20224}#) - (let ((#{n 20231}# - (#{id-var-name 4321}# #{e 20224}# #{w 20226}#))) - (let ((#{b 20232}# - (let ((#{t 20807}# (assq #{n 20231}# #{r 20225}#))) - (if #{t 20807}# - (cdr #{t 20807}#) - (if (symbol? #{n 20231}#) - (let ((#{t 20812}# - (begin - (if (if (not #{mod 20229}#) - (current-module) - #f) - (warn "module system is booted, we should have a module" - #{n 20231}#)) - (let ((#{v 20849}# - (module-variable - (if #{mod 20229}# - (resolve-module - (cdr #{mod 20229}#)) - (current-module)) - #{n 20231}#))) - (if #{v 20849}# - (if (variable-bound? #{v 20849}#) - (let ((#{val 20858}# - (variable-ref #{v 20849}#))) - (if (macro? #{val 20858}#) - (if (macro-type #{val 20858}#) - (cons (macro-type #{val 20858}#) - (macro-binding - #{val 20858}#)) - #f) - #f)) - #f) - #f))))) - (if #{t 20812}# #{t 20812}# '(global))) - '(displaced-lexical)))))) - (let ((#{type 20233}# (car #{b 20232}#))) - (if (let ((#{t 20267}# #{type 20233}#)) - (eqv? #{t 20267}# 'lexical)) + #{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 20233}# - (cdr #{b 20232}#) - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#) - (if (let ((#{t 20424}# #{type 20233}#)) - (eqv? #{t 20424}# 'global)) - (values - #{type 20233}# - #{n 20231}# - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#) - (if (let ((#{t 20550}# #{type 20233}#)) - (eqv? #{t 20550}# 'macro)) - (if #{for-car? 20230}# - (values - #{type 20233}# - (cdr #{b 20232}#) - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#) - (#{syntax-type 4333}# - (#{expand-macro 4337}# - (cdr #{b 20232}#) - #{e 20224}# - #{r 20225}# - #{w 20226}# - #{s 20227}# - #{rib 20228}# - #{mod 20229}#) - #{r 20225}# - '(()) - #{s 20227}# - #{rib 20228}# - #{mod 20229}# - #f)) - (values - #{type 20233}# - (cdr #{b 20232}#) - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#))))))) - (if (pair? #{e 20224}#) - (let ((#{first 20869}# (car #{e 20224}#))) + #{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 4333}# - #{first 20869}# - #{r 20225}# - #{w 20226}# - #{s 20227}# - #{rib 20228}# - #{mod 20229}# + (#{syntax-type 28270}# + #{first 47940}# + #{r 47921}# + #{w 47922}# + #{s 47923}# + #{rib 47924}# + #{mod 47925}# #t)) - (lambda (#{ftype 20871}# - #{fval 20872}# - #{fe 20873}# - #{fw 20874}# - #{fs 20875}# - #{fmod 20876}#) - (if (eqv? #{ftype 20871}# 'lexical) + (lambda (#{ftype 47942}# + #{fval 47943}# + #{fe 47944}# + #{fw 47945}# + #{fs 47946}# + #{fmod 47947}#) + (if (eqv? #{ftype 47942}# 'lexical) (values 'lexical-call - #{fval 20872}# - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#) - (if (eqv? #{ftype 20871}# 'global) + #{fval 47943}# + #{e 47920}# + #{w 47922}# + #{s 47923}# + #{mod 47925}#) + (if (eqv? #{ftype 47942}# 'global) (values 'global-call (vector 'syntax-object - #{fval 20872}# - #{w 20226}# - #{fmod 20876}#) - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#) - (if (eqv? #{ftype 20871}# 'macro) - (#{syntax-type 4333}# - (#{expand-macro 4337}# - #{fval 20872}# - #{e 20224}# - #{r 20225}# - #{w 20226}# - #{s 20227}# - #{rib 20228}# - #{mod 20229}#) - #{r 20225}# + #{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 20227}# - #{rib 20228}# - #{mod 20229}# - #{for-car? 20230}#) - (if (eqv? #{ftype 20871}# 'module-ref) + #{s 47923}# + #{rib 47924}# + #{mod 47925}# + #{for-car? 47926}#) + (if (eqv? #{ftype 47942}# 'module-ref) (call-with-values (lambda () - (#{fval 20872}# - #{e 20224}# - #{r 20225}# - #{w 20226}#)) - (lambda (#{e 20897}# - #{r 20898}# - #{w 20899}# - #{s 20900}# - #{mod 20901}#) - (#{syntax-type 4333}# - #{e 20897}# - #{r 20898}# - #{w 20899}# - #{s 20900}# - #{rib 20228}# - #{mod 20901}# - #{for-car? 20230}#))) - (if (eqv? #{ftype 20871}# 'core) + (#{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 20872}# - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#) - (if (eqv? #{ftype 20871}# 'local-syntax) + #{fval 47943}# + #{e 47920}# + #{w 47922}# + #{s 47923}# + #{mod 47925}#) + (if (eqv? #{ftype 47942}# 'local-syntax) (values 'local-syntax-form - #{fval 20872}# - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#) - (if (eqv? #{ftype 20871}# 'begin) + #{fval 47943}# + #{e 47920}# + #{w 47922}# + #{s 47923}# + #{mod 47925}#) + (if (eqv? #{ftype 47942}# 'begin) (values 'begin-form #f - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#) - (if (eqv? #{ftype 20871}# 'eval-when) + #{e 47920}# + #{w 47922}# + #{s 47923}# + #{mod 47925}#) + (if (eqv? #{ftype 47942}# 'eval-when) (values 'eval-when-form #f - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#) - (if (eqv? #{ftype 20871}# 'define) - (let ((#{tmp 20918}# + #{e 47920}# + #{w 47922}# + #{s 47923}# + #{mod 47925}#) + (if (eqv? #{ftype 47942}# 'define) + (let ((#{tmp 47989}# ($sc-dispatch - #{e 20224}# + #{e 47920}# '(_ any any)))) - (if (if #{tmp 20918}# + (if (if #{tmp 47989}# (@apply - (lambda (#{name 20922}# - #{val 20923}#) - (if (symbol? #{name 20922}#) + (lambda (#{name 47993}# + #{val 47994}#) + (if (symbol? #{name 47993}#) #t (if (if (vector? - #{name 20922}#) + #{name 47993}#) (if (= (vector-length - #{name 20922}#) + #{name 47993}#) 4) (eq? (vector-ref - #{name 20922}# + #{name 47993}# 0) 'syntax-object) #f) #f) (symbol? (vector-ref - #{name 20922}# + #{name 47993}# 1)) #f))) - #{tmp 20918}#) + #{tmp 47989}#) #f) (@apply - (lambda (#{name 20950}# #{val 20951}#) + (lambda (#{name 48021}# #{val 48022}#) (values 'define-form - #{name 20950}# - #{val 20951}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#)) - #{tmp 20918}#) - (let ((#{tmp 20952}# + #{name 48021}# + #{val 48022}# + #{w 47922}# + #{s 47923}# + #{mod 47925}#)) + #{tmp 47989}#) + (let ((#{tmp 48023}# ($sc-dispatch - #{e 20224}# + #{e 47920}# '(_ (any . any) any . each-any)))) - (if (if #{tmp 20952}# + (if (if #{tmp 48023}# (@apply - (lambda (#{name 20956}# - #{args 20957}# - #{e1 20958}# - #{e2 20959}#) + (lambda (#{name 48027}# + #{args 48028}# + #{e1 48029}# + #{e2 48030}#) (if (if (symbol? - #{name 20956}#) + #{name 48027}#) #t (if (if (vector? - #{name 20956}#) + #{name 48027}#) (if (= (vector-length - #{name 20956}#) + #{name 48027}#) 4) (eq? (vector-ref - #{name 20956}# + #{name 48027}# 0) 'syntax-object) #f) #f) (symbol? (vector-ref - #{name 20956}# + #{name 48027}# 1)) #f)) - (#{valid-bound-ids? 4324}# - (letrec* - ((#{lvl 21108}# - (lambda (#{vars 21110}# - #{ls 21111}# - #{w 21112}#) - (if (pair? #{vars 21110}#) - (#{lvl 21108}# - (cdr #{vars 21110}#) - (cons (#{wrap 4327}# - (car #{vars 21110}#) - #{w 21112}# - #f) - #{ls 21111}#) - #{w 21112}#) - (if (if (symbol? - #{vars 21110}#) - #t - (if (if (vector? - #{vars 21110}#) - (if (= (vector-length - #{vars 21110}#) - 4) - (eq? (vector-ref - #{vars 21110}# - 0) - 'syntax-object) - #f) - #f) - (symbol? - (vector-ref - #{vars 21110}# - 1)) - #f)) - (cons (#{wrap 4327}# - #{vars 21110}# - #{w 21112}# - #f) - #{ls 21111}#) - (if (null? #{vars 21110}#) - #{ls 21111}# - (if (if (vector? - #{vars 21110}#) - (if (= (vector-length - #{vars 21110}#) - 4) - (eq? (vector-ref - #{vars 21110}# - 0) - 'syntax-object) - #f) - #f) - (#{lvl 21108}# - (vector-ref - #{vars 21110}# - 1) - #{ls 21111}# - (#{join-wraps 4318}# - #{w 21112}# - (vector-ref - #{vars 21110}# - 2))) - (cons #{vars 21110}# - #{ls 21111}#)))))))) - (#{lvl 21108}# - #{args 20957}# - '() - '(())))) + (#{valid-bound-ids? 28261}# + (#{lambda-var-list 28286}# + #{args 48028}#)) #f)) - #{tmp 20952}#) + #{tmp 48023}#) #f) (@apply - (lambda (#{name 21156}# - #{args 21157}# - #{e1 21158}# - #{e2 21159}#) + (lambda (#{name 48493}# + #{args 48494}# + #{e1 48495}# + #{e2 48496}#) (values 'define-form - (#{wrap 4327}# - #{name 21156}# - #{w 20226}# - #{mod 20229}#) - (let ((#{e 21165}# + (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) @@ -1660,10 +2007,10 @@ (top) (top) (top)) - #("i1843" - "i1844" - "i1845" - "i1846")) + #("i25779" + "i25780" + "i25781" + "i25782")) #(ribcage () () @@ -1685,12 +2032,12 @@ (top) (top) (top)) - #("i1796" - "i1797" - "i1798" - "i1799" - "i1800" - "i1801")) + #("i25732" + "i25733" + "i25734" + "i25735" + "i25736" + "i25737")) #(ribcage () () @@ -1698,7 +2045,7 @@ #(ribcage #(first) #((top)) - #("i1788")) + #("i25724")) #(ribcage () () @@ -1726,13 +2073,13 @@ (top) (top) (top)) - #("i1760" - "i1761" - "i1762" - "i1763" - "i1764" - "i1765" - "i1766")) + #("i25703" + "i25704" + "i25705" + "i25706" + "i25707" + "i25708" + "i25709")) #(ribcage (lambda-var-list gen-var @@ -1747,7 +2094,7 @@ expand-local-syntax expand-body expand-macro - expand-application + expand-call expand-expr expand syntax-type @@ -1762,6 +2109,7 @@ valid-bound-ids? bound-id=? free-id=? + resolve-identifier id-var-name same-marks? join-marks @@ -1799,7 +2147,6 @@ id? nonsymbol-id? global-extend - lookup macros-only-env extend-var-env extend-env @@ -1825,6 +2172,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -1836,7 +2184,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -1857,8 +2205,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 @@ -2005,143 +2354,147 @@ (top) (top) (top) + (top) + (top) (top)) - ("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 @@ -2149,72 +2502,208 @@ ((top) (top) (top)) - ("i46" - "i45" - "i44"))) + ("i23873" + "i23872" + "i23871")) + #(ribcage + () + () + ())) (hygiene guile)) - (#{wrap 4327}# - (cons #{args 21157}# - (cons #{e1 21158}# - #{e2 21159}#)) - #{w 20226}# - #{mod 20229}#)))) + (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 21165}#) - #{s 20227}# + (if (if (pair? #{e 48598}#) + #{s 47923}# #f) (set-source-properties! - #{e 21165}# - #{s 20227}#)) - #{e 21165}#)) + #{e 48598}# + #{s 47923}#)) + #{e 48598}#)) '(()) - #{s 20227}# - #{mod 20229}#)) - #{tmp 20952}#) - (let ((#{tmp 21172}# + #{s 47923}# + #{mod 47925}#)) + #{tmp 48023}#) + (let ((#{tmp 48681}# ($sc-dispatch - #{e 20224}# + #{e 47920}# '(_ any)))) - (if (if #{tmp 21172}# + (if (if #{tmp 48681}# (@apply - (lambda (#{name 21176}#) + (lambda (#{name 48685}#) (if (symbol? - #{name 21176}#) + #{name 48685}#) #t (if (if (vector? - #{name 21176}#) + #{name 48685}#) (if (= (vector-length - #{name 21176}#) + #{name 48685}#) 4) (eq? (vector-ref - #{name 21176}# + #{name 48685}# 0) 'syntax-object) #f) #f) (symbol? (vector-ref - #{name 21176}# + #{name 48685}# 1)) #f))) - #{tmp 21172}#) + #{tmp 48681}#) #f) (@apply - (lambda (#{name 21203}#) + (lambda (#{name 48712}#) (values 'define-form - (#{wrap 4327}# - #{name 21203}# - #{w 20226}# - #{mod 20229}#) + (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)) - #("i1856")) + #("i25792")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage @@ -2230,17 +2719,17 @@ (top) (top) (top)) - #("i1796" - "i1797" - "i1798" - "i1799" - "i1800" - "i1801")) + #("i25732" + "i25733" + "i25734" + "i25735" + "i25736" + "i25737")) #(ribcage () () ()) #(ribcage #(first) #((top)) - #("i1788")) + #("i25724")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) @@ -2259,13 +2748,13 @@ (top) (top) (top)) - #("i1760" - "i1761" - "i1762" - "i1763" - "i1764" - "i1765" - "i1766")) + #("i25703" + "i25704" + "i25705" + "i25706" + "i25707" + "i25708" + "i25709")) #(ribcage (lambda-var-list gen-var @@ -2280,7 +2769,7 @@ expand-local-syntax expand-body expand-macro - expand-application + expand-call expand-expr expand syntax-type @@ -2295,6 +2784,7 @@ valid-bound-ids? bound-id=? free-id=? + resolve-identifier id-var-name same-marks? join-marks @@ -2332,7 +2822,6 @@ id? nonsymbol-id? global-extend - lookup macros-only-env extend-var-env extend-env @@ -2358,6 +2847,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -2369,7 +2859,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -2390,8 +2880,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 @@ -2538,151 +3029,156 @@ (top) (top) (top) + (top) + (top) (top)) - ("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)) #(syntax-object #f @@ -2690,7 +3186,7 @@ #(ribcage #(name) #((top)) - #("i1856")) + #("i25792")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage @@ -2706,17 +3202,17 @@ (top) (top) (top)) - #("i1796" - "i1797" - "i1798" - "i1799" - "i1800" - "i1801")) + #("i25732" + "i25733" + "i25734" + "i25735" + "i25736" + "i25737")) #(ribcage () () ()) #(ribcage #(first) #((top)) - #("i1788")) + #("i25724")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) @@ -2735,13 +3231,13 @@ (top) (top) (top)) - #("i1760" - "i1761" - "i1762" - "i1763" - "i1764" - "i1765" - "i1766")) + #("i25703" + "i25704" + "i25705" + "i25706" + "i25707" + "i25708" + "i25709")) #(ribcage (lambda-var-list gen-var @@ -2756,7 +3252,7 @@ expand-local-syntax expand-body expand-macro - expand-application + expand-call expand-expr expand syntax-type @@ -2771,6 +3267,7 @@ valid-bound-ids? bound-id=? free-id=? + resolve-identifier id-var-name same-marks? join-marks @@ -2808,7 +3305,6 @@ id? nonsymbol-id? global-extend - lookup macros-only-env extend-var-env extend-env @@ -2834,6 +3330,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -2845,7 +3342,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -2866,8 +3363,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 @@ -3014,151 +3512,156 @@ (top) (top) (top) + (top) + (top) (top)) - ("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)) #(syntax-object #f @@ -3166,7 +3669,7 @@ #(ribcage #(name) #((top)) - #("i1856")) + #("i25792")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage @@ -3182,17 +3685,17 @@ (top) (top) (top)) - #("i1796" - "i1797" - "i1798" - "i1799" - "i1800" - "i1801")) + #("i25732" + "i25733" + "i25734" + "i25735" + "i25736" + "i25737")) #(ribcage () () ()) #(ribcage #(first) #((top)) - #("i1788")) + #("i25724")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) @@ -3211,13 +3714,13 @@ (top) (top) (top)) - #("i1760" - "i1761" - "i1762" - "i1763" - "i1764" - "i1765" - "i1766")) + #("i25703" + "i25704" + "i25705" + "i25706" + "i25707" + "i25708" + "i25709")) #(ribcage (lambda-var-list gen-var @@ -3232,7 +3735,7 @@ expand-local-syntax expand-body expand-macro - expand-application + expand-call expand-expr expand syntax-type @@ -3247,6 +3750,7 @@ valid-bound-ids? bound-id=? free-id=? + resolve-identifier id-var-name same-marks? join-marks @@ -3284,7 +3788,6 @@ id? nonsymbol-id? global-extend - lookup macros-only-env extend-var-env extend-env @@ -3310,6 +3813,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -3321,7 +3825,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -3342,8 +3846,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 @@ -3490,420 +3995,544 @@ (top) (top) (top) + (top) + (top) (top)) - ("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))) '(()) - #{s 20227}# - #{mod 20229}#)) - #{tmp 21172}#) + #{s 47923}# + #{mod 47925}#)) + #{tmp 48681}#) (syntax-violation #f "source expression failed to match any pattern" - #{e 20224}#))))))) - (if (eqv? #{ftype 20871}# 'define-syntax) - (let ((#{tmp 21222}# + #{e 47920}#))))))) + (if (eqv? #{ftype 47942}# 'define-syntax) + (let ((#{tmp 48827}# ($sc-dispatch - #{e 20224}# + #{e 47920}# '(_ any any)))) - (if (if #{tmp 21222}# + (if (if #{tmp 48827}# (@apply - (lambda (#{name 21226}# - #{val 21227}#) - (if (symbol? #{name 21226}#) + (lambda (#{name 48831}# + #{val 48832}#) + (if (symbol? #{name 48831}#) #t (if (if (vector? - #{name 21226}#) + #{name 48831}#) (if (= (vector-length - #{name 21226}#) + #{name 48831}#) 4) (eq? (vector-ref - #{name 21226}# + #{name 48831}# 0) 'syntax-object) #f) #f) (symbol? (vector-ref - #{name 21226}# + #{name 48831}# 1)) #f))) - #{tmp 21222}#) + #{tmp 48827}#) #f) (@apply - (lambda (#{name 21254}# - #{val 21255}#) + (lambda (#{name 48859}# + #{val 48860}#) (values 'define-syntax-form - #{name 21254}# - #{val 21255}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#)) - #{tmp 21222}#) + #{name 48859}# + #{val 48860}# + #{w 47922}# + #{s 47923}# + #{mod 47925}#)) + #{tmp 48827}#) (syntax-violation #f "source expression failed to match any pattern" - #{e 20224}#))) - (values - 'call - #f - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#)))))))))))))) - (if (if (vector? #{e 20224}#) - (if (= (vector-length #{e 20224}#) 4) - (eq? (vector-ref #{e 20224}# 0) 'syntax-object) + #{e 47920}#))) + (if (eqv? #{ftype 47942}# + 'define-syntax-parameter) + (let ((#{tmp 48871}# + ($sc-dispatch + #{e 47920}# + '(_ any any)))) + (if (if #{tmp 48871}# + (@apply + (lambda (#{name 48875}# + #{val 48876}#) + (if (symbol? #{name 48875}#) + #t + (if (if (vector? + #{name 48875}#) + (if (= (vector-length + #{name 48875}#) + 4) + (eq? (vector-ref + #{name 48875}# + 0) + 'syntax-object) + #f) + #f) + (symbol? + (vector-ref + #{name 48875}# + 1)) + #f))) + #{tmp 48871}#) + #f) + (@apply + (lambda (#{name 48903}# + #{val 48904}#) + (values + '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 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) #f) - (#{syntax-type 4333}# - (vector-ref #{e 20224}# 1) - #{r 20225}# - (#{join-wraps 4318}# - #{w 20226}# - (vector-ref #{e 20224}# 2)) - (let ((#{t 21282}# - (#{source-annotation 4295}# #{e 20224}#))) - (if #{t 21282}# #{t 21282}# #{s 20227}#)) - #{rib 20228}# - (let ((#{t 21517}# (vector-ref #{e 20224}# 3))) - (if #{t 21517}# #{t 21517}# #{mod 20229}#)) - #{for-car? 20230}#) - (if (self-evaluating? #{e 20224}#) + (#{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 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#) + #{e 47920}# + #{w 47922}# + #{s 47923}# + #{mod 47925}#) (values 'other #f - #{e 20224}# - #{w 20226}# - #{s 20227}# - #{mod 20229}#))))))) - (#{expand 4334}# - (lambda (#{e 21526}# - #{r 21527}# - #{w 21528}# - #{mod 21529}#) + #{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 4333}# - #{e 21526}# - #{r 21527}# - #{w 21528}# - (#{source-annotation 4295}# #{e 21526}#) + (#{syntax-type 28270}# + #{e 49248}# + #{r 49249}# + #{w 49250}# + (#{source-annotation 28232}# #{e 49248}#) #f - #{mod 21529}# + #{mod 49251}# #f)) - (lambda (#{type 21684}# - #{value 21685}# - #{e 21686}# - #{w 21687}# - #{s 21688}# - #{mod 21689}#) - (#{expand-expr 4335}# - #{type 21684}# - #{value 21685}# - #{e 21686}# - #{r 21527}# - #{w 21687}# - #{s 21688}# - #{mod 21689}#))))) - (#{expand-expr 4335}# - (lambda (#{type 21692}# - #{value 21693}# - #{e 21694}# - #{r 21695}# - #{w 21696}# - #{s 21697}# - #{mod 21698}#) - (if (eqv? #{type 21692}# 'lexical) + (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 21697}# - #{e 21694}# - #{value 21693}#) - (if (if (eqv? #{type 21692}# 'core) + #{s 49450}# + #{e 49447}# + #{value 49446}#) + (if (if (eqv? #{type 49445}# 'core) #t - (eqv? #{type 21692}# 'core-form)) - (#{value 21693}# - #{e 21694}# - #{r 21695}# - #{w 21696}# - #{s 21697}# - #{mod 21698}#) - (if (eqv? #{type 21692}# 'module-ref) + (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 21693}# - #{e 21694}# - #{r 21695}# - #{w 21696}#)) - (lambda (#{e 21724}# - #{r 21725}# - #{w 21726}# - #{s 21727}# - #{mod 21728}#) - (#{expand 4334}# - #{e 21724}# - #{r 21725}# - #{w 21726}# - #{mod 21728}#))) - (if (eqv? #{type 21692}# 'lexical-call) - (#{expand-application 4336}# - (let ((#{id 21803}# (car #{e 21694}#))) - (#{build-lexical-reference 4272}# + (#{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 4295}# #{id 21803}#) - (if (if (vector? #{id 21803}#) - (if (= (vector-length #{id 21803}#) 4) - (eq? (vector-ref #{id 21803}# 0) 'syntax-object) + (#{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) #f) - (syntax->datum #{id 21803}#) - #{id 21803}#) - #{value 21693}#)) - #{e 21694}# - #{r 21695}# - #{w 21696}# - #{s 21697}# - #{mod 21698}#) - (if (eqv? #{type 21692}# 'global-call) - (#{expand-application 4336}# - (#{build-global-reference 4275}# - (#{source-annotation 4295}# (car #{e 21694}#)) - (if (if (vector? #{value 21693}#) - (if (= (vector-length #{value 21693}#) 4) - (eq? (vector-ref #{value 21693}# 0) + (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) #f) - (vector-ref #{value 21693}# 1) - #{value 21693}#) - (if (if (vector? #{value 21693}#) - (if (= (vector-length #{value 21693}#) 4) - (eq? (vector-ref #{value 21693}# 0) + (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) #f) - (vector-ref #{value 21693}# 3) - #{mod 21698}#)) - #{e 21694}# - #{r 21695}# - #{w 21696}# - #{s 21697}# - #{mod 21698}#) - (if (eqv? #{type 21692}# 'constant) - (let ((#{exp 22140}# - (#{strip 4347}# - (#{wrap 4327}# - (begin - (if (if (pair? #{e 21694}#) #{s 21697}# #f) - (set-source-properties! - #{e 21694}# - #{s 21697}#)) - #{e 21694}#) - #{w 21696}# - #{mod 21698}#) + (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 21697}# - #{exp 22140}#)) - (if (eqv? #{type 21692}# 'global) - (#{analyze-variable 4274}# - #{mod 21698}# - #{value 21693}# - (lambda (#{mod 22176}# #{var 22177}# #{public? 22178}#) + #{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 21697}# - #{mod 22176}# - #{var 22177}# - #{public? 22178}#)) - (lambda (#{var 22187}#) + #{s 49450}# + #{mod 50440}# + #{var 50441}# + #{public? 50442}#)) + (lambda (#{var 50450}#) (make-struct/no-tail (vector-ref %expanded-vtables 7) - #{s 21697}# - #{var 22187}#))) - (if (eqv? #{type 21692}# 'call) - (#{expand-application 4336}# - (#{expand 4334}# - (car #{e 21694}#) - #{r 21695}# - #{w 21696}# - #{mod 21698}#) - #{e 21694}# - #{r 21695}# - #{w 21696}# - #{s 21697}# - #{mod 21698}#) - (if (eqv? #{type 21692}# 'begin-form) - (let ((#{tmp 22262}# + #{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 21694}# + #{e 49447}# '(_ any . each-any)))) - (if #{tmp 22262}# + (if #{tmp 50620}# (@apply - (lambda (#{e1 22266}# #{e2 22267}#) - (#{expand-sequence 4329}# - (cons #{e1 22266}# #{e2 22267}#) - #{r 21695}# - #{w 21696}# - #{s 21697}# - #{mod 21698}#)) - #{tmp 22262}#) - (let ((#{tmp 22354}# - ($sc-dispatch #{e 21694}# '(_)))) - (if #{tmp 22354}# + (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 @@ -3912,2349 +4541,2463 @@ (make-struct/no-tail (vector-ref %expanded-vtables 0) #f))) - #{tmp 22354}#) + #{tmp 50720}#) (syntax-violation #f "source expression failed to match any pattern" - #{e 21694}#))))) - (if (eqv? #{type 21692}# 'local-syntax-form) - (#{expand-local-syntax 4339}# - #{value 21693}# - #{e 21694}# - #{r 21695}# - #{w 21696}# - #{s 21697}# - #{mod 21698}# - #{expand-sequence 4329}#) - (if (eqv? #{type 21692}# 'eval-when-form) - (let ((#{tmp 22443}# + #{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 21694}# + #{e 49447}# '(_ each-any any . each-any)))) - (if #{tmp 22443}# + (if #{tmp 50812}# (@apply - (lambda (#{x 22447}# - #{e1 22448}# - #{e2 22449}#) - (let ((#{when-list 22450}# - (#{parse-when-list 4332}# - #{e 21694}# - #{x 22447}#))) - (if (memq 'eval #{when-list 22450}#) - (#{expand-sequence 4329}# - (cons #{e1 22448}# #{e2 22449}#) - #{r 21695}# - #{w 21696}# - #{s 21697}# - #{mod 21698}#) + (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 22443}#) + #{tmp 50812}#) (syntax-violation #f "source expression failed to match any pattern" - #{e 21694}#))) - (if (if (eqv? #{type 21692}# 'define-form) + #{e 49447}#))) + (if (if (eqv? #{type 49445}# 'define-form) #t - (eqv? #{type 21692}# 'define-syntax-form)) + (if (eqv? #{type 49445}# + 'define-syntax-form) + #t + (eqv? #{type 49445}# + 'define-syntax-parameter-form))) (syntax-violation #f "definition in expression context" - #{e 21694}# - (#{wrap 4327}# - #{value 21693}# - #{w 21696}# - #{mod 21698}#)) - (if (eqv? #{type 21692}# 'syntax) + #{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 "reference to pattern variable outside syntax form" - (#{wrap 4327}# - (begin - (if (if (pair? #{e 21694}#) - #{s 21697}# + (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) - (set-source-properties! - #{e 21694}# - #{s 21697}#)) - #{e 21694}#) - #{w 21696}# - #{mod 21698}#)) - (if (eqv? #{type 21692}# 'displaced-lexical) + (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 identifier outside its scope" - (#{wrap 4327}# - (begin - (if (if (pair? #{e 21694}#) - #{s 21697}# + (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) #f) - (set-source-properties! - #{e 21694}# - #{s 21697}#)) - #{e 21694}#) - #{w 21696}# - #{mod 21698}#)) + (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" - (#{wrap 4327}# - (begin - (if (if (pair? #{e 21694}#) - #{s 21697}# + (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) #f) - (set-source-properties! - #{e 21694}# - #{s 21697}#)) - #{e 21694}#) - #{w 21696}# - #{mod 21698}#)))))))))))))))))) - (#{expand-application 4336}# - (lambda (#{x 22687}# - #{e 22688}# - #{r 22689}# - #{w 22690}# - #{s 22691}# - #{mod 22692}#) - (let ((#{tmp 22694}# - ($sc-dispatch #{e 22688}# '(any . each-any)))) - (if #{tmp 22694}# + (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 22698}# #{e1 22699}#) - (#{build-application 4269}# - #{s 22691}# - #{x 22687}# - (map (lambda (#{e 22779}#) - (#{expand 4334}# - #{e 22779}# - #{r 22689}# - #{w 22690}# - #{mod 22692}#)) - #{e1 22699}#))) - #{tmp 22694}#) + (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 22688}#))))) - (#{expand-macro 4337}# - (lambda (#{p 22855}# - #{e 22856}# - #{r 22857}# - #{w 22858}# - #{s 22859}# - #{rib 22860}# - #{mod 22861}#) + #{e 51396}#))))) + (#{expand-macro 28274}# + (lambda (#{p 51579}# + #{e 51580}# + #{r 51581}# + #{w 51582}# + #{s 51583}# + #{rib 51584}# + #{mod 51585}#) (letrec* - ((#{rebuild-macro-output 22862}# - (lambda (#{x 22893}# #{m 22894}#) - (if (pair? #{x 22893}#) - (let ((#{e 22898}# - (cons (#{rebuild-macro-output 22862}# - (car #{x 22893}#) - #{m 22894}#) - (#{rebuild-macro-output 22862}# - (cdr #{x 22893}#) - #{m 22894}#)))) + ((#{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 22898}#) #{s 22859}# #f) - (set-source-properties! #{e 22898}# #{s 22859}#)) - #{e 22898}#)) - (if (if (vector? #{x 22893}#) - (if (= (vector-length #{x 22893}#) 4) - (eq? (vector-ref #{x 22893}# 0) 'syntax-object) + (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) #f) - (let ((#{w 22914}# (vector-ref #{x 22893}# 2))) - (let ((#{ms 22915}# (car #{w 22914}#)) - (#{s 22916}# (cdr #{w 22914}#))) - (if (if (pair? #{ms 22915}#) - (eq? (car #{ms 22915}#) #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 22924}# (vector-ref #{x 22893}# 1)) - (#{wrap 22925}# - (cons (cdr #{ms 22915}#) - (if #{rib 22860}# - (cons #{rib 22860}# (cdr #{s 22916}#)) - (cdr #{s 22916}#)))) - (#{module 22926}# (vector-ref #{x 22893}# 3))) + (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 22924}# - #{wrap 22925}# - #{module 22926}#)) - (let ((#{expression 22936}# - (let ((#{e 22941}# (vector-ref #{x 22893}# 1))) + #{expression 51724}# + #{wrap 51725}# + #{module 51726}#)) + (let ((#{expression 51736}# + (let ((#{e 51741}# (vector-ref #{x 51693}# 1))) (begin - (if (if (pair? #{e 22941}#) #{s 22916}# #f) + (if (if (pair? #{e 51741}#) #{s 51716}# #f) (set-source-properties! - #{e 22941}# - #{s 22916}#)) - #{e 22941}#))) - (#{wrap 22937}# - (cons (cons #{m 22894}# #{ms 22915}#) - (if #{rib 22860}# - (cons #{rib 22860}# - (cons 'shift #{s 22916}#)) - (cons 'shift #{s 22916}#)))) - (#{module 22938}# (vector-ref #{x 22893}# 3))) + #{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 22936}# - #{wrap 22937}# - #{module 22938}#))))) - (if (vector? #{x 22893}#) - (let ((#{n 22953}# (vector-length #{x 22893}#))) - (let ((#{v 22954}# - (let ((#{e 22962}# (make-vector #{n 22953}#))) + #{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 22962}#) #{x 22893}# #f) + (if (if (pair? #{e 51820}#) #{x 51693}# #f) (set-source-properties! - #{e 22962}# - #{x 22893}#)) - #{e 22962}#)))) + #{e 51820}# + #{x 51693}#)) + #{e 51820}#)))) (letrec* - ((#{loop 22955}# - (lambda (#{i 23007}#) - (if (= #{i 23007}# #{n 22953}#) - #{v 22954}# + ((#{loop 51755}# + (lambda (#{i 51816}#) + (if (= #{i 51816}# #{n 51753}#) + #{v 51754}# (begin (vector-set! - #{v 22954}# - #{i 23007}# - (#{rebuild-macro-output 22862}# - (vector-ref #{x 22893}# #{i 23007}#) - #{m 22894}#)) - (#{loop 22955}# (#{1+}# #{i 23007}#))))))) - (#{loop 22955}# 0)))) - (if (symbol? #{x 22893}#) + #{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 23013}# (cdr #{w 22858}#))) - (#{wrap 4327}# - (begin - (if (if (pair? #{e 22856}#) #{s 23013}# #f) - (set-source-properties! - #{e 22856}# - #{s 23013}#)) - #{e 22856}#) - #{w 22858}# - #{mod 22861}#)) - #{x 22893}#) + (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 22893}#) #{s 22859}# #f) - (set-source-properties! #{x 22893}# #{s 22859}#)) - #{x 22893}#)))))))) - (#{rebuild-macro-output 22862}# - (#{p 22855}# - (let ((#{w 22869}# - (cons (cons #f (car #{w 22858}#)) - (cons 'shift (cdr #{w 22858}#))))) - (#{wrap 4327}# - (begin - (if (if (pair? #{e 22856}#) #{s 22859}# #f) - (set-source-properties! #{e 22856}# #{s 22859}#)) - #{e 22856}#) - #{w 22869}# - #{mod 22861}#))) + (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 4338}# - (lambda (#{body 23045}# - #{outer-form 23046}# - #{r 23047}# - #{w 23048}# - #{mod 23049}#) - (let ((#{r 23050}# - (cons '("placeholder" placeholder) #{r 23047}#))) - (let ((#{ribcage 23051}# (vector 'ribcage '() '() '()))) - (let ((#{w 23052}# - (cons (car #{w 23048}#) - (cons #{ribcage 23051}# (cdr #{w 23048}#))))) + (#{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 23053}# - (lambda (#{body 23066}# - #{ids 23067}# - #{labels 23068}# - #{var-ids 23069}# - #{vars 23070}# - #{vals 23071}# - #{bindings 23072}#) - (if (null? #{body 23066}#) + ((#{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 23046}#) - (let ((#{e 23073}# (cdr (car #{body 23066}#))) - (#{er 23074}# (car (car #{body 23066}#)))) + #{outer-form 51940}#) + (let ((#{e 52062}# (cdr (car #{body 52055}#))) + (#{er 52063}# (car (car #{body 52055}#)))) (call-with-values (lambda () - (#{syntax-type 4333}# - #{e 23073}# - #{er 23074}# + (#{syntax-type 28270}# + #{e 52062}# + #{er 52063}# '(()) - (#{source-annotation 4295}# #{er 23074}#) - #{ribcage 23051}# - #{mod 23049}# + (#{source-annotation 28232}# #{er 52063}#) + #{ribcage 51945}# + #{mod 51943}# #f)) - (lambda (#{type 23231}# - #{value 23232}# - #{e 23233}# - #{w 23234}# - #{s 23235}# - #{mod 23236}#) - (if (eqv? #{type 23231}# 'define-form) - (let ((#{id 23240}# - (#{wrap 4327}# - #{value 23232}# - #{w 23234}# - #{mod 23236}#)) - (#{label 23241}# + (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 23242}# - (let ((#{id 23302}# - (if (if (vector? #{id 23240}#) + (let ((#{var 52262}# + (let ((#{id 52412}# + (if (if (vector? #{id 52260}#) (if (= (vector-length - #{id 23240}#) + #{id 52260}#) 4) (eq? (vector-ref - #{id 23240}# + #{id 52260}# 0) 'syntax-object) #f) #f) - (vector-ref #{id 23240}# 1) - #{id 23240}#))) + (vector-ref #{id 52260}# 1) + #{id 52260}#))) (gensym (string-append - (symbol->string #{id 23302}#) + (symbol->string #{id 52412}#) " "))))) (begin - (let ((#{update 23292}# - (cons (vector-ref #{id 23240}# 1) - (vector-ref - #{ribcage 23051}# - 1)))) - (vector-set! - #{ribcage 23051}# - 1 - #{update 23292}#)) - (let ((#{update 23294}# - (cons (car (vector-ref - #{id 23240}# - 2)) - (vector-ref - #{ribcage 23051}# - 2)))) - (vector-set! - #{ribcage 23051}# - 2 - #{update 23294}#)) - (let ((#{update 23296}# - (cons #{label 23241}# - (vector-ref - #{ribcage 23051}# - 3)))) - (vector-set! - #{ribcage 23051}# - 3 - #{update 23296}#)) - (#{parse 23053}# - (cdr #{body 23066}#) - (cons #{id 23240}# #{ids 23067}#) - (cons #{label 23241}# #{labels 23068}#) - (cons #{id 23240}# #{var-ids 23069}#) - (cons #{var 23242}# #{vars 23070}#) - (cons (cons #{er 23074}# - (#{wrap 4327}# - #{e 23233}# - #{w 23234}# - #{mod 23236}#)) - #{vals 23071}#) - (cons (cons 'lexical #{var 23242}#) - #{bindings 23072}#))))) - (if (eqv? #{type 23231}# 'define-syntax-form) - (let ((#{id 23330}# - (#{wrap 4327}# - #{value 23232}# - #{w 23234}# - #{mod 23236}#)) - (#{label 23331}# + (begin + (let ((#{update 52271}# + (cons (vector-ref #{id 52260}# 1) + (vector-ref + #{ribcage 51945}# + 1)))) + (vector-set! + #{ribcage 51945}# + 1 + #{update 52271}#)) + (let ((#{update 52383}# + (cons (car (vector-ref + #{id 52260}# + 2)) + (vector-ref + #{ribcage 51945}# + 2)))) + (vector-set! + #{ribcage 51945}# + 2 + #{update 52383}#)) + (let ((#{update 52398}# + (cons #{label 52261}# + (vector-ref + #{ribcage 51945}# + 3)))) + (vector-set! + #{ribcage 51945}# + 3 + #{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 - (let ((#{update 23381}# - (cons (vector-ref #{id 23330}# 1) - (vector-ref - #{ribcage 23051}# - 1)))) - (vector-set! - #{ribcage 23051}# - 1 - #{update 23381}#)) - (let ((#{update 23383}# - (cons (car (vector-ref - #{id 23330}# - 2)) - (vector-ref - #{ribcage 23051}# - 2)))) - (vector-set! - #{ribcage 23051}# - 2 - #{update 23383}#)) - (let ((#{update 23385}# - (cons #{label 23331}# - (vector-ref - #{ribcage 23051}# - 3)))) - (vector-set! - #{ribcage 23051}# - 3 - #{update 23385}#)) - (#{parse 23053}# - (cdr #{body 23066}#) - (cons #{id 23330}# #{ids 23067}#) - (cons #{label 23331}# #{labels 23068}#) - #{var-ids 23069}# - #{vars 23070}# - #{vals 23071}# - (cons (cons 'macro - (cons #{er 23074}# - (#{wrap 4327}# - #{e 23233}# - #{w 23234}# - #{mod 23236}#))) - #{bindings 23072}#)))) - (if (eqv? #{type 23231}# 'begin-form) - (let ((#{tmp 23393}# + (begin + (let ((#{update 52551}# + (cons (vector-ref #{id 52541}# 1) + (vector-ref + #{ribcage 51945}# + 1)))) + (vector-set! + #{ribcage 51945}# + 1 + #{update 52551}#)) + (let ((#{update 52663}# + (cons (car (vector-ref + #{id 52541}# + 2)) + (vector-ref + #{ribcage 51945}# + 2)))) + (vector-set! + #{ribcage 51945}# + 2 + #{update 52663}#)) + (let ((#{update 52678}# + (cons #{label 52542}# + (vector-ref + #{ribcage 51945}# + 3)))) + (vector-set! + #{ribcage 51945}# + 3 + #{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 23233}# + #{e 52253}# '(_ . each-any)))) - (if #{tmp 23393}# + (if #{tmp 52790}# (@apply - (lambda (#{e1 23397}#) - (#{parse 23053}# + (lambda (#{e1 52794}#) + (#{parse 51947}# (letrec* - ((#{f 23398}# - (lambda (#{forms 23461}#) - (if (null? #{forms 23461}#) - (cdr #{body 23066}#) - (cons (cons #{er 23074}# - (#{wrap 4327}# - (car #{forms 23461}#) - #{w 23234}# - #{mod 23236}#)) - (#{f 23398}# - (cdr #{forms 23461}#))))))) - (#{f 23398}# #{e1 23397}#)) - #{ids 23067}# - #{labels 23068}# - #{var-ids 23069}# - #{vars 23070}# - #{vals 23071}# - #{bindings 23072}#)) - #{tmp 23393}#) + ((#{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 23233}#))) - (if (eqv? #{type 23231}# 'local-syntax-form) - (#{expand-local-syntax 4339}# - #{value 23232}# - #{e 23233}# - #{er 23074}# - #{w 23234}# - #{s 23235}# - #{mod 23236}# - (lambda (#{forms 23475}# - #{er 23476}# - #{w 23477}# - #{s 23478}# - #{mod 23479}#) - (#{parse 23053}# + #{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* - ((#{f 23480}# - (lambda (#{forms 23543}#) - (if (null? #{forms 23543}#) - (cdr #{body 23066}#) - (cons (cons #{er 23476}# - (#{wrap 4327}# - (car #{forms 23543}#) - #{w 23477}# - #{mod 23479}#)) - (#{f 23480}# - (cdr #{forms 23543}#))))))) - (#{f 23480}# #{forms 23475}#)) - #{ids 23067}# - #{labels 23068}# - #{var-ids 23069}# - #{vars 23070}# - #{vals 23071}# - #{bindings 23072}#))) - (if (null? #{ids 23067}#) - (#{build-sequence 4283}# + ((#{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 23608}#) - (let ((#{e 23612}# - (cdr #{x 23608}#)) - (#{r 23613}# - (car #{x 23608}#))) - (call-with-values - (lambda () - (#{syntax-type 4333}# - #{e 23612}# - #{r 23613}# - '(()) - (#{source-annotation 4295}# - #{e 23612}#) - #f - #{mod 23236}# - #f)) - (lambda (#{type 23617}# - #{value 23618}# - #{e 23619}# - #{w 23620}# - #{s 23621}# - #{mod 23622}#) - (#{expand-expr 4335}# - #{type 23617}# - #{value 23618}# - #{e 23619}# - #{r 23613}# - #{w 23620}# - #{s 23621}# - #{mod 23622}#))))) - (cons (cons #{er 23074}# - (#{wrap 4327}# - (begin - (if (if (pair? #{e 23233}#) - #{s 23235}# + (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) - (set-source-properties! - #{e 23233}# - #{s 23235}#)) - #{e 23233}#) - #{w 23234}# - #{mod 23236}#)) - (cdr #{body 23066}#)))) + (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? 4324}# - #{ids 23067}#)) + (if (not (#{valid-bound-ids? 28261}# + #{ids 52056}#)) (syntax-violation #f "invalid or duplicate identifier in definition" - #{outer-form 23046}#)) + #{outer-form 51940}#)) (letrec* - ((#{loop 23723}# - (lambda (#{bs 23726}# - #{er-cache 23727}# - #{r-cache 23728}#) - (if (not (null? #{bs 23726}#)) - (let ((#{b 23729}# - (car #{bs 23726}#))) - (if (eq? (car #{b 23729}#) - 'macro) - (let ((#{er 23731}# - (car (cdr #{b 23729}#)))) - (let ((#{r-cache 23732}# - (if (eq? #{er 23731}# - #{er-cache 23727}#) - #{r-cache 23728}# - (#{macros-only-env 4298}# - #{er 23731}#)))) + ((#{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 23729}# - (#{eval-local-transformer 4340}# - (#{expand 4334}# - (cdr (cdr #{b 23729}#)) - #{r-cache 23732}# + #{b 53695}# + (#{eval-local-transformer 28277}# + (#{expand 28271}# + (cdr (cdr #{b 53695}#)) + #{r-cache 53701}# '(()) - #{mod 23236}#) - #{mod 23236}#)) - (#{loop 23723}# - (cdr #{bs 23726}#) - #{er 23731}# - #{r-cache 23732}#)))) - (#{loop 23723}# - (cdr #{bs 23726}#) - #{er-cache 23727}# - #{r-cache 23728}#))))))) - (#{loop 23723}# - #{bindings 23072}# + #{mod 52256}#) + #{mod 52256}#)) + (if (eq? (car #{b 53695}#) + 'syntax-parameter) + (set-cdr! + #{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 #f)) (set-cdr! - #{r 23050}# - (#{extend-env 4296}# - #{labels 23068}# - #{bindings 23072}# - (cdr #{r 23050}#))) - (#{build-letrec 4286}# + #{r 51944}# + (#{extend-env 28233}# + #{labels 52057}# + #{bindings 52061}# + (cdr #{r 51944}#))) + (#{build-letrec 28223}# #f #t (reverse (map syntax->datum - #{var-ids 23069}#)) - (reverse #{vars 23070}#) - (map (lambda (#{x 24075}#) - (let ((#{e 24079}# - (cdr #{x 24075}#)) - (#{r 24080}# - (car #{x 24075}#))) - (call-with-values - (lambda () - (#{syntax-type 4333}# - #{e 24079}# - #{r 24080}# - '(()) - (#{source-annotation 4295}# - #{e 24079}#) - #f - #{mod 23236}# - #f)) - (lambda (#{type 24084}# - #{value 24085}# - #{e 24086}# - #{w 24087}# - #{s 24088}# - #{mod 24089}#) - (#{expand-expr 4335}# - #{type 24084}# - #{value 24085}# - #{e 24086}# - #{r 24080}# - #{w 24087}# - #{s 24088}# - #{mod 24089}#))))) - (reverse #{vals 23071}#)) - (let ((#{exps 24095}# - (map (lambda (#{x 24096}#) - (let ((#{e 24099}# - (cdr #{x 24096}#)) - (#{r 24100}# - (car #{x 24096}#))) - (call-with-values - (lambda () - (#{syntax-type 4333}# - #{e 24099}# - #{r 24100}# - '(()) - (#{source-annotation 4295}# - #{e 24099}#) - #f - #{mod 23236}# - #f)) - (lambda (#{type 24104}# - #{value 24105}# - #{e 24106}# - #{w 24107}# - #{s 24108}# - #{mod 24109}#) - (#{expand-expr 4335}# - #{type 24104}# - #{value 24105}# - #{e 24106}# - #{r 24100}# - #{w 24107}# - #{s 24108}# - #{mod 24109}#))))) - (cons (cons #{er 23074}# - (#{wrap 4327}# + #{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 23233}#) - #{s 23235}# + (if (if (pair? #{e 52253}#) + #{s 52255}# #f) (set-source-properties! - #{e 23233}# - #{s 23235}#)) - #{e 23233}#) - #{w 23234}# - #{mod 23236}#)) - (cdr #{body 23066}#))))) - (if (null? (cdr #{exps 24095}#)) - (car #{exps 24095}#) - (make-struct/no-tail - (vector-ref - %expanded-vtables - 12) - #f - #{exps 24095}#))))))))))))))))) - (#{parse 23053}# - (map (lambda (#{x 23056}#) - (cons #{r 23050}# - (#{wrap 4327}# - #{x 23056}# - #{w 23052}# - #{mod 23049}#))) - #{body 23045}#) + #{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 4339}# - (lambda (#{rec? 24135}# - #{e 24136}# - #{r 24137}# - #{w 24138}# - #{s 24139}# - #{mod 24140}# - #{k 24141}#) - (let ((#{tmp 24143}# + (#{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 24136}# + #{e 54422}# '(_ #(each (any any)) any . each-any)))) - (if #{tmp 24143}# + (if #{tmp 54429}# (@apply - (lambda (#{id 24147}# - #{val 24148}# - #{e1 24149}# - #{e2 24150}#) - (if (not (#{valid-bound-ids? 4324}# #{id 24147}#)) + (lambda (#{id 54433}# + #{val 54434}# + #{e1 54435}# + #{e2 54436}#) + (if (not (#{valid-bound-ids? 28261}# #{id 54433}#)) (syntax-violation #f "duplicate bound keyword" - #{e 24136}#) - (let ((#{labels 24240}# - (#{gen-labels 4305}# #{id 24147}#))) - (let ((#{new-w 24241}# - (#{make-binding-wrap 4316}# - #{id 24147}# - #{labels 24240}# - #{w 24138}#))) - (#{k 24141}# - (cons #{e1 24149}# #{e2 24150}#) - (#{extend-env 4296}# - #{labels 24240}# - (let ((#{trans-r 24279}# - (#{macros-only-env 4298}# #{r 24137}#))) + #{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? 24135}# #{new-w 24241}# #{w 24138}#) - (map (lambda (#{x 24280}#) + (if #{rec? 54421}# #{new-w 54534}# #{w 54424}#) + (map (lambda (#{x 54575}#) (cons 'macro - (#{eval-local-transformer 4340}# - (#{expand 4334}# - #{x 24280}# - #{trans-r 24279}# + (#{eval-local-transformer 28277}# + (#{expand 28271}# + #{x 54575}# + #{trans-r 54574}# (values - (if #{rec? 24135}# - #{new-w 24241}# - #{w 24138}#)) - #{mod 24140}#) - #{mod 24140}#))) - #{val 24148}#))) - #{r 24137}#) - #{new-w 24241}# - #{s 24139}# - #{mod 24140}#))))) - #{tmp 24143}#) + (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" - (#{wrap 4327}# - (begin - (if (if (pair? #{e 24136}#) #{s 24139}# #f) - (set-source-properties! #{e 24136}# #{s 24139}#)) - #{e 24136}#) - #{w 24138}# - #{mod 24140}#)))))) - (#{eval-local-transformer 4340}# - (lambda (#{expanded 24576}# #{mod 24577}#) - (let ((#{p 24578}# (primitive-eval #{expanded 24576}#))) - (if (procedure? #{p 24578}#) - #{p 24578}# + (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 24578}#))))) - (#{ellipsis? 4342}# - (lambda (#{x 5143}#) - (if (if (if (vector? #{x 5143}#) - (if (= (vector-length #{x 5143}#) 4) - (eq? (vector-ref #{x 5143}# 0) 'syntax-object) + #{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) #f) - (symbol? (vector-ref #{x 5143}# 1)) + (symbol? (vector-ref #{x 29819}# 1)) #f) - (if (eq? (if (if (vector? #{x 5143}#) - (if (= (vector-length #{x 5143}#) 4) - (eq? (vector-ref #{x 5143}# 0) 'syntax-object) - #f) - #f) - (vector-ref #{x 5143}# 1) - #{x 5143}#) - (if (if (= (vector-length - '#(syntax-object - ... - ((top) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i2219")) - #(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=? - 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)) - ("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)) #("i2219")) - #(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=? - 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)) - ("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 4321}# #{x 5143}# '(())) - (#{id-var-name 4321}# - '#(syntax-object - ... - ((top) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i2219")) - #(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=? - 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)) - ("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) + (#{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 4343}# - (lambda (#{orig-args 24583}#) + (#{lambda-formals 28280}# + (lambda (#{orig-args 55003}#) (letrec* - ((#{req 24584}# - (lambda (#{args 24588}# #{rreq 24589}#) - (let ((#{tmp 24591}# ($sc-dispatch #{args 24588}# '()))) - (if #{tmp 24591}# + ((#{req 55004}# + (lambda (#{args 55008}# #{rreq 55009}#) + (let ((#{tmp 55011}# ($sc-dispatch #{args 55008}# '()))) + (if #{tmp 55011}# (@apply (lambda () - (#{check 24585}# (reverse #{rreq 24589}#) #f)) - #{tmp 24591}#) - (let ((#{tmp 24714}# - ($sc-dispatch #{args 24588}# '(any . any)))) - (if (if #{tmp 24714}# + (#{check 55005}# (reverse #{rreq 55009}#) #f)) + #{tmp 55011}#) + (let ((#{tmp 55127}# + ($sc-dispatch #{args 55008}# '(any . any)))) + (if (if #{tmp 55127}# (@apply - (lambda (#{a 24718}# #{b 24719}#) - (if (symbol? #{a 24718}#) + (lambda (#{a 55131}# #{b 55132}#) + (if (symbol? #{a 55131}#) #t - (if (if (vector? #{a 24718}#) - (if (= (vector-length #{a 24718}#) 4) - (eq? (vector-ref #{a 24718}# 0) + (if (if (vector? #{a 55131}#) + (if (= (vector-length #{a 55131}#) 4) + (eq? (vector-ref #{a 55131}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{a 24718}# 1)) + (symbol? (vector-ref #{a 55131}# 1)) #f))) - #{tmp 24714}#) + #{tmp 55127}#) #f) (@apply - (lambda (#{a 24746}# #{b 24747}#) - (#{req 24584}# - #{b 24747}# - (cons #{a 24746}# #{rreq 24589}#))) - #{tmp 24714}#) - (let ((#{tmp 24748}# (list #{args 24588}#))) + (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 24750}#) - (if (symbol? #{r 24750}#) + (lambda (#{r 55163}#) + (if (symbol? #{r 55163}#) #t - (if (if (vector? #{r 24750}#) - (if (= (vector-length #{r 24750}#) 4) - (eq? (vector-ref #{r 24750}# 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 #{r 24750}# 1)) + (symbol? (vector-ref #{r 55163}# 1)) #f))) - #{tmp 24748}#) + #{tmp 55161}#) (@apply - (lambda (#{r 24780}#) - (#{check 24585}# - (reverse #{rreq 24589}#) - #{r 24780}#)) - #{tmp 24748}#) + (lambda (#{r 55193}#) + (#{check 55005}# + (reverse #{rreq 55009}#) + #{r 55193}#)) + #{tmp 55161}#) (syntax-violation 'lambda "invalid argument list" - #{orig-args 24583}# - #{args 24588}#))))))))) - (#{check 24585}# - (lambda (#{req 24911}# #{rest 24912}#) - (if (#{distinct-bound-ids? 4325}# - (if #{rest 24912}# - (cons #{rest 24912}# #{req 24911}#) - #{req 24911}#)) - (values #{req 24911}# #f #{rest 24912}# #f) + #{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 24583}#))))) - (#{req 24584}# #{orig-args 24583}# '())))) - (#{expand-simple-lambda 4344}# - (lambda (#{e 25028}# - #{r 25029}# - #{w 25030}# - #{s 25031}# - #{mod 25032}# - #{req 25033}# - #{rest 25034}# - #{meta 25035}# - #{body 25036}#) - (let ((#{ids 25037}# - (if #{rest 25034}# - (append #{req 25033}# (list #{rest 25034}#)) - #{req 25033}#))) - (let ((#{vars 25038}# - (map #{gen-var 4348}# #{ids 25037}#))) - (let ((#{labels 25039}# - (#{gen-labels 4305}# #{ids 25037}#))) - (#{build-simple-lambda 4278}# - #{s 25031}# - (map syntax->datum #{req 25033}#) - (if #{rest 25034}# - (syntax->datum #{rest 25034}#) + #{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 25038}# - #{meta 25035}# - (#{expand-body 4338}# - #{body 25036}# - (#{wrap 4327}# - (begin - (if (if (pair? #{e 25028}#) #{s 25031}# #f) - (set-source-properties! #{e 25028}# #{s 25031}#)) - #{e 25028}#) - #{w 25030}# - #{mod 25032}#) - (#{extend-var-env 4297}# - #{labels 25039}# - #{vars 25038}# - #{r 25029}#) - (#{make-binding-wrap 4316}# - #{ids 25037}# - #{labels 25039}# - #{w 25030}#) - #{mod 25032}#))))))) - (#{lambda*-formals 4345}# - (lambda (#{orig-args 25339}#) + #{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 25340}# - (lambda (#{args 25347}# #{rreq 25348}#) - (let ((#{tmp 25350}# ($sc-dispatch #{args 25347}# '()))) - (if #{tmp 25350}# + ((#{req 55933}# + (lambda (#{args 55940}# #{rreq 55941}#) + (let ((#{tmp 55943}# ($sc-dispatch #{args 55940}# '()))) + (if #{tmp 55943}# (@apply (lambda () - (#{check 25344}# - (reverse #{rreq 25348}#) + (#{check 55937}# + (reverse #{rreq 55941}#) '() #f '())) - #{tmp 25350}#) - (let ((#{tmp 25356}# - ($sc-dispatch #{args 25347}# '(any . any)))) - (if (if #{tmp 25356}# + #{tmp 55943}#) + (let ((#{tmp 56062}# + ($sc-dispatch #{args 55940}# '(any . any)))) + (if (if #{tmp 56062}# (@apply - (lambda (#{a 25360}# #{b 25361}#) - (if (symbol? #{a 25360}#) + (lambda (#{a 56066}# #{b 56067}#) + (if (symbol? #{a 56066}#) #t - (if (if (vector? #{a 25360}#) - (if (= (vector-length #{a 25360}#) 4) - (eq? (vector-ref #{a 25360}# 0) + (if (if (vector? #{a 56066}#) + (if (= (vector-length #{a 56066}#) 4) + (eq? (vector-ref #{a 56066}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{a 25360}# 1)) + (symbol? (vector-ref #{a 56066}# 1)) #f))) - #{tmp 25356}#) + #{tmp 56062}#) #f) (@apply - (lambda (#{a 25388}# #{b 25389}#) - (#{req 25340}# - #{b 25389}# - (cons #{a 25388}# #{rreq 25348}#))) - #{tmp 25356}#) - (let ((#{tmp 25390}# - ($sc-dispatch #{args 25347}# '(any . any)))) - (if (if #{tmp 25390}# + (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 25394}# #{b 25395}#) - (eq? (syntax->datum #{a 25394}#) #:optional)) - #{tmp 25390}#) + (lambda (#{a 56100}# #{b 56101}#) + (eq? (syntax->datum #{a 56100}#) #:optional)) + #{tmp 56096}#) #f) (@apply - (lambda (#{a 25396}# #{b 25397}#) - (#{opt 25341}# - #{b 25397}# - (reverse #{rreq 25348}#) + (lambda (#{a 56102}# #{b 56103}#) + (#{opt 55934}# + #{b 56103}# + (reverse #{rreq 55941}#) '())) - #{tmp 25390}#) - (let ((#{tmp 25400}# - ($sc-dispatch #{args 25347}# '(any . any)))) - (if (if #{tmp 25400}# + #{tmp 56096}#) + (let ((#{tmp 56106}# + ($sc-dispatch #{args 55940}# '(any . any)))) + (if (if #{tmp 56106}# (@apply - (lambda (#{a 25404}# #{b 25405}#) - (eq? (syntax->datum #{a 25404}#) #:key)) - #{tmp 25400}#) + (lambda (#{a 56110}# #{b 56111}#) + (eq? (syntax->datum #{a 56110}#) #:key)) + #{tmp 56106}#) #f) (@apply - (lambda (#{a 25406}# #{b 25407}#) - (#{key 25342}# - #{b 25407}# - (reverse #{rreq 25348}#) + (lambda (#{a 56112}# #{b 56113}#) + (#{key 55935}# + #{b 56113}# + (reverse #{rreq 55941}#) '() '())) - #{tmp 25400}#) - (let ((#{tmp 25410}# + #{tmp 56106}#) + (let ((#{tmp 56116}# ($sc-dispatch - #{args 25347}# + #{args 55940}# '(any any)))) - (if (if #{tmp 25410}# + (if (if #{tmp 56116}# (@apply - (lambda (#{a 25414}# #{b 25415}#) - (eq? (syntax->datum #{a 25414}#) + (lambda (#{a 56120}# #{b 56121}#) + (eq? (syntax->datum #{a 56120}#) #:rest)) - #{tmp 25410}#) + #{tmp 56116}#) #f) (@apply - (lambda (#{a 25416}# #{b 25417}#) - (#{rest 25343}# - #{b 25417}# - (reverse #{rreq 25348}#) + (lambda (#{a 56122}# #{b 56123}#) + (#{rest 55936}# + #{b 56123}# + (reverse #{rreq 55941}#) '() '())) - #{tmp 25410}#) - (let ((#{tmp 25420}# (list #{args 25347}#))) + #{tmp 56116}#) + (let ((#{tmp 56126}# (list #{args 55940}#))) (if (@apply - (lambda (#{r 25422}#) - (if (symbol? #{r 25422}#) + (lambda (#{r 56128}#) + (if (symbol? #{r 56128}#) #t - (if (if (vector? #{r 25422}#) + (if (if (vector? #{r 56128}#) (if (= (vector-length - #{r 25422}#) + #{r 56128}#) 4) (eq? (vector-ref - #{r 25422}# + #{r 56128}# 0) 'syntax-object) #f) #f) (symbol? - (vector-ref #{r 25422}# 1)) + (vector-ref #{r 56128}# 1)) #f))) - #{tmp 25420}#) + #{tmp 56126}#) (@apply - (lambda (#{r 25452}#) - (#{rest 25343}# - #{r 25452}# - (reverse #{rreq 25348}#) + (lambda (#{r 56158}#) + (#{rest 55936}# + #{r 56158}# + (reverse #{rreq 55941}#) '() '())) - #{tmp 25420}#) + #{tmp 56126}#) (syntax-violation 'lambda* "invalid argument list" - #{orig-args 25339}# - #{args 25347}#))))))))))))))) - (#{opt 25341}# - (lambda (#{args 25471}# #{req 25472}# #{ropt 25473}#) - (let ((#{tmp 25475}# ($sc-dispatch #{args 25471}# '()))) - (if #{tmp 25475}# + #{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 25344}# - #{req 25472}# - (reverse #{ropt 25473}#) + (#{check 55937}# + #{req 56178}# + (reverse #{ropt 56179}#) #f '())) - #{tmp 25475}#) - (let ((#{tmp 25481}# - ($sc-dispatch #{args 25471}# '(any . any)))) - (if (if #{tmp 25481}# + #{tmp 56181}#) + (let ((#{tmp 56302}# + ($sc-dispatch #{args 56177}# '(any . any)))) + (if (if #{tmp 56302}# (@apply - (lambda (#{a 25485}# #{b 25486}#) - (if (symbol? #{a 25485}#) + (lambda (#{a 56306}# #{b 56307}#) + (if (symbol? #{a 56306}#) #t - (if (if (vector? #{a 25485}#) - (if (= (vector-length #{a 25485}#) 4) - (eq? (vector-ref #{a 25485}# 0) + (if (if (vector? #{a 56306}#) + (if (= (vector-length #{a 56306}#) 4) + (eq? (vector-ref #{a 56306}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{a 25485}# 1)) + (symbol? (vector-ref #{a 56306}# 1)) #f))) - #{tmp 25481}#) + #{tmp 56302}#) #f) (@apply - (lambda (#{a 25513}# #{b 25514}#) - (#{opt 25341}# - #{b 25514}# - #{req 25472}# - (cons (cons #{a 25513}# + (lambda (#{a 56334}# #{b 56335}#) + (#{opt 55934}# + #{b 56335}# + #{req 56178}# + (cons (cons #{a 56334}# '(#(syntax-object #f ((top) #(ribcage #(a b) #((top) (top)) - #("i2358" "i2359")) + #("i26305" "i26306")) #(ribcage () () ()) #(ribcage #(args req ropt) #((top) (top) (top)) - #("i2348" "i2349" "i2350")) + #("i26295" "i26296" "i26297")) #(ribcage (check rest key opt req) ((top) (top) (top) (top) (top)) - ("i2294" - "i2292" - "i2290" - "i2288" - "i2286")) + ("i26241" + "i26239" + "i26237" + "i26235" + "i26233")) #(ribcage #(orig-args) #((top)) - #("i2285")) + #("i26232")) #(ribcage (lambda-var-list gen-var @@ -6269,7 +7012,7 @@ expand-local-syntax expand-body expand-macro - expand-application + expand-call expand-expr expand syntax-type @@ -6284,6 +7027,7 @@ valid-bound-ids? bound-id=? free-id=? + resolve-identifier id-var-name same-marks? join-marks @@ -6321,7 +7065,6 @@ id? nonsymbol-id? global-extend - lookup macros-only-env extend-var-env extend-env @@ -6347,6 +7090,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -6358,7 +7102,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -6379,8 +7123,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 @@ -6527,291 +7272,296 @@ (top) (top) (top) + (top) + (top) (top)) - ("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)))) - #{ropt 25473}#))) - #{tmp 25481}#) - (let ((#{tmp 25515}# + #{ropt 56179}#))) + #{tmp 56302}#) + (let ((#{tmp 56336}# ($sc-dispatch - #{args 25471}# + #{args 56177}# '((any any) . any)))) - (if (if #{tmp 25515}# + (if (if #{tmp 56336}# (@apply - (lambda (#{a 25519}# - #{init 25520}# - #{b 25521}#) - (if (symbol? #{a 25519}#) + (lambda (#{a 56340}# + #{init 56341}# + #{b 56342}#) + (if (symbol? #{a 56340}#) #t - (if (if (vector? #{a 25519}#) - (if (= (vector-length #{a 25519}#) 4) - (eq? (vector-ref #{a 25519}# 0) + (if (if (vector? #{a 56340}#) + (if (= (vector-length #{a 56340}#) 4) + (eq? (vector-ref #{a 56340}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{a 25519}# 1)) + (symbol? (vector-ref #{a 56340}# 1)) #f))) - #{tmp 25515}#) + #{tmp 56336}#) #f) (@apply - (lambda (#{a 25548}# #{init 25549}# #{b 25550}#) - (#{opt 25341}# - #{b 25550}# - #{req 25472}# - (cons (list #{a 25548}# #{init 25549}#) - #{ropt 25473}#))) - #{tmp 25515}#) - (let ((#{tmp 25551}# - ($sc-dispatch #{args 25471}# '(any . any)))) - (if (if #{tmp 25551}# + (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 25555}# #{b 25556}#) - (eq? (syntax->datum #{a 25555}#) #:key)) - #{tmp 25551}#) + (lambda (#{a 56376}# #{b 56377}#) + (eq? (syntax->datum #{a 56376}#) #:key)) + #{tmp 56372}#) #f) (@apply - (lambda (#{a 25557}# #{b 25558}#) - (#{key 25342}# - #{b 25558}# - #{req 25472}# - (reverse #{ropt 25473}#) + (lambda (#{a 56378}# #{b 56379}#) + (#{key 55935}# + #{b 56379}# + #{req 56178}# + (reverse #{ropt 56179}#) '())) - #{tmp 25551}#) - (let ((#{tmp 25561}# + #{tmp 56372}#) + (let ((#{tmp 56382}# ($sc-dispatch - #{args 25471}# + #{args 56177}# '(any any)))) - (if (if #{tmp 25561}# + (if (if #{tmp 56382}# (@apply - (lambda (#{a 25565}# #{b 25566}#) - (eq? (syntax->datum #{a 25565}#) + (lambda (#{a 56386}# #{b 56387}#) + (eq? (syntax->datum #{a 56386}#) #:rest)) - #{tmp 25561}#) + #{tmp 56382}#) #f) (@apply - (lambda (#{a 25567}# #{b 25568}#) - (#{rest 25343}# - #{b 25568}# - #{req 25472}# - (reverse #{ropt 25473}#) + (lambda (#{a 56388}# #{b 56389}#) + (#{rest 55936}# + #{b 56389}# + #{req 56178}# + (reverse #{ropt 56179}#) '())) - #{tmp 25561}#) - (let ((#{tmp 25571}# (list #{args 25471}#))) + #{tmp 56382}#) + (let ((#{tmp 56392}# (list #{args 56177}#))) (if (@apply - (lambda (#{r 25573}#) - (if (symbol? #{r 25573}#) + (lambda (#{r 56394}#) + (if (symbol? #{r 56394}#) #t - (if (if (vector? #{r 25573}#) + (if (if (vector? #{r 56394}#) (if (= (vector-length - #{r 25573}#) + #{r 56394}#) 4) (eq? (vector-ref - #{r 25573}# + #{r 56394}# 0) 'syntax-object) #f) #f) (symbol? - (vector-ref #{r 25573}# 1)) + (vector-ref #{r 56394}# 1)) #f))) - #{tmp 25571}#) + #{tmp 56392}#) (@apply - (lambda (#{r 25603}#) - (#{rest 25343}# - #{r 25603}# - #{req 25472}# - (reverse #{ropt 25473}#) + (lambda (#{r 56424}#) + (#{rest 55936}# + #{r 56424}# + #{req 56178}# + (reverse #{ropt 56179}#) '())) - #{tmp 25571}#) + #{tmp 56392}#) (syntax-violation 'lambda* "invalid optional argument list" - #{orig-args 25339}# - #{args 25471}#))))))))))))))) - (#{key 25342}# - (lambda (#{args 25622}# - #{req 25623}# - #{opt 25624}# - #{rkey 25625}#) - (let ((#{tmp 25627}# ($sc-dispatch #{args 25622}# '()))) - (if #{tmp 25627}# + #{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 25344}# - #{req 25623}# - #{opt 25624}# + (#{check 55937}# + #{req 56444}# + #{opt 56445}# #f - (cons #f (reverse #{rkey 25625}#)))) - #{tmp 25627}#) - (let ((#{tmp 25633}# - ($sc-dispatch #{args 25622}# '(any . any)))) - (if (if #{tmp 25633}# + (cons #f (reverse #{rkey 56446}#)))) + #{tmp 56448}#) + (let ((#{tmp 56570}# + ($sc-dispatch #{args 56443}# '(any . any)))) + (if (if #{tmp 56570}# (@apply - (lambda (#{a 25637}# #{b 25638}#) - (if (symbol? #{a 25637}#) + (lambda (#{a 56574}# #{b 56575}#) + (if (symbol? #{a 56574}#) #t - (if (if (vector? #{a 25637}#) - (if (= (vector-length #{a 25637}#) 4) - (eq? (vector-ref #{a 25637}# 0) + (if (if (vector? #{a 56574}#) + (if (= (vector-length #{a 56574}#) 4) + (eq? (vector-ref #{a 56574}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{a 25637}# 1)) + (symbol? (vector-ref #{a 56574}# 1)) #f))) - #{tmp 25633}#) + #{tmp 56570}#) #f) (@apply - (lambda (#{a 25665}# #{b 25666}#) - (let ((#{tmp 25667}# + (lambda (#{a 56602}# #{b 56603}#) + (let ((#{tmp 56604}# (symbol->keyword - (syntax->datum #{a 25665}#)))) - (#{key 25342}# - #{b 25666}# - #{req 25623}# - #{opt 25624}# - (cons (cons #{tmp 25667}# - (cons #{a 25665}# + (syntax->datum #{a 56602}#)))) + (#{key 55935}# + #{b 56603}# + #{req 56444}# + #{opt 56445}# + (cons (cons #{tmp 56604}# + (cons #{a 56602}# '(#(syntax-object #f ((top) @@ -6819,11 +7569,11 @@ #(ribcage #(k) #((top)) - #("i2421")) + #("i26368")) #(ribcage #(a b) #((top) (top)) - #("i2415" "i2416")) + #("i26362" "i26363")) #(ribcage () () ()) #(ribcage #(args req opt rkey) @@ -6831,10 +7581,10 @@ (top) (top) (top)) - #("i2404" - "i2405" - "i2406" - "i2407")) + #("i26351" + "i26352" + "i26353" + "i26354")) #(ribcage (check rest key opt req) ((top) @@ -6842,15 +7592,15 @@ (top) (top) (top)) - ("i2294" - "i2292" - "i2290" - "i2288" - "i2286")) + ("i26241" + "i26239" + "i26237" + "i26235" + "i26233")) #(ribcage #(orig-args) #((top)) - #("i2285")) + #("i26232")) #(ribcage (lambda-var-list gen-var @@ -6865,7 +7615,7 @@ expand-local-syntax expand-body expand-macro - expand-application + expand-call expand-expr expand syntax-type @@ -6880,6 +7630,7 @@ valid-bound-ids? bound-id=? free-id=? + resolve-identifier id-var-name same-marks? join-marks @@ -6917,7 +7668,6 @@ id? nonsymbol-id? global-extend - lookup macros-only-env extend-var-env extend-env @@ -6943,6 +7693,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -6954,7 +7705,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -6975,8 +7726,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 @@ -7123,924 +7875,1160 @@ (top) (top) (top) + (top) + (top) (top)) - ("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))))) - #{rkey 25625}#)))) - #{tmp 25633}#) - (let ((#{tmp 25670}# + #{rkey 56446}#)))) + #{tmp 56570}#) + (let ((#{tmp 56607}# ($sc-dispatch - #{args 25622}# + #{args 56443}# '((any any) . any)))) - (if (if #{tmp 25670}# + (if (if #{tmp 56607}# (@apply - (lambda (#{a 25674}# - #{init 25675}# - #{b 25676}#) - (if (symbol? #{a 25674}#) + (lambda (#{a 56611}# + #{init 56612}# + #{b 56613}#) + (if (symbol? #{a 56611}#) #t - (if (if (vector? #{a 25674}#) - (if (= (vector-length #{a 25674}#) 4) - (eq? (vector-ref #{a 25674}# 0) + (if (if (vector? #{a 56611}#) + (if (= (vector-length #{a 56611}#) 4) + (eq? (vector-ref #{a 56611}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{a 25674}# 1)) + (symbol? (vector-ref #{a 56611}# 1)) #f))) - #{tmp 25670}#) + #{tmp 56607}#) #f) (@apply - (lambda (#{a 25703}# #{init 25704}# #{b 25705}#) - (let ((#{tmp 25706}# + (lambda (#{a 56640}# #{init 56641}# #{b 56642}#) + (let ((#{tmp 56643}# (symbol->keyword - (syntax->datum #{a 25703}#)))) - (#{key 25342}# - #{b 25705}# - #{req 25623}# - #{opt 25624}# - (cons (list #{tmp 25706}# - #{a 25703}# - #{init 25704}#) - #{rkey 25625}#)))) - #{tmp 25670}#) - (let ((#{tmp 25709}# + (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 25622}# + #{args 56443}# '((any any any) . any)))) - (if (if #{tmp 25709}# + (if (if #{tmp 56646}# (@apply - (lambda (#{a 25713}# - #{init 25714}# - #{k 25715}# - #{b 25716}#) - (if (if (symbol? #{a 25713}#) + (lambda (#{a 56650}# + #{init 56651}# + #{k 56652}# + #{b 56653}#) + (if (if (symbol? #{a 56650}#) #t - (if (if (vector? #{a 25713}#) + (if (if (vector? #{a 56650}#) (if (= (vector-length - #{a 25713}#) + #{a 56650}#) 4) (eq? (vector-ref - #{a 25713}# + #{a 56650}# 0) 'syntax-object) #f) #f) (symbol? - (vector-ref #{a 25713}# 1)) + (vector-ref #{a 56650}# 1)) #f)) - (keyword? (syntax->datum #{k 25715}#)) + (keyword? (syntax->datum #{k 56652}#)) #f)) - #{tmp 25709}#) + #{tmp 56646}#) #f) (@apply - (lambda (#{a 25743}# - #{init 25744}# - #{k 25745}# - #{b 25746}#) - (#{key 25342}# - #{b 25746}# - #{req 25623}# - #{opt 25624}# - (cons (list #{k 25745}# - #{a 25743}# - #{init 25744}#) - #{rkey 25625}#))) - #{tmp 25709}#) - (let ((#{tmp 25747}# - ($sc-dispatch #{args 25622}# '(any)))) - (if (if #{tmp 25747}# + (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 25751}#) - (eq? (syntax->datum #{aok 25751}#) + (lambda (#{aok 56688}#) + (eq? (syntax->datum #{aok 56688}#) #:allow-other-keys)) - #{tmp 25747}#) + #{tmp 56684}#) #f) (@apply - (lambda (#{aok 25752}#) - (#{check 25344}# - #{req 25623}# - #{opt 25624}# + (lambda (#{aok 56689}#) + (#{check 55937}# + #{req 56444}# + #{opt 56445}# #f - (cons #t (reverse #{rkey 25625}#)))) - #{tmp 25747}#) - (let ((#{tmp 25755}# + (cons #t (reverse #{rkey 56446}#)))) + #{tmp 56684}#) + (let ((#{tmp 56808}# ($sc-dispatch - #{args 25622}# + #{args 56443}# '(any any any)))) - (if (if #{tmp 25755}# + (if (if #{tmp 56808}# (@apply - (lambda (#{aok 25759}# - #{a 25760}# - #{b 25761}#) + (lambda (#{aok 56812}# + #{a 56813}# + #{b 56814}#) (if (eq? (syntax->datum - #{aok 25759}#) + #{aok 56812}#) #:allow-other-keys) (eq? (syntax->datum - #{a 25760}#) + #{a 56813}#) #:rest) #f)) - #{tmp 25755}#) + #{tmp 56808}#) #f) (@apply - (lambda (#{aok 25762}# - #{a 25763}# - #{b 25764}#) - (#{rest 25343}# - #{b 25764}# - #{req 25623}# - #{opt 25624}# + (lambda (#{aok 56815}# + #{a 56816}# + #{b 56817}#) + (#{rest 55936}# + #{b 56817}# + #{req 56444}# + #{opt 56445}# (cons #t - (reverse #{rkey 25625}#)))) - #{tmp 25755}#) - (let ((#{tmp 25767}# + (reverse #{rkey 56446}#)))) + #{tmp 56808}#) + (let ((#{tmp 56820}# ($sc-dispatch - #{args 25622}# + #{args 56443}# '(any . any)))) - (if (if #{tmp 25767}# + (if (if #{tmp 56820}# (@apply - (lambda (#{aok 25771}# - #{r 25772}#) + (lambda (#{aok 56824}# + #{r 56825}#) (if (eq? (syntax->datum - #{aok 25771}#) + #{aok 56824}#) #:allow-other-keys) - (if (symbol? #{r 25772}#) + (if (symbol? #{r 56825}#) #t (if (if (vector? - #{r 25772}#) + #{r 56825}#) (if (= (vector-length - #{r 25772}#) + #{r 56825}#) 4) (eq? (vector-ref - #{r 25772}# + #{r 56825}# 0) 'syntax-object) #f) #f) (symbol? (vector-ref - #{r 25772}# + #{r 56825}# 1)) #f)) #f)) - #{tmp 25767}#) + #{tmp 56820}#) #f) (@apply - (lambda (#{aok 25799}# #{r 25800}#) - (#{rest 25343}# - #{r 25800}# - #{req 25623}# - #{opt 25624}# + (lambda (#{aok 56852}# #{r 56853}#) + (#{rest 55936}# + #{r 56853}# + #{req 56444}# + #{opt 56445}# (cons #t (reverse - #{rkey 25625}#)))) - #{tmp 25767}#) - (let ((#{tmp 25803}# + #{rkey 56446}#)))) + #{tmp 56820}#) + (let ((#{tmp 56856}# ($sc-dispatch - #{args 25622}# + #{args 56443}# '(any any)))) - (if (if #{tmp 25803}# + (if (if #{tmp 56856}# (@apply - (lambda (#{a 25807}# - #{b 25808}#) + (lambda (#{a 56860}# + #{b 56861}#) (eq? (syntax->datum - #{a 25807}#) + #{a 56860}#) #:rest)) - #{tmp 25803}#) + #{tmp 56856}#) #f) (@apply - (lambda (#{a 25809}# - #{b 25810}#) - (#{rest 25343}# - #{b 25810}# - #{req 25623}# - #{opt 25624}# + (lambda (#{a 56862}# + #{b 56863}#) + (#{rest 55936}# + #{b 56863}# + #{req 56444}# + #{opt 56445}# (cons #f (reverse - #{rkey 25625}#)))) - #{tmp 25803}#) - (let ((#{tmp 25813}# - (list #{args 25622}#))) + #{rkey 56446}#)))) + #{tmp 56856}#) + (let ((#{tmp 56866}# + (list #{args 56443}#))) (if (@apply - (lambda (#{r 25815}#) + (lambda (#{r 56868}#) (if (symbol? - #{r 25815}#) + #{r 56868}#) #t (if (if (vector? - #{r 25815}#) + #{r 56868}#) (if (= (vector-length - #{r 25815}#) + #{r 56868}#) 4) (eq? (vector-ref - #{r 25815}# + #{r 56868}# 0) 'syntax-object) #f) #f) (symbol? (vector-ref - #{r 25815}# + #{r 56868}# 1)) #f))) - #{tmp 25813}#) + #{tmp 56866}#) (@apply - (lambda (#{r 25845}#) - (#{rest 25343}# - #{r 25845}# - #{req 25623}# - #{opt 25624}# + (lambda (#{r 56898}#) + (#{rest 55936}# + #{r 56898}# + #{req 56444}# + #{opt 56445}# (cons #f (reverse - #{rkey 25625}#)))) - #{tmp 25813}#) + #{rkey 56446}#)))) + #{tmp 56866}#) (syntax-violation 'lambda* "invalid keyword argument list" - #{orig-args 25339}# - #{args 25622}#))))))))))))))))))))) - (#{rest 25343}# - (lambda (#{args 25873}# - #{req 25874}# - #{opt 25875}# - #{kw 25876}#) - (let ((#{tmp 25878}# (list #{args 25873}#))) + #{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 25880}#) - (if (symbol? #{r 25880}#) + (lambda (#{r 56933}#) + (if (symbol? #{r 56933}#) #t - (if (if (vector? #{r 25880}#) - (if (= (vector-length #{r 25880}#) 4) - (eq? (vector-ref #{r 25880}# 0) + (if (if (vector? #{r 56933}#) + (if (= (vector-length #{r 56933}#) 4) + (eq? (vector-ref #{r 56933}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{r 25880}# 1)) + (symbol? (vector-ref #{r 56933}# 1)) #f))) - #{tmp 25878}#) + #{tmp 56931}#) (@apply - (lambda (#{r 25910}#) - (#{check 25344}# - #{req 25874}# - #{opt 25875}# - #{r 25910}# - #{kw 25876}#)) - #{tmp 25878}#) + (lambda (#{r 56963}#) + (#{check 55937}# + #{req 56927}# + #{opt 56928}# + #{r 56963}# + #{kw 56929}#)) + #{tmp 56931}#) (syntax-violation 'lambda* "invalid rest argument" - #{orig-args 25339}# - #{args 25873}#))))) - (#{check 25344}# - (lambda (#{req 25914}# - #{opt 25915}# - #{rest 25916}# - #{kw 25917}#) - (if (#{distinct-bound-ids? 4325}# + #{orig-args 55932}# + #{args 56926}#))))) + (#{check 55937}# + (lambda (#{req 57091}# + #{opt 57092}# + #{rest 57093}# + #{kw 57094}#) + (if (#{distinct-bound-ids? 28262}# (append - #{req 25914}# - (map car #{opt 25915}#) - (if #{rest 25916}# (list #{rest 25916}#) '()) - (if (pair? #{kw 25917}#) - (map cadr (cdr #{kw 25917}#)) + #{req 57091}# + (map car #{opt 57092}#) + (if #{rest 57093}# (list #{rest 57093}#) '()) + (if (pair? #{kw 57094}#) + (map cadr (cdr #{kw 57094}#)) '()))) (values - #{req 25914}# - #{opt 25915}# - #{rest 25916}# - #{kw 25917}#) + #{req 57091}# + #{opt 57092}# + #{rest 57093}# + #{kw 57094}#) (syntax-violation 'lambda* "duplicate identifier in argument list" - #{orig-args 25339}#))))) - (#{req 25340}# #{orig-args 25339}# '())))) - (#{expand-lambda-case 4346}# - (lambda (#{e 26033}# - #{r 26034}# - #{w 26035}# - #{s 26036}# - #{mod 26037}# - #{get-formals 26038}# - #{clauses 26039}#) + #{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 26040}# - (lambda (#{req 26173}# - #{opt 26174}# - #{rest 26175}# - #{kw 26176}# - #{body 26177}#) - (let ((#{vars 26178}# - (map #{gen-var 4348}# #{req 26173}#)) - (#{labels 26179}# - (#{gen-labels 4305}# #{req 26173}#))) - (let ((#{r* 26180}# - (#{extend-var-env 4297}# - #{labels 26179}# - #{vars 26178}# - #{r 26034}#)) - (#{w* 26181}# - (#{make-binding-wrap 4316}# - #{req 26173}# - #{labels 26179}# - #{w 26035}#))) - (#{parse-opt 26041}# - (map syntax->datum #{req 26173}#) - #{opt 26174}# - #{rest 26175}# - #{kw 26176}# - #{body 26177}# - (reverse #{vars 26178}#) - #{r* 26180}# - #{w* 26181}# + ((#{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 26041}# - (lambda (#{req 26395}# - #{opt 26396}# - #{rest 26397}# - #{kw 26398}# - #{body 26399}# - #{vars 26400}# - #{r* 26401}# - #{w* 26402}# - #{out 26403}# - #{inits 26404}#) - (if (pair? #{opt 26396}#) - (let ((#{tmp 26405}# (car #{opt 26396}#))) - (let ((#{tmp 26406}# - ($sc-dispatch #{tmp 26405}# '(any any)))) - (if #{tmp 26406}# + (#{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 26408}# #{i 26409}#) - (let ((#{v 26410}# - (let ((#{id 26418}# - (if (if (vector? #{id 26408}#) + (lambda (#{id 57600}# #{i 57601}#) + (let ((#{v 57602}# + (let ((#{id 57610}# + (if (if (vector? #{id 57600}#) (if (= (vector-length - #{id 26408}#) + #{id 57600}#) 4) (eq? (vector-ref - #{id 26408}# + #{id 57600}# 0) 'syntax-object) #f) #f) - (vector-ref #{id 26408}# 1) - #{id 26408}#))) + (vector-ref #{id 57600}# 1) + #{id 57600}#))) (gensym (string-append - (symbol->string #{id 26418}#) + (symbol->string #{id 57610}#) " "))))) - (let ((#{l 26411}# - (#{gen-labels 4305}# (list #{v 26410}#)))) - (let ((#{r** 26412}# - (#{extend-var-env 4297}# - #{l 26411}# - (list #{v 26410}#) - #{r* 26401}#))) - (let ((#{w** 26413}# - (#{make-binding-wrap 4316}# - (list #{id 26408}#) - #{l 26411}# - #{w* 26402}#))) - (#{parse-opt 26041}# - #{req 26395}# - (cdr #{opt 26396}#) - #{rest 26397}# - #{kw 26398}# - #{body 26399}# - (cons #{v 26410}# #{vars 26400}#) - #{r** 26412}# - #{w** 26413}# - (cons (syntax->datum #{id 26408}#) - #{out 26403}#) - (cons (#{expand 4334}# - #{i 26409}# - #{r* 26401}# - #{w* 26402}# - #{mod 26037}#) - #{inits 26404}#))))))) - #{tmp 26406}#) + (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 26405}#)))) - (if #{rest 26397}# - (let ((#{v 26683}# - (let ((#{id 26693}# - (if (if (vector? #{rest 26397}#) - (if (= (vector-length #{rest 26397}#) + #{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 26397}# 0) + (eq? (vector-ref #{rest 57589}# 0) 'syntax-object) #f) #f) - (vector-ref #{rest 26397}# 1) - #{rest 26397}#))) + (vector-ref #{rest 57589}# 1) + #{rest 57589}#))) (gensym (string-append - (symbol->string #{id 26693}#) + (symbol->string #{id 57914}#) " "))))) - (let ((#{l 26684}# - (#{gen-labels 4305}# (list #{v 26683}#)))) - (let ((#{r* 26685}# - (#{extend-var-env 4297}# - #{l 26684}# - (list #{v 26683}#) - #{r* 26401}#))) - (let ((#{w* 26686}# - (#{make-binding-wrap 4316}# - (list #{rest 26397}#) - #{l 26684}# - #{w* 26402}#))) - (#{parse-kw 26042}# - #{req 26395}# - (if (pair? #{out 26403}#) - (reverse #{out 26403}#) + (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 26397}#) - (if (pair? #{kw 26398}#) - (cdr #{kw 26398}#) - #{kw 26398}#) - #{body 26399}# - (cons #{v 26683}# #{vars 26400}#) - #{r* 26685}# - #{w* 26686}# - (if (pair? #{kw 26398}#) (car #{kw 26398}#) #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 26404}#))))) - (#{parse-kw 26042}# - #{req 26395}# - (if (pair? #{out 26403}#) - (reverse #{out 26403}#) + #{inits 57596}#))))) + (#{parse-kw 57212}# + #{req 57587}# + (if (pair? #{out 57595}#) + (reverse #{out 57595}#) #f) #f - (if (pair? #{kw 26398}#) - (cdr #{kw 26398}#) - #{kw 26398}#) - #{body 26399}# - #{vars 26400}# - #{r* 26401}# - #{w* 26402}# - (if (pair? #{kw 26398}#) (car #{kw 26398}#) #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 26404}#))))) - (#{parse-kw 26042}# - (lambda (#{req 26891}# - #{opt 26892}# - #{rest 26893}# - #{kw 26894}# - #{body 26895}# - #{vars 26896}# - #{r* 26897}# - #{w* 26898}# - #{aok 26899}# - #{out 26900}# - #{inits 26901}#) - (if (pair? #{kw 26894}#) - (let ((#{tmp 26902}# (car #{kw 26894}#))) - (let ((#{tmp 26903}# - ($sc-dispatch #{tmp 26902}# '(any any any)))) - (if #{tmp 26903}# + #{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 26905}# #{id 26906}# #{i 26907}#) - (let ((#{v 26908}# - (let ((#{id 26916}# - (if (if (vector? #{id 26906}#) + (lambda (#{k 58147}# #{id 58148}# #{i 58149}#) + (let ((#{v 58150}# + (let ((#{id 58158}# + (if (if (vector? #{id 58148}#) (if (= (vector-length - #{id 26906}#) + #{id 58148}#) 4) (eq? (vector-ref - #{id 26906}# + #{id 58148}# 0) 'syntax-object) #f) #f) - (vector-ref #{id 26906}# 1) - #{id 26906}#))) + (vector-ref #{id 58148}# 1) + #{id 58148}#))) (gensym (string-append - (symbol->string #{id 26916}#) + (symbol->string #{id 58158}#) " "))))) - (let ((#{l 26909}# - (#{gen-labels 4305}# (list #{v 26908}#)))) - (let ((#{r** 26910}# - (#{extend-var-env 4297}# - #{l 26909}# - (list #{v 26908}#) - #{r* 26897}#))) - (let ((#{w** 26911}# - (#{make-binding-wrap 4316}# - (list #{id 26906}#) - #{l 26909}# - #{w* 26898}#))) - (#{parse-kw 26042}# - #{req 26891}# - #{opt 26892}# - #{rest 26893}# - (cdr #{kw 26894}#) - #{body 26895}# - (cons #{v 26908}# #{vars 26896}#) - #{r** 26910}# - #{w** 26911}# - #{aok 26899}# - (cons (list (syntax->datum #{k 26905}#) - (syntax->datum #{id 26906}#) - #{v 26908}#) - #{out 26900}#) - (cons (#{expand 4334}# - #{i 26907}# - #{r* 26897}# - #{w* 26898}# - #{mod 26037}#) - #{inits 26901}#))))))) - #{tmp 26903}#) + (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 26902}#)))) - (#{parse-body 26043}# - #{req 26891}# - #{opt 26892}# - #{rest 26893}# - (if (if #{aok 26899}# - #{aok 26899}# - (pair? #{out 26900}#)) - (cons #{aok 26899}# (reverse #{out 26900}#)) + #{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 26895}# - (reverse #{vars 26896}#) - #{r* 26897}# - #{w* 26898}# - (reverse #{inits 26901}#) + #{body 58137}# + (reverse #{vars 58138}#) + #{r* 58139}# + #{w* 58140}# + (reverse #{inits 58143}#) '())))) - (#{parse-body 26043}# - (lambda (#{req 27190}# - #{opt 27191}# - #{rest 27192}# - #{kw 27193}# - #{body 27194}# - #{vars 27195}# - #{r* 27196}# - #{w* 27197}# - #{inits 27198}# - #{meta 27199}#) - (let ((#{tmp 27201}# + (#{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 27194}# + #{body 58465}# '(any any . each-any)))) - (if (if #{tmp 27201}# + (if (if #{tmp 58472}# (@apply - (lambda (#{docstring 27205}# #{e1 27206}# #{e2 27207}#) - (string? (syntax->datum #{docstring 27205}#))) - #{tmp 27201}#) + (lambda (#{docstring 58476}# #{e1 58477}# #{e2 58478}#) + (string? (syntax->datum #{docstring 58476}#))) + #{tmp 58472}#) #f) (@apply - (lambda (#{docstring 27208}# #{e1 27209}# #{e2 27210}#) - (#{parse-body 26043}# - #{req 27190}# - #{opt 27191}# - #{rest 27192}# - #{kw 27193}# - (cons #{e1 27209}# #{e2 27210}#) - #{vars 27195}# - #{r* 27196}# - #{w* 27197}# - #{inits 27198}# + (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 27199}# + #{meta 58470}# (list (cons 'documentation - (syntax->datum #{docstring 27208}#)))))) - #{tmp 27201}#) - (let ((#{tmp 27211}# + (syntax->datum #{docstring 58479}#)))))) + #{tmp 58472}#) + (let ((#{tmp 58482}# ($sc-dispatch - #{body 27194}# + #{body 58465}# '(#(vector #(each (any . any))) any . each-any)))) - (if #{tmp 27211}# + (if #{tmp 58482}# (@apply - (lambda (#{k 27215}# - #{v 27216}# - #{e1 27217}# - #{e2 27218}#) - (#{parse-body 26043}# - #{req 27190}# - #{opt 27191}# - #{rest 27192}# - #{kw 27193}# - (cons #{e1 27217}# #{e2 27218}#) - #{vars 27195}# - #{r* 27196}# - #{w* 27197}# - #{inits 27198}# + (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 27199}# + #{meta 58470}# (syntax->datum - (map cons #{k 27215}# #{v 27216}#))))) - #{tmp 27211}#) - (let ((#{tmp 27219}# - ($sc-dispatch #{body 27194}# '(any . each-any)))) - (if #{tmp 27219}# + (map cons #{k 58486}# #{v 58487}#))))) + #{tmp 58482}#) + (let ((#{tmp 58490}# + ($sc-dispatch #{body 58465}# '(any . each-any)))) + (if #{tmp 58490}# (@apply - (lambda (#{e1 27223}# #{e2 27224}#) + (lambda (#{e1 58494}# #{e2 58495}#) (values - #{meta 27199}# - #{req 27190}# - #{opt 27191}# - #{rest 27192}# - #{kw 27193}# - #{inits 27198}# - #{vars 27195}# - (#{expand-body 4338}# - (cons #{e1 27223}# #{e2 27224}#) - (#{wrap 4327}# - (begin - (if (if (pair? #{e 26033}#) - #{s 26036}# + #{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) #f) - (set-source-properties! - #{e 26033}# - #{s 26036}#)) - #{e 26033}#) - #{w 26035}# - #{mod 26037}#) - #{r* 27196}# - #{w* 27197}# - #{mod 26037}#))) - #{tmp 27219}#) + (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 27194}#)))))))))) - (let ((#{tmp 26045}# - ($sc-dispatch #{clauses 26039}# '()))) - (if #{tmp 26045}# + #{body 58465}#)))))))))) + (let ((#{tmp 57215}# + ($sc-dispatch #{clauses 57209}# '()))) + (if #{tmp 57215}# (@apply (lambda () (values '() #f)) - #{tmp 26045}#) - (let ((#{tmp 26049}# + #{tmp 57215}#) + (let ((#{tmp 57219}# ($sc-dispatch - #{clauses 26039}# + #{clauses 57209}# '((any any . each-any) . #(each (any any . each-any)))))) - (if #{tmp 26049}# + (if #{tmp 57219}# (@apply - (lambda (#{args 26053}# - #{e1 26054}# - #{e2 26055}# - #{args* 26056}# - #{e1* 26057}# - #{e2* 26058}#) + (lambda (#{args 57223}# + #{e1 57224}# + #{e2 57225}# + #{args* 57226}# + #{e1* 57227}# + #{e2* 57228}#) (call-with-values (lambda () - (#{get-formals 26038}# #{args 26053}#)) - (lambda (#{req 26059}# - #{opt 26060}# - #{rest 26061}# - #{kw 26062}#) + (#{get-formals 57208}# #{args 57223}#)) + (lambda (#{req 57229}# + #{opt 57230}# + #{rest 57231}# + #{kw 57232}#) (call-with-values (lambda () - (#{parse-req 26040}# - #{req 26059}# - #{opt 26060}# - #{rest 26061}# - #{kw 26062}# - (cons #{e1 26054}# #{e2 26055}#))) - (lambda (#{meta 26129}# - #{req 26130}# - #{opt 26131}# - #{rest 26132}# - #{kw 26133}# - #{inits 26134}# - #{vars 26135}# - #{body 26136}#) + (#{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 4346}# - #{e 26033}# - #{r 26034}# - #{w 26035}# - #{s 26036}# - #{mod 26037}# - #{get-formals 26038}# - (map (lambda (#{tmp 2764 26137}# - #{tmp 2763 26138}# - #{tmp 2762 26139}#) - (cons #{tmp 2762 26139}# - (cons #{tmp 2763 26138}# - #{tmp 2764 26137}#))) - #{e2* 26058}# - #{e1* 26057}# - #{args* 26056}#))) - (lambda (#{meta* 26140}# #{else* 26141}#) + (#{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 26129}# #{meta* 26140}#) + (append #{meta 57301}# #{meta* 57312}#) (make-struct/no-tail - (vector-ref %expanded-vtables 14) - #{s 26036}# - #{req 26130}# - #{opt 26131}# - #{rest 26132}# - #{kw 26133}# - #{inits 26134}# - #{vars 26135}# - #{body 26136}# - #{else* 26141}#))))))))) - #{tmp 26049}#) + (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 26039}#)))))))) - (#{strip 4347}# - (lambda (#{x 27261}# #{w 27262}#) - (if (memq 'top (car #{w 27262}#)) - #{x 27261}# + #{clauses 57209}#)))))))) + (#{strip 28284}# + (lambda (#{x 58608}# #{w 58609}#) + (if (memq 'top (car #{w 58609}#)) + #{x 58608}# (letrec* - ((#{f 27263}# - (lambda (#{x 27266}#) - (if (if (vector? #{x 27266}#) - (if (= (vector-length #{x 27266}#) 4) - (eq? (vector-ref #{x 27266}# 0) 'syntax-object) + ((#{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) #f) - (#{strip 4347}# - (vector-ref #{x 27266}# 1) - (vector-ref #{x 27266}# 2)) - (if (pair? #{x 27266}#) - (let ((#{a 27285}# (#{f 27263}# (car #{x 27266}#))) - (#{d 27286}# (#{f 27263}# (cdr #{x 27266}#)))) - (if (if (eq? #{a 27285}# (car #{x 27266}#)) - (eq? #{d 27286}# (cdr #{x 27266}#)) + (#{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 27266}# - (cons #{a 27285}# #{d 27286}#))) - (if (vector? #{x 27266}#) - (let ((#{old 27289}# (vector->list #{x 27266}#))) - (let ((#{new 27290}# (map #{f 27263}# #{old 27289}#))) + #{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 27291}# - (lambda (#{l1 27367}# #{l2 27368}#) - (if (null? #{l1 27367}#) - #{x 27266}# - (if (eq? (car #{l1 27367}#) - (car #{l2 27368}#)) - (#{lp 27291}# - (cdr #{l1 27367}#) - (cdr #{l2 27368}#)) - (list->vector #{new 27290}#)))))) - (#{lp 27291}# #{old 27289}# #{new 27290}#)))) - #{x 27266}#)))))) - (#{f 27263}# #{x 27261}#))))) - (#{gen-var 4348}# - (lambda (#{id 26185}#) - (let ((#{id 26186}# - (if (if (vector? #{id 26185}#) - (if (= (vector-length #{id 26185}#) 4) - (eq? (vector-ref #{id 26185}# 0) 'syntax-object) + ((#{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) #f) - (vector-ref #{id 26185}# 1) - #{id 26185}#))) + (vector-ref #{id 57357}# 1) + #{id 57357}#))) (gensym - (string-append (symbol->string #{id 26186}#) " ")))))) + (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) @@ -8056,1903 +9044,2664 @@ 'let-syntax 'local-syntax #f)) - (#{global-extend 4300}# + (#{global-extend 28236}# 'core - 'fluid-let-syntax - (lambda (#{e 4469}# - #{r 4470}# - #{w 4471}# - #{s 4472}# - #{mod 4473}#) - (let ((#{tmp 4475}# + 'syntax-parameterize + (lambda (#{e 28413}# + #{r 28414}# + #{w 28415}# + #{s 28416}# + #{mod 28417}#) + (let ((#{tmp 28419}# ($sc-dispatch - #{e 4469}# + #{e 28413}# '(_ #(each (any any)) any . each-any)))) - (if (if #{tmp 4475}# + (if (if #{tmp 28419}# (@apply - (lambda (#{var 4479}# - #{val 4480}# - #{e1 4481}# - #{e2 4482}#) - (#{valid-bound-ids? 4324}# #{var 4479}#)) - #{tmp 4475}#) + (lambda (#{var 28423}# + #{val 28424}# + #{e1 28425}# + #{e2 28426}#) + (#{valid-bound-ids? 28261}# #{var 28423}#)) + #{tmp 28419}#) #f) (@apply - (lambda (#{var 4560}# - #{val 4561}# - #{e1 4562}# - #{e2 4563}#) - (let ((#{names 4564}# - (map (lambda (#{x 4754}#) - (#{id-var-name 4321}# #{x 4754}# #{w 4471}#)) - #{var 4560}#))) - (begin - (for-each - (lambda (#{id 4565}# #{n 4566}#) - (let ((#{atom-key 4567}# - (car (let ((#{t 4691}# - (assq #{n 4566}# #{r 4470}#))) - (if #{t 4691}# - (cdr #{t 4691}#) - (if (symbol? #{n 4566}#) - (let ((#{t 4696}# - (begin - (if (if (not #{mod 4473}#) - (current-module) - #f) - (warn "module system is booted, we should have a module" - #{n 4566}#)) - (let ((#{v 4733}# - (module-variable - (if #{mod 4473}# - (resolve-module - (cdr #{mod 4473}#)) - (current-module)) - #{n 4566}#))) - (if #{v 4733}# - (if (variable-bound? - #{v 4733}#) - (let ((#{val 4742}# - (variable-ref - #{v 4733}#))) - (if (macro? - #{val 4742}#) - (if (macro-type - #{val 4742}#) - (cons (macro-type - #{val 4742}#) - (macro-binding - #{val 4742}#)) - #f) - #f)) - #f) - #f))))) - (if #{t 4696}# - #{t 4696}# - '(global))) - '(displaced-lexical))))))) - (if (let ((#{t 4600}# #{atom-key 4567}#)) - (eqv? #{t 4600}# 'displaced-lexical)) - (syntax-violation - 'fluid-let-syntax - "identifier out of context" - #{e 4469}# - (#{wrap 4327}# - (begin - (if (if (pair? #{id 4565}#) #{s 4472}# #f) - (set-source-properties! - #{id 4565}# - #{s 4472}#)) - #{id 4565}#) - #{w 4471}# - #{mod 4473}#))))) - #{var 4560}# - #{names 4564}#) - (#{expand-body 4338}# - (cons #{e1 4562}# #{e2 4563}#) - (#{wrap 4327}# - (begin - (if (if (pair? #{e 4469}#) #{s 4472}# #f) - (set-source-properties! #{e 4469}# #{s 4472}#)) - #{e 4469}#) - #{w 4471}# - #{mod 4473}#) - (#{extend-env 4296}# - #{names 4564}# - (let ((#{trans-r 4840}# - (#{macros-only-env 4298}# #{r 4470}#))) - (map (lambda (#{x 4841}#) + (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 4340}# - (#{expand 4334}# - #{x 4841}# - #{trans-r 4840}# - #{w 4471}# - #{mod 4473}#) - #{mod 4473}#))) - #{val 4561}#)) - #{r 4470}#) - #{w 4471}# - #{mod 4473}#)))) - #{tmp 4475}#) + (#{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 - 'fluid-let-syntax + 'syntax-parameterize "bad syntax" - (#{wrap 4327}# - (begin - (if (if (pair? #{e 4469}#) #{s 4472}# #f) - (set-source-properties! #{e 4469}# #{s 4472}#)) - #{e 4469}#) - #{w 4471}# - #{mod 4473}#)))))) + (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 - (lambda (#{e 5050}# - #{r 5051}# - #{w 5052}# - #{s 5053}# - #{mod 5054}#) - (let ((#{tmp 5056}# ($sc-dispatch #{e 5050}# '(_ any)))) - (if #{tmp 5056}# + (lambda (#{e 29386}# + #{r 29387}# + #{w 29388}# + #{s 29389}# + #{mod 29390}#) + (let ((#{tmp 29392}# + ($sc-dispatch #{e 29386}# '(_ any)))) + (if #{tmp 29392}# (@apply - (lambda (#{e 5059}#) - (let ((#{exp 5063}# - (#{strip 4347}# #{e 5059}# #{w 5052}#))) + (lambda (#{e 29395}#) + (let ((#{exp 29399}# + (#{strip 28284}# #{e 29395}# #{w 29388}#))) (make-struct/no-tail (vector-ref %expanded-vtables 1) - #{s 5053}# - #{exp 5063}#))) - #{tmp 5056}#) + #{s 29389}# + #{exp 29399}#))) + #{tmp 29392}#) (syntax-violation 'quote "bad syntax" - (#{wrap 4327}# - (begin - (if (if (pair? #{e 5050}#) #{s 5053}# #f) - (set-source-properties! #{e 5050}# #{s 5053}#)) - #{e 5050}#) - #{w 5052}# - #{mod 5054}#))))))) - (#{global-extend 4300}# + (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 5290}# - (lambda (#{src 5392}# - #{e 5393}# - #{r 5394}# - #{maps 5395}# - #{ellipsis? 5396}# - #{mod 5397}#) - (if (if (symbol? #{e 5393}#) + ((#{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 5393}#) - (if (= (vector-length #{e 5393}#) 4) - (eq? (vector-ref #{e 5393}# 0) 'syntax-object) + (if (if (vector? #{e 30137}#) + (if (= (vector-length #{e 30137}#) 4) + (eq? (vector-ref #{e 30137}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{e 5393}# 1)) + (symbol? (vector-ref #{e 30137}# 1)) #f)) - (let ((#{label 5424}# - (#{id-var-name 4321}# #{e 5393}# '(())))) - (let ((#{b 5425}# - (let ((#{t 5562}# (assq #{label 5424}# #{r 5394}#))) - (if #{t 5562}# - (cdr #{t 5562}#) - (if (symbol? #{label 5424}#) - (let ((#{t 5567}# - (begin - (if (if (not #{mod 5397}#) - (current-module) - #f) - (warn "module system is booted, we should have a module" - #{label 5424}#)) - (let ((#{v 5604}# - (module-variable - (if #{mod 5397}# - (resolve-module - (cdr #{mod 5397}#)) - (current-module)) - #{label 5424}#))) - (if #{v 5604}# - (if (variable-bound? #{v 5604}#) - (let ((#{val 5613}# - (variable-ref - #{v 5604}#))) - (if (macro? #{val 5613}#) - (if (macro-type - #{val 5613}#) - (cons (macro-type - #{val 5613}#) - (macro-binding - #{val 5613}#)) - #f) - #f)) - #f) - #f))))) - (if #{t 5567}# #{t 5567}# '(global))) - '(displaced-lexical)))))) - (if (eq? (car #{b 5425}#) 'syntax) + (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 () - (let ((#{var.lev 5458}# (cdr #{b 5425}#))) - (#{gen-ref 5291}# - #{src 5392}# - (car #{var.lev 5458}#) - (cdr #{var.lev 5458}#) - #{maps 5395}#))) - (lambda (#{var 5554}# #{maps 5555}#) - (values (list 'ref #{var 5554}#) #{maps 5555}#))) - (if (#{ellipsis? 5396}# #{e 5393}#) + (#{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 5392}#) - (values (list 'quote #{e 5393}#) #{maps 5395}#))))) - (let ((#{tmp 5625}# - ($sc-dispatch #{e 5393}# '(any any)))) - (if (if #{tmp 5625}# + #{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 5629}# #{e 5630}#) - (#{ellipsis? 5396}# #{dots 5629}#)) - #{tmp 5625}#) + (lambda (#{dots 30185}# #{e 30186}#) + (#{ellipsis? 30140}# #{dots 30185}#)) + #{tmp 30181}#) #f) (@apply - (lambda (#{dots 5631}# #{e 5632}#) - (#{gen-syntax 5290}# - #{src 5392}# - #{e 5632}# - #{r 5394}# - #{maps 5395}# - (lambda (#{x 5633}#) #f) - #{mod 5397}#)) - #{tmp 5625}#) - (let ((#{tmp 5634}# - ($sc-dispatch #{e 5393}# '(any any . any)))) - (if (if #{tmp 5634}# + (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 5638}# #{dots 5639}# #{y 5640}#) - (#{ellipsis? 5396}# #{dots 5639}#)) - #{tmp 5634}#) + (lambda (#{x 30194}# #{dots 30195}# #{y 30196}#) + (#{ellipsis? 30140}# #{dots 30195}#)) + #{tmp 30190}#) #f) (@apply - (lambda (#{x 5641}# #{dots 5642}# #{y 5643}#) + (lambda (#{x 30197}# #{dots 30198}# #{y 30199}#) (letrec* - ((#{f 5644}# - (lambda (#{y 5652}# #{k 5653}#) - (let ((#{tmp 5655}# + ((#{f 30200}# + (lambda (#{y 30208}# #{k 30209}#) + (let ((#{tmp 30211}# ($sc-dispatch - #{y 5652}# + #{y 30208}# '(any . any)))) - (if (if #{tmp 5655}# + (if (if #{tmp 30211}# (@apply - (lambda (#{dots 5659}# #{y 5660}#) - (#{ellipsis? 5396}# - #{dots 5659}#)) - #{tmp 5655}#) + (lambda (#{dots 30215}# + #{y 30216}#) + (#{ellipsis? 30140}# + #{dots 30215}#)) + #{tmp 30211}#) #f) (@apply - (lambda (#{dots 5661}# #{y 5662}#) - (#{f 5644}# - #{y 5662}# - (lambda (#{maps 5663}#) + (lambda (#{dots 30217}# #{y 30218}#) + (#{f 30200}# + #{y 30218}# + (lambda (#{maps 30219}#) (call-with-values (lambda () - (#{k 5653}# - (cons '() #{maps 5663}#))) - (lambda (#{x 5664}# - #{maps 5665}#) - (if (null? (car #{maps 5665}#)) + (#{k 30209}# + (cons '() #{maps 30219}#))) + (lambda (#{x 30220}# + #{maps 30221}#) + (if (null? (car #{maps 30221}#)) (syntax-violation 'syntax "extra ellipsis" - #{src 5392}#) + #{src 30136}#) (values - (let ((#{map-env 5669}# - (car #{maps 5665}#))) + (let ((#{map-env 30225}# + (car #{maps 30221}#))) (list 'apply '(primitive append) - (#{gen-map 5293}# - #{x 5664}# - #{map-env 5669}#))) - (cdr #{maps 5665}#)))))))) - #{tmp 5655}#) + (#{gen-map 29708}# + #{x 30220}# + #{map-env 30225}#))) + (cdr #{maps 30221}#)))))))) + #{tmp 30211}#) (call-with-values (lambda () - (#{gen-syntax 5290}# - #{src 5392}# - #{y 5652}# - #{r 5394}# - #{maps 5395}# - #{ellipsis? 5396}# - #{mod 5397}#)) - (lambda (#{y 5672}# #{maps 5673}#) + (#{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 5653}# #{maps 5673}#)) - (lambda (#{x 5674}# #{maps 5675}#) + (#{k 30209}# #{maps 30229}#)) + (lambda (#{x 30230}# + #{maps 30231}#) (values - (if (equal? #{y 5672}# ''()) - #{x 5674}# + (if (equal? #{y 30228}# ''()) + #{x 30230}# (list 'append - #{x 5674}# - #{y 5672}#)) - #{maps 5675}#)))))))))) - (#{f 5644}# - #{y 5643}# - (lambda (#{maps 5647}#) + #{x 30230}# + #{y 30228}#)) + #{maps 30231}#)))))))))) + (#{f 30200}# + #{y 30199}# + (lambda (#{maps 30203}#) (call-with-values (lambda () - (#{gen-syntax 5290}# - #{src 5392}# - #{x 5641}# - #{r 5394}# - (cons '() #{maps 5647}#) - #{ellipsis? 5396}# - #{mod 5397}#)) - (lambda (#{x 5648}# #{maps 5649}#) - (if (null? (car #{maps 5649}#)) + (#{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 5392}#) + #{src 30136}#) (values - (#{gen-map 5293}# - #{x 5648}# - (car #{maps 5649}#)) - (cdr #{maps 5649}#))))))))) - #{tmp 5634}#) - (let ((#{tmp 5691}# - ($sc-dispatch #{e 5393}# '(any . any)))) - (if #{tmp 5691}# + (#{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 5695}# #{y 5696}#) + (lambda (#{x 30251}# #{y 30252}#) (call-with-values (lambda () - (#{gen-syntax 5290}# - #{src 5392}# - #{x 5695}# - #{r 5394}# - #{maps 5395}# - #{ellipsis? 5396}# - #{mod 5397}#)) - (lambda (#{x 5697}# #{maps 5698}#) + (#{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 5290}# - #{src 5392}# - #{y 5696}# - #{r 5394}# - #{maps 5698}# - #{ellipsis? 5396}# - #{mod 5397}#)) - (lambda (#{y 5699}# #{maps 5700}#) + (#{gen-syntax 29705}# + #{src 30136}# + #{y 30252}# + #{r 30138}# + #{maps 30254}# + #{ellipsis? 30140}# + #{mod 30141}#)) + (lambda (#{y 30255}# #{maps 30256}#) (values - (let ((#{atom-key 5705}# - (car #{y 5699}#))) - (if (eqv? #{atom-key 5705}# 'quote) - (if (eq? (car #{x 5697}#) 'quote) + (let ((#{atom-key 30261}# + (car #{y 30255}#))) + (if (eqv? #{atom-key 30261}# 'quote) + (if (eq? (car #{x 30253}#) 'quote) (list 'quote - (cons (car (cdr #{x 5697}#)) - (car (cdr #{y 5699}#)))) - (if (eq? (car (cdr #{y 5699}#)) + (cons (car (cdr #{x 30253}#)) + (car (cdr #{y 30255}#)))) + (if (eq? (car (cdr #{y 30255}#)) '()) - (list 'list #{x 5697}#) + (list 'list #{x 30253}#) (list 'cons - #{x 5697}# - #{y 5699}#))) - (if (eqv? #{atom-key 5705}# 'list) + #{x 30253}# + #{y 30255}#))) + (if (eqv? #{atom-key 30261}# + 'list) (cons 'list - (cons #{x 5697}# - (cdr #{y 5699}#))) + (cons #{x 30253}# + (cdr #{y 30255}#))) (list 'cons - #{x 5697}# - #{y 5699}#)))) - #{maps 5700}#)))))) - #{tmp 5691}#) - (let ((#{tmp 5734}# + #{x 30253}# + #{y 30255}#)))) + #{maps 30256}#)))))) + #{tmp 30247}#) + (let ((#{tmp 30290}# ($sc-dispatch - #{e 5393}# + #{e 30137}# '#(vector (any . each-any))))) - (if #{tmp 5734}# + (if #{tmp 30290}# (@apply - (lambda (#{e1 5738}# #{e2 5739}#) + (lambda (#{e1 30294}# #{e2 30295}#) (call-with-values (lambda () - (#{gen-syntax 5290}# - #{src 5392}# - (cons #{e1 5738}# #{e2 5739}#) - #{r 5394}# - #{maps 5395}# - #{ellipsis? 5396}# - #{mod 5397}#)) - (lambda (#{e 5740}# #{maps 5741}#) + (#{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 5740}#) 'list) - (cons 'vector (cdr #{e 5740}#)) - (if (eq? (car #{e 5740}#) 'quote) + (if (eq? (car #{e 30296}#) 'list) + (cons 'vector (cdr #{e 30296}#)) + (if (eq? (car #{e 30296}#) 'quote) (list 'quote (list->vector - (car (cdr #{e 5740}#)))) - (list 'list->vector #{e 5740}#))) - #{maps 5741}#)))) - #{tmp 5734}#) + (car (cdr #{e 30296}#)))) + (list 'list->vector #{e 30296}#))) + #{maps 30297}#)))) + #{tmp 30290}#) (values - (list 'quote #{e 5393}#) - #{maps 5395}#)))))))))))) - (#{gen-ref 5291}# - (lambda (#{src 5768}# - #{var 5769}# - #{level 5770}# - #{maps 5771}#) - (if (= #{level 5770}# 0) - (values #{var 5769}# #{maps 5771}#) - (if (null? #{maps 5771}#) + (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 5768}#) + #{src 30324}#) (call-with-values (lambda () - (#{gen-ref 5291}# - #{src 5768}# - #{var 5769}# - (#{1-}# #{level 5770}#) - (cdr #{maps 5771}#))) - (lambda (#{outer-var 5772}# #{outer-maps 5773}#) - (let ((#{b 5774}# - (assq #{outer-var 5772}# (car #{maps 5771}#)))) - (if #{b 5774}# - (values (cdr #{b 5774}#) #{maps 5771}#) - (let ((#{inner-var 5776}# + (#{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 5776}# - (cons (cons (cons #{outer-var 5772}# - #{inner-var 5776}#) - (car #{maps 5771}#)) - #{outer-maps 5773}#))))))))))) - (#{gen-map 5293}# - (lambda (#{e 5790}# #{map-env 5791}#) - (let ((#{formals 5792}# (map cdr #{map-env 5791}#)) - (#{actuals 5793}# - (map (lambda (#{x 5795}#) - (list 'ref (car #{x 5795}#))) - #{map-env 5791}#))) - (if (eq? (car #{e 5790}#) 'ref) - (car #{actuals 5793}#) + #{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 5796}#) - (if (eq? (car #{x 5796}#) 'ref) - (memq (car (cdr #{x 5796}#)) #{formals 5792}#) + (lambda (#{x 30352}#) + (if (eq? (car #{x 30352}#) 'ref) + (memq (car (cdr #{x 30352}#)) #{formals 30348}#) #f)) - (cdr #{e 5790}#)) + (cdr #{e 30346}#)) (cons 'map - (cons (list 'primitive (car #{e 5790}#)) - (map (let ((#{r 5798}# + (cons (list 'primitive (car #{e 30346}#)) + (map (let ((#{r 30354}# (map cons - #{formals 5792}# - #{actuals 5793}#))) - (lambda (#{x 5799}#) - (cdr (assq (car (cdr #{x 5799}#)) - #{r 5798}#)))) - (cdr #{e 5790}#)))) + #{formals 30348}# + #{actuals 30349}#))) + (lambda (#{x 30355}#) + (cdr (assq (car (cdr #{x 30355}#)) + #{r 30354}#)))) + (cdr #{e 30346}#)))) (cons 'map - (cons (list 'lambda #{formals 5792}# #{e 5790}#) - #{actuals 5793}#))))))) - (#{regen 5297}# - (lambda (#{x 5801}#) - (let ((#{atom-key 5802}# (car #{x 5801}#))) - (if (eqv? #{atom-key 5802}# 'ref) - (let ((#{name 5812}# (car (cdr #{x 5801}#))) - (#{var 5813}# (car (cdr #{x 5801}#)))) + (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 5812}# - #{var 5813}#)) - (if (eqv? #{atom-key 5802}# 'primitive) - (let ((#{name 5825}# (car (cdr #{x 5801}#)))) - (if (equal? (module-name (current-module)) '(guile)) - (make-struct/no-tail - (vector-ref %expanded-vtables 7) - #f - #{name 5825}#) - (make-struct/no-tail - (vector-ref %expanded-vtables 5) - #f - '(guile) - #{name 5825}# - #f))) - (if (eqv? #{atom-key 5802}# 'quote) - (let ((#{exp 5843}# (car (cdr #{x 5801}#)))) + #{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 2) + #f + #{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 5843}#)) - (if (eqv? #{atom-key 5802}# 'lambda) - (if (list? (car (cdr #{x 5801}#))) - (let ((#{req 5854}# (car (cdr #{x 5801}#))) - (#{vars 5856}# (car (cdr #{x 5801}#))) - (#{exp 5858}# - (#{regen 5297}# - (car (cdr (cdr #{x 5801}#)))))) - (let ((#{body 5863}# + #{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 14) + (vector-ref %expanded-vtables 15) #f - #{req 5854}# + #{req 30402}# #f #f #f '() - #{vars 5856}# - #{exp 5858}# + #{vars 30404}# + #{exp 30406}# #f))) (make-struct/no-tail - (vector-ref %expanded-vtables 13) + (vector-ref %expanded-vtables 14) #f '() - #{body 5863}#))) - (error "how did we get here" #{x 5801}#)) - (let ((#{fun-exp 5879}# - (let ((#{name 5888}# (car #{x 5801}#))) - (if (equal? - (module-name (current-module)) - '(guile)) - (make-struct/no-tail - (vector-ref %expanded-vtables 7) - #f - #{name 5888}#) - (make-struct/no-tail - (vector-ref %expanded-vtables 5) - #f - '(guile) - #{name 5888}# - #f)))) - (#{arg-exps 5880}# - (map #{regen 5297}# (cdr #{x 5801}#)))) + #{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 11) + (vector-ref %expanded-vtables 12) #f - #{fun-exp 5879}# - #{arg-exps 5880}#)))))))))) - (lambda (#{e 5298}# - #{r 5299}# - #{w 5300}# - #{s 5301}# - #{mod 5302}#) - (let ((#{e 5303}# - (#{wrap 4327}# - (begin - (if (if (pair? #{e 5298}#) #{s 5301}# #f) - (set-source-properties! #{e 5298}# #{s 5301}#)) - #{e 5298}#) - #{w 5300}# - #{mod 5302}#))) - (let ((#{tmp 5305}# ($sc-dispatch #{e 5303}# '(_ any)))) - (if #{tmp 5305}# - (@apply - (lambda (#{x 5330}#) - (call-with-values - (lambda () - (#{gen-syntax 5290}# - #{e 5303}# - #{x 5330}# - #{r 5299}# - '() - #{ellipsis? 4342}# - #{mod 5302}#)) - (lambda (#{e 5384}# #{maps 5385}#) - (#{regen 5297}# #{e 5384}#)))) - #{tmp 5305}#) - (syntax-violation - 'syntax - "bad `syntax' form" - #{e 5303}#))))))) - (#{global-extend 4300}# + #{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 29768}#) + (call-with-values + (lambda () + (#{gen-syntax 29705}# + #{e 29718}# + #{x 29768}# + #{r 29714}# + '() + #{ellipsis? 28279}# + #{mod 29717}#)) + (lambda (#{e 29845}# #{maps 29846}#) + (#{regen 29712}# #{e 29845}#)))) + #{tmp 29720}#) + (syntax-violation + 'syntax + "bad `syntax' form" + #{e 29718}#)))))))) + (#{global-extend 28236}# 'core 'lambda - (lambda (#{e 6081}# - #{r 6082}# - #{w 6083}# - #{s 6084}# - #{mod 6085}#) - (let ((#{tmp 6087}# - ($sc-dispatch #{e 6081}# '(_ any any . each-any)))) - (if #{tmp 6087}# + (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 6091}# #{e1 6092}# #{e2 6093}#) + (lambda (#{args 30669}# #{e1 30670}# #{e2 30671}#) (call-with-values (lambda () - (#{lambda-formals 4343}# #{args 6091}#)) - (lambda (#{req 6096}# - #{opt 6097}# - #{rest 6098}# - #{kw 6099}#) + (#{lambda-formals 28280}# #{args 30669}#)) + (lambda (#{req 30674}# + #{opt 30675}# + #{rest 30676}# + #{kw 30677}#) (letrec* - ((#{lp 6100}# - (lambda (#{body 6103}# #{meta 6104}#) - (let ((#{tmp 6106}# + ((#{lp 30678}# + (lambda (#{body 30681}# #{meta 30682}#) + (let ((#{tmp 30684}# ($sc-dispatch - #{body 6103}# + #{body 30681}# '(any any . each-any)))) - (if (if #{tmp 6106}# + (if (if #{tmp 30684}# (@apply - (lambda (#{docstring 6110}# - #{e1 6111}# - #{e2 6112}#) + (lambda (#{docstring 30688}# + #{e1 30689}# + #{e2 30690}#) (string? - (syntax->datum #{docstring 6110}#))) - #{tmp 6106}#) + (syntax->datum #{docstring 30688}#))) + #{tmp 30684}#) #f) (@apply - (lambda (#{docstring 6113}# - #{e1 6114}# - #{e2 6115}#) - (#{lp 6100}# - (cons #{e1 6114}# #{e2 6115}#) + (lambda (#{docstring 30691}# + #{e1 30692}# + #{e2 30693}#) + (#{lp 30678}# + (cons #{e1 30692}# #{e2 30693}#) (append - #{meta 6104}# + #{meta 30682}# (list (cons 'documentation (syntax->datum - #{docstring 6113}#)))))) - #{tmp 6106}#) - (let ((#{tmp 6116}# + #{docstring 30691}#)))))) + #{tmp 30684}#) + (let ((#{tmp 30694}# ($sc-dispatch - #{body 6103}# + #{body 30681}# '(#(vector #(each (any . any))) any . each-any)))) - (if #{tmp 6116}# + (if #{tmp 30694}# (@apply - (lambda (#{k 6120}# - #{v 6121}# - #{e1 6122}# - #{e2 6123}#) - (#{lp 6100}# - (cons #{e1 6122}# #{e2 6123}#) + (lambda (#{k 30698}# + #{v 30699}# + #{e1 30700}# + #{e2 30701}#) + (#{lp 30678}# + (cons #{e1 30700}# #{e2 30701}#) (append - #{meta 6104}# + #{meta 30682}# (syntax->datum (map cons - #{k 6120}# - #{v 6121}#))))) - #{tmp 6116}#) - (#{expand-simple-lambda 4344}# - #{e 6081}# - #{r 6082}# - #{w 6083}# - #{s 6084}# - #{mod 6085}# - #{req 6096}# - #{rest 6098}# - #{meta 6104}# - #{body 6103}#)))))))) - (#{lp 6100}# (cons #{e1 6092}# #{e2 6093}#) '()))))) - #{tmp 6087}#) + #{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 6081}#))))) - (#{global-extend 4300}# + #{e 30659}#))))) + (#{global-extend 28236}# 'core 'lambda* - (lambda (#{e 6414}# - #{r 6415}# - #{w 6416}# - #{s 6417}# - #{mod 6418}#) - (let ((#{tmp 6420}# - ($sc-dispatch #{e 6414}# '(_ any any . each-any)))) - (if #{tmp 6420}# + (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 6424}# #{e1 6425}# #{e2 6426}#) + (lambda (#{args 31091}# #{e1 31092}# #{e2 31093}#) (call-with-values (lambda () - (#{expand-lambda-case 4346}# - #{e 6414}# - #{r 6415}# - #{w 6416}# - #{s 6417}# - #{mod 6418}# - #{lambda*-formals 4345}# - (list (cons #{args 6424}# - (cons #{e1 6425}# #{e2 6426}#))))) - (lambda (#{meta 6429}# #{lcase 6430}#) + (#{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 13) - #{s 6417}# - #{meta 6429}# - #{lcase 6430}#)))) - #{tmp 6420}#) + (vector-ref %expanded-vtables 14) + #{s 31084}# + #{meta 31096}# + #{lcase 31097}#)))) + #{tmp 31087}#) (syntax-violation 'lambda "bad lambda*" - #{e 6414}#))))) - (#{global-extend 4300}# + #{e 31081}#))))) + (#{global-extend 28236}# 'core 'case-lambda - (lambda (#{e 6600}# - #{r 6601}# - #{w 6602}# - #{s 6603}# - #{mod 6604}#) - (let ((#{tmp 6606}# + (lambda (#{e 31260}# + #{r 31261}# + #{w 31262}# + #{s 31263}# + #{mod 31264}#) + (let ((#{tmp 31266}# ($sc-dispatch - #{e 6600}# + #{e 31260}# '(_ (any any . each-any) . #(each (any any . each-any)))))) - (if #{tmp 6606}# + (if #{tmp 31266}# (@apply - (lambda (#{args 6610}# - #{e1 6611}# - #{e2 6612}# - #{args* 6613}# - #{e1* 6614}# - #{e2* 6615}#) + (lambda (#{args 31270}# + #{e1 31271}# + #{e2 31272}# + #{args* 31273}# + #{e1* 31274}# + #{e2* 31275}#) (call-with-values (lambda () - (#{expand-lambda-case 4346}# - #{e 6600}# - #{r 6601}# - #{w 6602}# - #{s 6603}# - #{mod 6604}# - #{lambda-formals 4343}# - (cons (cons #{args 6610}# - (cons #{e1 6611}# #{e2 6612}#)) - (map (lambda (#{tmp 3263 6618}# - #{tmp 3262 6619}# - #{tmp 3261 6620}#) - (cons #{tmp 3261 6620}# - (cons #{tmp 3262 6619}# - #{tmp 3263 6618}#))) - #{e2* 6615}# - #{e1* 6614}# - #{args* 6613}#)))) - (lambda (#{meta 6621}# #{lcase 6622}#) + (#{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 13) - #{s 6603}# - #{meta 6621}# - #{lcase 6622}#)))) - #{tmp 6606}#) + (vector-ref %expanded-vtables 14) + #{s 31263}# + #{meta 31281}# + #{lcase 31282}#)))) + #{tmp 31266}#) (syntax-violation 'case-lambda "bad case-lambda" - #{e 6600}#))))) - (#{global-extend 4300}# + #{e 31260}#))))) + (#{global-extend 28236}# 'core 'case-lambda* - (lambda (#{e 6784}# - #{r 6785}# - #{w 6786}# - #{s 6787}# - #{mod 6788}#) - (let ((#{tmp 6790}# + (lambda (#{e 31451}# + #{r 31452}# + #{w 31453}# + #{s 31454}# + #{mod 31455}#) + (let ((#{tmp 31457}# ($sc-dispatch - #{e 6784}# + #{e 31451}# '(_ (any any . each-any) . #(each (any any . each-any)))))) - (if #{tmp 6790}# + (if #{tmp 31457}# (@apply - (lambda (#{args 6794}# - #{e1 6795}# - #{e2 6796}# - #{args* 6797}# - #{e1* 6798}# - #{e2* 6799}#) + (lambda (#{args 31461}# + #{e1 31462}# + #{e2 31463}# + #{args* 31464}# + #{e1* 31465}# + #{e2* 31466}#) (call-with-values (lambda () - (#{expand-lambda-case 4346}# - #{e 6784}# - #{r 6785}# - #{w 6786}# - #{s 6787}# - #{mod 6788}# - #{lambda*-formals 4345}# - (cons (cons #{args 6794}# - (cons #{e1 6795}# #{e2 6796}#)) - (map (lambda (#{tmp 3298 6802}# - #{tmp 3297 6803}# - #{tmp 3296 6804}#) - (cons #{tmp 3296 6804}# - (cons #{tmp 3297 6803}# - #{tmp 3298 6802}#))) - #{e2* 6799}# - #{e1* 6798}# - #{args* 6797}#)))) - (lambda (#{meta 6805}# #{lcase 6806}#) + (#{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 13) - #{s 6787}# - #{meta 6805}# - #{lcase 6806}#)))) - #{tmp 6790}#) + (vector-ref %expanded-vtables 14) + #{s 31454}# + #{meta 31472}# + #{lcase 31473}#)))) + #{tmp 31457}#) (syntax-violation 'case-lambda "bad case-lambda*" - #{e 6784}#))))) - (#{global-extend 4300}# + #{e 31451}#))))) + (#{global-extend 28236}# 'core 'let (letrec* - ((#{expand-let 6997}# - (lambda (#{e 7146}# - #{r 7147}# - #{w 7148}# - #{s 7149}# - #{mod 7150}# - #{constructor 7151}# - #{ids 7152}# - #{vals 7153}# - #{exps 7154}#) - (if (not (#{valid-bound-ids? 4324}# #{ids 7152}#)) + ((#{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 7146}#) - (let ((#{labels 7232}# - (#{gen-labels 4305}# #{ids 7152}#)) - (#{new-vars 7233}# - (map #{gen-var 4348}# #{ids 7152}#))) - (let ((#{nw 7234}# - (#{make-binding-wrap 4316}# - #{ids 7152}# - #{labels 7232}# - #{w 7148}#)) - (#{nr 7235}# - (#{extend-var-env 4297}# - #{labels 7232}# - #{new-vars 7233}# - #{r 7147}#))) - (#{constructor 7151}# - #{s 7149}# - (map syntax->datum #{ids 7152}#) - #{new-vars 7233}# - (map (lambda (#{x 7252}#) - (#{expand 4334}# - #{x 7252}# - #{r 7147}# - #{w 7148}# - #{mod 7150}#)) - #{vals 7153}#) - (#{expand-body 4338}# - #{exps 7154}# - (#{source-wrap 4328}# - #{e 7146}# - #{nw 7234}# - #{s 7149}# - #{mod 7150}#) - #{nr 7235}# - #{nw 7234}# - #{mod 7150}#)))))))) - (lambda (#{e 6998}# - #{r 6999}# - #{w 7000}# - #{s 7001}# - #{mod 7002}#) - (let ((#{tmp 7004}# + #{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 6998}# + #{e 31682}# '(_ #(each (any any)) any . each-any)))) - (if (if #{tmp 7004}# + (if (if #{tmp 31688}# (@apply - (lambda (#{id 7008}# - #{val 7009}# - #{e1 7010}# - #{e2 7011}#) - (and-map #{id? 4302}# #{id 7008}#)) - #{tmp 7004}#) + (lambda (#{id 31692}# + #{val 31693}# + #{e1 31694}# + #{e2 31695}#) + (and-map #{id? 28238}# #{id 31692}#)) + #{tmp 31688}#) #f) (@apply - (lambda (#{id 7027}# - #{val 7028}# - #{e1 7029}# - #{e2 7030}#) - (#{expand-let 6997}# - #{e 6998}# - #{r 6999}# - #{w 7000}# - #{s 7001}# - #{mod 7002}# - #{build-let 4284}# - #{id 7027}# - #{val 7028}# - (cons #{e1 7029}# #{e2 7030}#))) - #{tmp 7004}#) - (let ((#{tmp 7060}# + (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 6998}# + #{e 31682}# '(_ any #(each (any any)) any . each-any)))) - (if (if #{tmp 7060}# + (if (if #{tmp 31729}# (@apply - (lambda (#{f 7064}# - #{id 7065}# - #{val 7066}# - #{e1 7067}# - #{e2 7068}#) - (if (if (symbol? #{f 7064}#) + (lambda (#{f 31733}# + #{id 31734}# + #{val 31735}# + #{e1 31736}# + #{e2 31737}#) + (if (if (symbol? #{f 31733}#) #t - (if (if (vector? #{f 7064}#) - (if (= (vector-length #{f 7064}#) 4) - (eq? (vector-ref #{f 7064}# 0) + (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 7064}# 1)) + (symbol? (vector-ref #{f 31733}# 1)) #f)) - (and-map #{id? 4302}# #{id 7065}#) + (and-map #{id? 28238}# #{id 31734}#) #f)) - #{tmp 7060}#) + #{tmp 31729}#) #f) (@apply - (lambda (#{f 7110}# - #{id 7111}# - #{val 7112}# - #{e1 7113}# - #{e2 7114}#) - (#{expand-let 6997}# - #{e 6998}# - #{r 6999}# - #{w 7000}# - #{s 7001}# - #{mod 7002}# - #{build-named-let 4285}# - (cons #{f 7110}# #{id 7111}#) - #{val 7112}# - (cons #{e1 7113}# #{e2 7114}#))) - #{tmp 7060}#) + (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" - (#{wrap 4327}# - (begin - (if (if (pair? #{e 6998}#) #{s 7001}# #f) - (set-source-properties! #{e 6998}# #{s 7001}#)) - #{e 6998}#) - #{w 7000}# - #{mod 7002}#))))))))) - (#{global-extend 4300}# + (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) + (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 7694}# - #{r 7695}# - #{w 7696}# - #{s 7697}# - #{mod 7698}#) - (let ((#{tmp 7700}# + (lambda (#{e 32475}# + #{r 32476}# + #{w 32477}# + #{s 32478}# + #{mod 32479}#) + (let ((#{tmp 32481}# ($sc-dispatch - #{e 7694}# + #{e 32475}# '(_ #(each (any any)) any . each-any)))) - (if (if #{tmp 7700}# + (if (if #{tmp 32481}# (@apply - (lambda (#{id 7704}# - #{val 7705}# - #{e1 7706}# - #{e2 7707}#) - (and-map #{id? 4302}# #{id 7704}#)) - #{tmp 7700}#) + (lambda (#{id 32485}# + #{val 32486}# + #{e1 32487}# + #{e2 32488}#) + (and-map #{id? 28238}# #{id 32485}#)) + #{tmp 32481}#) #f) (@apply - (lambda (#{id 7723}# - #{val 7724}# - #{e1 7725}# - #{e2 7726}#) - (if (not (#{valid-bound-ids? 4324}# #{id 7723}#)) + (lambda (#{id 32504}# + #{val 32505}# + #{e1 32506}# + #{e2 32507}#) + (if (not (#{valid-bound-ids? 28261}# #{id 32504}#)) (syntax-violation 'letrec "duplicate bound variable" - #{e 7694}#) - (let ((#{labels 7816}# - (#{gen-labels 4305}# #{id 7723}#)) - (#{new-vars 7817}# - (map #{gen-var 4348}# #{id 7723}#))) - (let ((#{w 7818}# - (#{make-binding-wrap 4316}# - #{id 7723}# - #{labels 7816}# - #{w 7696}#)) - (#{r 7819}# - (#{extend-var-env 4297}# - #{labels 7816}# - #{new-vars 7817}# - #{r 7695}#))) - (#{build-letrec 4286}# - #{s 7697}# + #{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 7723}#) - #{new-vars 7817}# - (map (lambda (#{x 7906}#) - (#{expand 4334}# - #{x 7906}# - #{r 7819}# - #{w 7818}# - #{mod 7698}#)) - #{val 7724}#) - (#{expand-body 4338}# - (cons #{e1 7725}# #{e2 7726}#) - (#{wrap 4327}# - (begin - (if (if (pair? #{e 7694}#) #{s 7697}# #f) - (set-source-properties! #{e 7694}# #{s 7697}#)) - #{e 7694}#) - #{w 7818}# - #{mod 7698}#) - #{r 7819}# - #{w 7818}# - #{mod 7698}#)))))) - #{tmp 7700}#) + (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" - (#{wrap 4327}# - (begin - (if (if (pair? #{e 7694}#) #{s 7697}# #f) - (set-source-properties! #{e 7694}# #{s 7697}#)) - #{e 7694}#) - #{w 7696}# - #{mod 7698}#)))))) - (#{global-extend 4300}# + (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 8323}# - #{r 8324}# - #{w 8325}# - #{s 8326}# - #{mod 8327}#) - (let ((#{tmp 8329}# + (lambda (#{e 33286}# + #{r 33287}# + #{w 33288}# + #{s 33289}# + #{mod 33290}#) + (let ((#{tmp 33292}# ($sc-dispatch - #{e 8323}# + #{e 33286}# '(_ #(each (any any)) any . each-any)))) - (if (if #{tmp 8329}# + (if (if #{tmp 33292}# (@apply - (lambda (#{id 8333}# - #{val 8334}# - #{e1 8335}# - #{e2 8336}#) - (and-map #{id? 4302}# #{id 8333}#)) - #{tmp 8329}#) + (lambda (#{id 33296}# + #{val 33297}# + #{e1 33298}# + #{e2 33299}#) + (and-map #{id? 28238}# #{id 33296}#)) + #{tmp 33292}#) #f) (@apply - (lambda (#{id 8352}# - #{val 8353}# - #{e1 8354}# - #{e2 8355}#) - (if (not (#{valid-bound-ids? 4324}# #{id 8352}#)) + (lambda (#{id 33315}# + #{val 33316}# + #{e1 33317}# + #{e2 33318}#) + (if (not (#{valid-bound-ids? 28261}# #{id 33315}#)) (syntax-violation 'letrec* "duplicate bound variable" - #{e 8323}#) - (let ((#{labels 8445}# - (#{gen-labels 4305}# #{id 8352}#)) - (#{new-vars 8446}# - (map #{gen-var 4348}# #{id 8352}#))) - (let ((#{w 8447}# - (#{make-binding-wrap 4316}# - #{id 8352}# - #{labels 8445}# - #{w 8325}#)) - (#{r 8448}# - (#{extend-var-env 4297}# - #{labels 8445}# - #{new-vars 8446}# - #{r 8324}#))) - (#{build-letrec 4286}# - #{s 8326}# + #{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 8352}#) - #{new-vars 8446}# - (map (lambda (#{x 8535}#) - (#{expand 4334}# - #{x 8535}# - #{r 8448}# - #{w 8447}# - #{mod 8327}#)) - #{val 8353}#) - (#{expand-body 4338}# - (cons #{e1 8354}# #{e2 8355}#) - (#{wrap 4327}# - (begin - (if (if (pair? #{e 8323}#) #{s 8326}# #f) - (set-source-properties! #{e 8323}# #{s 8326}#)) - #{e 8323}#) - #{w 8447}# - #{mod 8327}#) - #{r 8448}# - #{w 8447}# - #{mod 8327}#)))))) - #{tmp 8329}#) + (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) + #{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*" - (#{wrap 4327}# - (begin - (if (if (pair? #{e 8323}#) #{s 8326}# #f) - (set-source-properties! #{e 8323}# #{s 8326}#)) - #{e 8323}#) - #{w 8325}# - #{mod 8327}#)))))) - (#{global-extend 4300}# + (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 8994}# - #{r 8995}# - #{w 8996}# - #{s 8997}# - #{mod 8998}#) - (let ((#{tmp 9000}# - ($sc-dispatch #{e 8994}# '(_ any any)))) - (if (if #{tmp 9000}# + (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 (#{id 9004}# #{val 9005}#) - (if (symbol? #{id 9004}#) + (lambda (#{id 34115}# #{val 34116}#) + (if (symbol? #{id 34115}#) #t - (if (if (vector? #{id 9004}#) - (if (= (vector-length #{id 9004}#) 4) - (eq? (vector-ref #{id 9004}# 0) 'syntax-object) + (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 9004}# 1)) + (symbol? (vector-ref #{id 34115}# 1)) #f))) - #{tmp 9000}#) + #{tmp 34111}#) #f) (@apply - (lambda (#{id 9032}# #{val 9033}#) - (let ((#{n 9034}# - (#{id-var-name 4321}# #{id 9032}# #{w 8996}#)) - (#{id-mod 9035}# - (if (if (vector? #{id 9032}#) - (if (= (vector-length #{id 9032}#) 4) - (eq? (vector-ref #{id 9032}# 0) 'syntax-object) - #f) - #f) - (vector-ref #{id 9032}# 3) - #{mod 8998}#))) - (let ((#{b 9036}# - (let ((#{t 9698}# (assq #{n 9034}# #{r 8995}#))) - (if #{t 9698}# - (cdr #{t 9698}#) - (if (symbol? #{n 9034}#) - (let ((#{t 9703}# - (begin - (if (if (not #{id-mod 9035}#) - (current-module) - #f) - (warn "module system is booted, we should have a module" - #{n 9034}#)) - (let ((#{v 9740}# - (module-variable - (if #{id-mod 9035}# - (resolve-module - (cdr #{id-mod 9035}#)) - (current-module)) - #{n 9034}#))) - (if #{v 9740}# - (if (variable-bound? #{v 9740}#) - (let ((#{val 9749}# - (variable-ref - #{v 9740}#))) - (if (macro? #{val 9749}#) - (if (macro-type - #{val 9749}#) - (cons (macro-type - #{val 9749}#) - (macro-binding - #{val 9749}#)) - #f) - #f)) - #f) - #f))))) - (if #{t 9703}# #{t 9703}# '(global))) - '(displaced-lexical)))))) - (let ((#{atom-key 9037}# (car #{b 9036}#))) - (if (let ((#{t 9069}# #{atom-key 9037}#)) - (eqv? #{t 9069}# 'lexical)) - (#{build-lexical-assignment 4273}# - #{s 8997}# - (syntax->datum #{id 9032}#) - (cdr #{b 9036}#) - (#{expand 4334}# - #{val 9033}# - #{r 8995}# - #{w 8996}# - #{mod 8998}#)) - (if (let ((#{t 9344}# #{atom-key 9037}#)) - (eqv? #{t 9344}# 'global)) - (#{build-global-assignment 4276}# - #{s 8997}# - #{n 9034}# - (#{expand 4334}# - #{val 9033}# - #{r 8995}# - #{w 8996}# - #{mod 8998}#) - #{id-mod 9035}#) - (if (let ((#{t 9589}# #{atom-key 9037}#)) - (eqv? #{t 9589}# 'macro)) - (let ((#{p 9652}# (cdr #{b 9036}#))) - (if (procedure-property - #{p 9652}# - 'variable-transformer) - (#{expand 4334}# - (#{expand-macro 4337}# - #{p 9652}# - #{e 8994}# - #{r 8995}# - #{w 8996}# - #{s 8997}# - #f - #{mod 8998}#) - #{r 8995}# - '(()) - #{mod 8998}#) - (syntax-violation - 'set! - "not a variable transformer" - (#{wrap 4327}# - #{e 8994}# - #{w 8996}# - #{mod 8998}#) - (#{wrap 4327}# - #{id 9032}# - #{w 8996}# - #{id-mod 9035}#)))) - (if (eqv? #{atom-key 9037}# 'displaced-lexical) - (syntax-violation - 'set! - "identifier out of context" - (#{wrap 4327}# - #{id 9032}# - #{w 8996}# - #{mod 8998}#)) - (syntax-violation - 'set! - "bad set!" - (#{wrap 4327}# - (begin - (if (if (pair? #{e 8994}#) #{s 8997}# #f) - (set-source-properties! - #{e 8994}# - #{s 8997}#)) - #{e 8994}#) - #{w 8996}# - #{mod 8998}#)))))))))) - #{tmp 9000}#) - (let ((#{tmp 9845}# + (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 8994}# + #{e 34105}# '(_ (any . each-any) any)))) - (if #{tmp 9845}# + (if #{tmp 34955}# (@apply - (lambda (#{head 9849}# #{tail 9850}# #{val 9851}#) + (lambda (#{head 34959}# #{tail 34960}# #{val 34961}#) (call-with-values (lambda () - (#{syntax-type 4333}# - #{head 9849}# - #{r 8995}# + (#{syntax-type 28270}# + #{head 34959}# + #{r 34106}# '(()) #f #f - #{mod 8998}# + #{mod 34109}# #t)) - (lambda (#{type 9854}# - #{value 9855}# - #{ee 9856}# - #{ww 9857}# - #{ss 9858}# - #{modmod 9859}#) - (if (eqv? #{type 9854}# 'module-ref) - (let ((#{val 9863}# - (#{expand 4334}# - #{val 9851}# - #{r 8995}# - #{w 8996}# - #{mod 8998}#))) + (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 9855}# - (cons #{head 9849}# #{tail 9850}#) - #{r 8995}# - #{w 8996}#)) - (lambda (#{e 9864}# - #{r 9865}# - #{w 9866}# - #{s* 9867}# - #{mod 9868}#) - (let ((#{tmp 9870}# (list #{e 9864}#))) + (#{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 9872}#) - (if (symbol? #{e 9872}#) + (lambda (#{e 34982}#) + (if (symbol? #{e 34982}#) #t - (if (if (vector? #{e 9872}#) + (if (if (vector? #{e 34982}#) (if (= (vector-length - #{e 9872}#) + #{e 34982}#) 4) (eq? (vector-ref - #{e 9872}# + #{e 34982}# 0) 'syntax-object) #f) #f) (symbol? - (vector-ref #{e 9872}# 1)) + (vector-ref #{e 34982}# 1)) #f))) - #{tmp 9870}#) + #{tmp 34980}#) (@apply - (lambda (#{e 9902}#) - (#{build-global-assignment 4276}# - #{s 8997}# - (syntax->datum #{e 9902}#) - #{val 9863}# - #{mod 9868}#)) - #{tmp 9870}#) + (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 9864}#)))))) - (#{build-application 4269}# - #{s 8997}# - (let ((#{e 10127}# - (list '#(syntax-object - setter - ((top) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(type value ee ww ss modmod) - #((top) - (top) - (top) - (top) - (top) - (top)) - #("i3544" - "i3545" - "i3546" - "i3547" - "i3548" - "i3549")) - #(ribcage - #(head tail val) - #((top) (top) (top)) - #("i3530" "i3531" "i3532")) - #(ribcage () () ()) - #(ribcage - #(e r w s mod) - #((top) - (top) - (top) - (top) - (top)) - #("i3494" - "i3495" - "i3496" - "i3497" - "i3498")) - #(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=? - 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)) - ("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 9849}#))) - (call-with-values - (lambda () - (#{syntax-type 4333}# - #{e 10127}# - #{r 8995}# - #{w 8996}# - (#{source-annotation 4295}# #{e 10127}#) - #f - #{mod 8998}# - #f)) - (lambda (#{type 10134}# - #{value 10135}# - #{e 10136}# - #{w 10137}# - #{s 10138}# - #{mod 10139}#) - (#{expand-expr 4335}# - #{type 10134}# - #{value 10135}# - #{e 10136}# - #{r 8995}# - #{w 10137}# - #{s 10138}# - #{mod 10139}#)))) - (map (lambda (#{e 10143}#) - (call-with-values - (lambda () - (#{syntax-type 4333}# - #{e 10143}# - #{r 8995}# - #{w 8996}# - (#{source-annotation 4295}# - #{e 10143}#) - #f - #{mod 8998}# - #f)) - (lambda (#{type 10158}# - #{value 10159}# - #{e 10160}# - #{w 10161}# - #{s 10162}# - #{mod 10163}#) - (#{expand-expr 4335}# - #{type 10158}# - #{value 10159}# - #{e 10160}# - #{r 8995}# - #{w 10161}# - #{s 10162}# - #{mod 10163}#)))) + #{e 34974}#)))))) + (#{build-call 28205}# + #{s 34108}# + (#{expand 28271}# + (list '#(syntax-object + setter + ((top) + #(ribcage () () ()) + #(ribcage () () ()) + #(ribcage + #(type value ee ww ss modmod) + #((top) + (top) + (top) + (top) + (top) + (top)) + #("i27483" + "i27484" + "i27485" + "i27486" + "i27487" + "i27488")) + #(ribcage + #(head tail val) + #((top) (top) (top)) + #("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 + 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)) + #{head 34959}#) + #{r 34106}# + #{w 34107}# + #{mod 34109}#) + (map (lambda (#{e 35325}#) + (#{expand 28271}# + #{e 35325}# + #{r 34106}# + #{w 34107}# + #{mod 34109}#)) (append - #{tail 9850}# - (list #{val 9851}#)))))))) - #{tmp 9845}#) + #{tail 34960}# + (list #{val 34961}#)))))))) + #{tmp 34955}#) (syntax-violation 'set! "bad set!" - (#{wrap 4327}# - (begin - (if (if (pair? #{e 8994}#) #{s 8997}# #f) - (set-source-properties! #{e 8994}# #{s 8997}#)) - #{e 8994}#) - #{w 8996}# - #{mod 8998}#)))))))) + (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 10206}# #{r 10207}# #{w 10208}#) - (let ((#{tmp 10210}# - ($sc-dispatch #{e 10206}# '(_ each-any any)))) - (if (if #{tmp 10210}# + (lambda (#{e 35518}# #{r 35519}# #{w 35520}#) + (let ((#{tmp 35522}# + ($sc-dispatch #{e 35518}# '(_ each-any any)))) + (if (if #{tmp 35522}# (@apply - (lambda (#{mod 10213}# #{id 10214}#) - (if (and-map #{id? 4302}# #{mod 10213}#) - (if (symbol? #{id 10214}#) + (lambda (#{mod 35525}# #{id 35526}#) + (if (and-map #{id? 28238}# #{mod 35525}#) + (if (symbol? #{id 35526}#) #t - (if (if (vector? #{id 10214}#) - (if (= (vector-length #{id 10214}#) 4) - (eq? (vector-ref #{id 10214}# 0) + (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 10214}# 1)) + (symbol? (vector-ref #{id 35526}# 1)) #f)) #f)) - #{tmp 10210}#) + #{tmp 35522}#) #f) (@apply - (lambda (#{mod 10254}# #{id 10255}#) + (lambda (#{mod 35566}# #{id 35567}#) (values - (syntax->datum #{id 10255}#) - #{r 10207}# - #{w 10208}# + (syntax->datum #{id 35567}#) + #{r 35519}# + #{w 35520}# #f (syntax->datum (cons '#(syntax-object @@ -9961,12 +11710,12 @@ #(ribcage #(mod id) #((top) (top)) - #("i3591" "i3592")) + #("i27530" "i27531")) #(ribcage () () ()) #(ribcage #(e r w) #((top) (top) (top)) - #("i3579" "i3580" "i3581")) + #("i27518" "i27519" "i27520")) #(ribcage (lambda-var-list gen-var @@ -9981,7 +11730,7 @@ expand-local-syntax expand-body expand-macro - expand-application + expand-call expand-expr expand syntax-type @@ -9996,6 +11745,7 @@ valid-bound-ids? bound-id=? free-id=? + resolve-identifier id-var-name same-marks? join-marks @@ -10033,7 +11783,6 @@ id? nonsymbol-id? global-extend - lookup macros-only-env extend-var-env extend-env @@ -10059,6 +11808,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -10070,7 +11820,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -10091,8 +11841,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 @@ -10239,214 +11990,219 @@ (top) (top) (top) + (top) + (top) (top)) - ("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 10254}#)))) - #{tmp 10210}#) + #{mod 35566}#)))) + #{tmp 35522}#) (syntax-violation #f "source expression failed to match any pattern" - #{e 10206}#)))))) - (#{global-extend 4300}# + #{e 35518}#)))))) + (#{global-extend 28236}# 'module-ref '@@ - (lambda (#{e 10347}# #{r 10348}# #{w 10349}#) + (lambda (#{e 35667}# #{r 35668}# #{w 35669}#) (letrec* - ((#{remodulate 10350}# - (lambda (#{x 10385}# #{mod 10386}#) - (if (pair? #{x 10385}#) - (cons (#{remodulate 10350}# - (car #{x 10385}#) - #{mod 10386}#) - (#{remodulate 10350}# - (cdr #{x 10385}#) - #{mod 10386}#)) - (if (if (vector? #{x 10385}#) - (if (= (vector-length #{x 10385}#) 4) - (eq? (vector-ref #{x 10385}# 0) 'syntax-object) + ((#{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 10400}# - (#{remodulate 10350}# - (vector-ref #{x 10385}# 1) - #{mod 10386}#)) - (#{wrap 10401}# (vector-ref #{x 10385}# 2))) + (let ((#{expression 35903}# + (#{remodulate 35670}# + (vector-ref #{x 35888}# 1) + #{mod 35889}#)) + (#{wrap 35904}# (vector-ref #{x 35888}# 2))) (vector 'syntax-object - #{expression 10400}# - #{wrap 10401}# - #{mod 10386}#)) - (if (vector? #{x 10385}#) - (let ((#{n 10409}# (vector-length #{x 10385}#))) - (let ((#{v 10410}# (make-vector #{n 10409}#))) + #{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 10411}# - (lambda (#{i 10458}#) - (if (= #{i 10458}# #{n 10409}#) - #{v 10410}# + ((#{loop 35914}# + (lambda (#{i 35969}#) + (if (= #{i 35969}# #{n 35912}#) + #{v 35913}# (begin (vector-set! - #{v 10410}# - #{i 10458}# - (#{remodulate 10350}# - (vector-ref #{x 10385}# #{i 10458}#) - #{mod 10386}#)) - (#{loop 10411}# (#{1+}# #{i 10458}#))))))) - (#{loop 10411}# 0)))) - #{x 10385}#)))))) - (let ((#{tmp 10352}# - ($sc-dispatch #{e 10347}# '(_ each-any any)))) - (if (if #{tmp 10352}# + #{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 10356}# #{exp 10357}#) - (and-map #{id? 4302}# #{mod 10356}#)) - #{tmp 10352}#) + (lambda (#{mod 35676}# #{exp 35677}#) + (and-map #{id? 28238}# #{mod 35676}#)) + #{tmp 35672}#) #f) (@apply - (lambda (#{mod 10373}# #{exp 10374}#) - (let ((#{mod 10375}# + (lambda (#{mod 35693}# #{exp 35694}#) + (let ((#{mod 35695}# (syntax->datum (cons '#(syntax-object private @@ -10454,12 +12210,15 @@ #(ribcage #(mod exp) #((top) (top)) - #("i3635" "i3636")) - #(ribcage (remodulate) ((top)) ("i3602")) + #("i27574" "i27575")) + #(ribcage + (remodulate) + ((top)) + ("i27541")) #(ribcage #(e r w) #((top) (top) (top)) - #("i3599" "i3600" "i3601")) + #("i27538" "i27539" "i27540")) #(ribcage (lambda-var-list gen-var @@ -10474,7 +12233,7 @@ expand-local-syntax expand-body expand-macro - expand-application + expand-call expand-expr expand syntax-type @@ -10489,6 +12248,7 @@ valid-bound-ids? bound-id=? free-id=? + resolve-identifier id-var-name same-marks? join-marks @@ -10526,7 +12286,6 @@ id? nonsymbol-id? global-extend - lookup macros-only-env extend-var-env extend-env @@ -10552,6 +12311,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -10563,7 +12323,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -10584,8 +12344,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 @@ -10732,271 +12493,330 @@ (top) (top) (top) + (top) + (top) (top)) - ("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 10373}#)))) + #{mod 35693}#)))) (values - (#{remodulate 10350}# - #{exp 10374}# - #{mod 10375}#) - #{r 10348}# - #{w 10349}# - (#{source-annotation 4295}# #{exp 10374}#) - #{mod 10375}#))) - #{tmp 10352}#) + (#{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 10347}#)))))) - (#{global-extend 4300}# + #{e 35667}#)))))) + (#{global-extend 28236}# 'core 'if - (lambda (#{e 10559}# - #{r 10560}# - #{w 10561}# - #{s 10562}# - #{mod 10563}#) - (let ((#{tmp 10565}# - ($sc-dispatch #{e 10559}# '(_ any any)))) - (if #{tmp 10565}# + (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 10569}# #{then 10570}#) - (#{build-conditional 4270}# - #{s 10562}# - (#{expand 4334}# - #{test 10569}# - #{r 10560}# - #{w 10561}# - #{mod 10563}#) - (#{expand 4334}# - #{then 10570}# - #{r 10560}# - #{w 10561}# - #{mod 10563}#) + (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 10565}#) - (let ((#{tmp 10795}# - ($sc-dispatch #{e 10559}# '(_ any any any)))) - (if #{tmp 10795}# + #{tmp 36084}#) + (let ((#{tmp 36338}# + ($sc-dispatch #{e 36078}# '(_ any any any)))) + (if #{tmp 36338}# (@apply - (lambda (#{test 10799}# #{then 10800}# #{else 10801}#) - (#{build-conditional 4270}# - #{s 10562}# - (#{expand 4334}# - #{test 10799}# - #{r 10560}# - #{w 10561}# - #{mod 10563}#) - (#{expand 4334}# - #{then 10800}# - #{r 10560}# - #{w 10561}# - #{mod 10563}#) - (#{expand 4334}# - #{else 10801}# - #{r 10560}# - #{w 10561}# - #{mod 10563}#))) - #{tmp 10795}#) + (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 10559}#))))))) - (#{global-extend 4300}# + #{e 36078}#))))))) + (#{global-extend 28236}# 'core 'with-fluids - (lambda (#{e 11200}# - #{r 11201}# - #{w 11202}# - #{s 11203}# - #{mod 11204}#) - (let ((#{tmp 11206}# + (lambda (#{e 36783}# + #{r 36784}# + #{w 36785}# + #{s 36786}# + #{mod 36787}#) + (let ((#{tmp 36789}# ($sc-dispatch - #{e 11200}# + #{e 36783}# '(_ #(each (any any)) any . each-any)))) - (if #{tmp 11206}# + (if #{tmp 36789}# (@apply - (lambda (#{fluid 11210}# - #{val 11211}# - #{b 11212}# - #{b* 11213}#) - (#{build-dynlet 4271}# - #{s 11203}# - (map (lambda (#{x 11294}#) - (#{expand 4334}# - #{x 11294}# - #{r 11201}# - #{w 11202}# - #{mod 11204}#)) - #{fluid 11210}#) - (map (lambda (#{x 11364}#) - (#{expand 4334}# - #{x 11364}# - #{r 11201}# - #{w 11202}# - #{mod 11204}#)) - #{val 11211}#) - (#{expand-body 4338}# - (cons #{b 11212}# #{b* 11213}#) - (#{wrap 4327}# - (begin - (if (if (pair? #{e 11200}#) #{s 11203}# #f) - (set-source-properties! #{e 11200}# #{s 11203}#)) - #{e 11200}#) - #{w 11202}# - #{mod 11204}#) - #{r 11201}# - #{w 11202}# - #{mod 11204}#))) - #{tmp 11206}#) + (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 11200}#))))) + #{e 36783}#))))) (module-define! (current-module) 'begin @@ -11014,5739 +12834,2177 @@ '())) (module-define! (current-module) + 'define-syntax-parameter + (make-syntax-transformer + 'define-syntax-parameter + 'define-syntax-parameter + '())) + (module-define! + (current-module) 'eval-when (make-syntax-transformer 'eval-when 'eval-when '())) - (#{global-extend 4300}# + (#{global-extend 28236}# 'core 'syntax-case (letrec* - ((#{convert-pattern 11722}# - (lambda (#{pattern 13319}# #{keys 13320}#) + ((#{convert-pattern 37426}# + (lambda (#{pattern 39048}# #{keys 39049}#) (letrec* - ((#{cvt* 13321}# - (lambda (#{p* 13945}# #{n 13946}# #{ids 13947}#) - (if (not (pair? #{p* 13945}#)) - (#{cvt 13323}# - #{p* 13945}# - #{n 13946}# - #{ids 13947}#) + ((#{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* 13321}# - (cdr #{p* 13945}#) - #{n 13946}# - #{ids 13947}#)) - (lambda (#{y 13950}# #{ids 13951}#) + (#{cvt* 39050}# + (cdr #{p* 39849}#) + #{n 39850}# + #{ids 39851}#)) + (lambda (#{y 39854}# #{ids 39855}#) (call-with-values (lambda () - (#{cvt 13323}# - (car #{p* 13945}#) - #{n 13946}# - #{ids 13951}#)) - (lambda (#{x 13954}# #{ids 13955}#) + (#{cvt 39052}# + (car #{p* 39849}#) + #{n 39850}# + #{ids 39855}#)) + (lambda (#{x 39858}# #{ids 39859}#) (values - (cons #{x 13954}# #{y 13950}#) - #{ids 13955}#)))))))) - (#{v-reverse 13322}# - (lambda (#{x 13956}#) + (cons #{x 39858}# #{y 39854}#) + #{ids 39859}#)))))))) + (#{v-reverse 39051}# + (lambda (#{x 39860}#) (letrec* - ((#{loop 13957}# - (lambda (#{r 14037}# #{x 14038}#) - (if (not (pair? #{x 14038}#)) - (values #{r 14037}# #{x 14038}#) - (#{loop 13957}# - (cons (car #{x 14038}#) #{r 14037}#) - (cdr #{x 14038}#)))))) - (#{loop 13957}# '() #{x 13956}#)))) - (#{cvt 13323}# - (lambda (#{p 13326}# #{n 13327}# #{ids 13328}#) - (if (if (symbol? #{p 13326}#) + ((#{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 13326}#) - (if (= (vector-length #{p 13326}#) 4) - (eq? (vector-ref #{p 13326}# 0) + (if (if (vector? #{p 39055}#) + (if (= (vector-length #{p 39055}#) 4) + (eq? (vector-ref #{p 39055}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{p 13326}# 1)) + (symbol? (vector-ref #{p 39055}# 1)) #f)) - (if (#{bound-id-member? 4326}# - #{p 13326}# - #{keys 13320}#) + (if (#{bound-id-member? 28263}# + #{p 39055}# + #{keys 39049}#) (values - (vector 'free-id #{p 13326}#) - #{ids 13328}#) - (if (if (eq? (if (if (vector? #{p 13326}#) - (if (= (vector-length #{p 13326}#) - 4) - (eq? (vector-ref #{p 13326}# 0) - 'syntax-object) - #f) - #f) - (vector-ref #{p 13326}# 1) - #{p 13326}#) - (if (if (= (vector-length - '#(syntax-object - _ - ((top) - #(ribcage () () ()) - #(ribcage - #(p n ids) - #((top) (top) (top)) - #("i3736" - "i3737" - "i3738")) - #(ribcage - (cvt v-reverse cvt*) - ((top) (top) (top)) - ("i3709" - "i3707" - "i3705")) - #(ribcage - #(pattern keys) - #((top) (top)) - #("i3703" "i3704")) - #(ribcage - (gen-syntax-case - gen-clause - build-dispatch-call - convert-pattern) - ((top) - (top) - (top) - (top)) - ("i3699" - "i3697" - "i3695" - "i3693")) - #(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=? - 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)) - ("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 - #(p n ids) - #((top) (top) (top)) - #("i3736" "i3737" "i3738")) - #(ribcage - (cvt v-reverse cvt*) - ((top) (top) (top)) - ("i3709" "i3707" "i3705")) - #(ribcage - #(pattern keys) - #((top) (top)) - #("i3703" "i3704")) - #(ribcage - (gen-syntax-case - gen-clause - build-dispatch-call - convert-pattern) - ((top) (top) (top) (top)) - ("i3699" "i3697" "i3695" "i3693")) - #(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=? - 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)) - ("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 4321}# #{p 13326}# '(())) - (#{id-var-name 4321}# - '#(syntax-object - _ - ((top) - #(ribcage () () ()) - #(ribcage - #(p n ids) - #((top) (top) (top)) - #("i3736" "i3737" "i3738")) - #(ribcage - (cvt v-reverse cvt*) - ((top) (top) (top)) - ("i3709" "i3707" "i3705")) - #(ribcage - #(pattern keys) - #((top) (top)) - #("i3703" "i3704")) - #(ribcage - (gen-syntax-case - gen-clause - build-dispatch-call - convert-pattern) - ((top) (top) (top) (top)) - ("i3699" "i3697" "i3695" "i3693")) - #(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=? - 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)) - ("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) - (values '_ #{ids 13328}#) + (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 'any - (cons (cons #{p 13326}# #{n 13327}#) - #{ids 13328}#)))) - (let ((#{tmp 13648}# - ($sc-dispatch #{p 13326}# '(any any)))) - (if (if #{tmp 13648}# + (cons (cons #{p 39055}# #{n 39056}#) + #{ids 39057}#)))) + (let ((#{tmp 39189}# + ($sc-dispatch #{p 39055}# '(any any)))) + (if (if #{tmp 39189}# (@apply - (lambda (#{x 13652}# #{dots 13653}#) - (if (if (if (vector? #{dots 13653}#) + (lambda (#{x 39193}# #{dots 39194}#) + (if (if (if (vector? #{dots 39194}#) (if (= (vector-length - #{dots 13653}#) + #{dots 39194}#) 4) (eq? (vector-ref - #{dots 13653}# + #{dots 39194}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{dots 13653}# 1)) + (symbol? (vector-ref #{dots 39194}# 1)) #f) - (if (eq? (if (if (vector? #{dots 13653}#) - (if (= (vector-length - #{dots 13653}#) - 4) - (eq? (vector-ref - #{dots 13653}# - 0) - 'syntax-object) - #f) - #f) - (vector-ref #{dots 13653}# 1) - #{dots 13653}#) - (if (if (= (vector-length - '#(syntax-object - ... - ((top) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i2219")) - #(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=? - 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)) - ("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)) - #("i2219")) - #(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=? - 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)) - ("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 4321}# - #{dots 13653}# - '(())) - (#{id-var-name 4321}# - '#(syntax-object - ... - ((top) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i2219")) - #(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=? - 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)) - ("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) + (#{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) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (top) + (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 13648}#) + #{tmp 39189}#) #f) (@apply - (lambda (#{x 13753}# #{dots 13754}#) + (lambda (#{x 39233}# #{dots 39234}#) (call-with-values (lambda () - (#{cvt 13323}# - #{x 13753}# - (#{1+}# #{n 13327}#) - #{ids 13328}#)) - (lambda (#{p 13755}# #{ids 13756}#) + (#{cvt 39052}# + #{x 39233}# + (#{1+}# #{n 39056}#) + #{ids 39057}#)) + (lambda (#{p 39235}# #{ids 39236}#) (values - (if (eq? #{p 13755}# 'any) + (if (eq? #{p 39235}# 'any) 'each-any - (vector 'each #{p 13755}#)) - #{ids 13756}#)))) - #{tmp 13648}#) - (let ((#{tmp 13757}# - ($sc-dispatch #{p 13326}# '(any any . any)))) - (if (if #{tmp 13757}# + (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 13761}# - #{dots 13762}# - #{ys 13763}#) - (if (if (if (vector? #{dots 13762}#) + (lambda (#{x 39241}# + #{dots 39242}# + #{ys 39243}#) + (if (if (if (vector? #{dots 39242}#) (if (= (vector-length - #{dots 13762}#) + #{dots 39242}#) 4) (eq? (vector-ref - #{dots 13762}# + #{dots 39242}# 0) 'syntax-object) #f) #f) (symbol? - (vector-ref #{dots 13762}# 1)) + (vector-ref #{dots 39242}# 1)) #f) - (if (eq? (if (if (vector? - #{dots 13762}#) - (if (= (vector-length - #{dots 13762}#) - 4) - (eq? (vector-ref - #{dots 13762}# - 0) - 'syntax-object) - #f) - #f) - (vector-ref - #{dots 13762}# - 1) - #{dots 13762}#) - (if (if (= (vector-length - '#(syntax-object - ... - ((top) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i2219")) - #(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=? - 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)) - ("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)) - #("i2219")) - #(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=? - 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)) - ("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 4321}# - #{dots 13762}# - '(())) - (#{id-var-name 4321}# - '#(syntax-object - ... - ((top) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i2219")) - #(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=? - 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)) - ("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) + (#{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 13757}#) + #{tmp 39237}#) #f) (@apply - (lambda (#{x 13863}# - #{dots 13864}# - #{ys 13865}#) + (lambda (#{x 39282}# + #{dots 39283}# + #{ys 39284}#) (call-with-values (lambda () - (#{cvt* 13321}# - #{ys 13865}# - #{n 13327}# - #{ids 13328}#)) - (lambda (#{ys 13868}# #{ids 13869}#) + (#{cvt* 39050}# + #{ys 39284}# + #{n 39056}# + #{ids 39057}#)) + (lambda (#{ys 39769}# #{ids 39770}#) (call-with-values (lambda () - (#{cvt 13323}# - #{x 13863}# - (#{1+}# #{n 13327}#) - #{ids 13869}#)) - (lambda (#{x 13870}# #{ids 13871}#) + (#{cvt 39052}# + #{x 39282}# + (#{1+}# #{n 39056}#) + #{ids 39770}#)) + (lambda (#{x 39771}# #{ids 39772}#) (call-with-values (lambda () - (#{v-reverse 13322}# - #{ys 13868}#)) - (lambda (#{ys 13904}# #{e 13905}#) + (#{v-reverse 39051}# + #{ys 39769}#)) + (lambda (#{ys 39808}# #{e 39809}#) (values (vector 'each+ - #{x 13870}# - #{ys 13904}# - #{e 13905}#) - #{ids 13871}#)))))))) - #{tmp 13757}#) - (let ((#{tmp 13906}# - ($sc-dispatch #{p 13326}# '(any . any)))) - (if #{tmp 13906}# + #{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 13910}# #{y 13911}#) + (lambda (#{x 39814}# #{y 39815}#) (call-with-values (lambda () - (#{cvt 13323}# - #{y 13911}# - #{n 13327}# - #{ids 13328}#)) - (lambda (#{y 13912}# #{ids 13913}#) + (#{cvt 39052}# + #{y 39815}# + #{n 39056}# + #{ids 39057}#)) + (lambda (#{y 39816}# #{ids 39817}#) (call-with-values (lambda () - (#{cvt 13323}# - #{x 13910}# - #{n 13327}# - #{ids 13913}#)) - (lambda (#{x 13914}# #{ids 13915}#) + (#{cvt 39052}# + #{x 39814}# + #{n 39056}# + #{ids 39817}#)) + (lambda (#{x 39818}# #{ids 39819}#) (values - (cons #{x 13914}# #{y 13912}#) - #{ids 13915}#)))))) - #{tmp 13906}#) - (let ((#{tmp 13916}# - ($sc-dispatch #{p 13326}# '()))) - (if #{tmp 13916}# + (cons #{x 39818}# #{y 39816}#) + #{ids 39819}#)))))) + #{tmp 39810}#) + (let ((#{tmp 39820}# + ($sc-dispatch #{p 39055}# '()))) + (if #{tmp 39820}# (@apply - (lambda () (values '() #{ids 13328}#)) - #{tmp 13916}#) - (let ((#{tmp 13920}# + (lambda () (values '() #{ids 39057}#)) + #{tmp 39820}#) + (let ((#{tmp 39824}# ($sc-dispatch - #{p 13326}# + #{p 39055}# '#(vector each-any)))) - (if #{tmp 13920}# + (if #{tmp 39824}# (@apply - (lambda (#{x 13924}#) + (lambda (#{x 39828}#) (call-with-values (lambda () - (#{cvt 13323}# - #{x 13924}# - #{n 13327}# - #{ids 13328}#)) - (lambda (#{p 13925}# - #{ids 13926}#) + (#{cvt 39052}# + #{x 39828}# + #{n 39056}# + #{ids 39057}#)) + (lambda (#{p 39829}# + #{ids 39830}#) (values (vector 'vector - #{p 13925}#) - #{ids 13926}#)))) - #{tmp 13920}#) + #{p 39829}#) + #{ids 39830}#)))) + #{tmp 39824}#) (values (vector 'atom - (#{strip 4347}# - #{p 13326}# + (#{strip 28284}# + #{p 39055}# '(()))) - #{ids 13328}#))))))))))))))) - (#{cvt 13323}# #{pattern 13319}# 0 '())))) - (#{build-dispatch-call 11723}# - (lambda (#{pvars 14039}# - #{exp 14040}# - #{y 14041}# - #{r 14042}# - #{mod 14043}#) - (let ((#{ids 14044}# (map car #{pvars 14039}#))) + #{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 14039}#) - (let ((#{labels 14046}# - (#{gen-labels 4305}# #{ids 14044}#)) - (#{new-vars 14047}# - (map #{gen-var 4348}# #{ids 14044}#))) - (#{build-application 4269}# + (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 - (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 4278}# + 'apply + (list (#{build-simple-lambda 28214}# #f - (map syntax->datum #{ids 14044}#) + (map syntax->datum #{ids 39969}#) #f - #{new-vars 14047}# + #{new-vars 39972}# '() - (#{expand 4334}# - #{exp 14040}# - (#{extend-env 4296}# - #{labels 14046}# - (map (lambda (#{var 14372}# #{level 14373}#) + (#{expand 28271}# + #{exp 39965}# + (#{extend-env 28233}# + #{labels 39971}# + (map (lambda (#{var 40304}# #{level 40305}#) (cons 'syntax - (cons #{var 14372}# - #{level 14373}#))) - #{new-vars 14047}# - (map cdr #{pvars 14039}#)) - #{r 14042}#) - (#{make-binding-wrap 4316}# - #{ids 14044}# - #{labels 14046}# + (cons #{var 40304}# + #{level 40305}#))) + #{new-vars 39972}# + (map cdr #{pvars 39964}#)) + #{r 39967}#) + (#{make-binding-wrap 28252}# + #{ids 39969}# + #{labels 39971}# '(())) - #{mod 14043}#)) - #{y 14041}#))))))) - (#{gen-clause 11724}# - (lambda (#{x 12691}# - #{keys 12692}# - #{clauses 12693}# - #{r 12694}# - #{pat 12695}# - #{fender 12696}# - #{exp 12697}# - #{mod 12698}#) + #{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 11722}# - #{pat 12695}# - #{keys 12692}#)) - (lambda (#{p 12853}# #{pvars 12854}#) - (if (not (#{distinct-bound-ids? 4325}# - (map car #{pvars 12854}#))) + (#{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 12695}#) + #{pat 38636}#) (if (not (and-map - (lambda (#{x 12970}#) - (not (let ((#{x 12974}# (car #{x 12970}#))) - (if (if (if (vector? #{x 12974}#) + (lambda (#{x 38887}#) + (not (let ((#{x 38891}# (car #{x 38887}#))) + (if (if (if (vector? #{x 38891}#) (if (= (vector-length - #{x 12974}#) + #{x 38891}#) 4) (eq? (vector-ref - #{x 12974}# + #{x 38891}# 0) 'syntax-object) #f) #f) (symbol? - (vector-ref #{x 12974}# 1)) + (vector-ref #{x 38891}# 1)) #f) - (if (eq? (if (if (vector? #{x 12974}#) - (if (= (vector-length - #{x 12974}#) - 4) - (eq? (vector-ref - #{x 12974}# - 0) - 'syntax-object) - #f) - #f) - (vector-ref #{x 12974}# 1) - #{x 12974}#) - (if (if (= (vector-length - '#(syntax-object - ... - ((top) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i2219")) - #(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=? - 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)) - ("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)) - #("i2219")) - #(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=? - 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)) - ("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 4321}# - #{x 12974}# - '(())) - (#{id-var-name 4321}# - '#(syntax-object - ... - ((top) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i2219")) - #(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=? - 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)) - ("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) + (#{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 12854}#)) + #{pvars 38778}#)) (syntax-violation 'syntax-case "misplaced ellipsis" - #{pat 12695}#) - (let ((#{y 13050}# + #{pat 38636}#) + (let ((#{y 38916}# (gensym (string-append (symbol->string 'tmp) " ")))) - (#{build-application 4269}# - #f - (let ((#{req 13193}# (list 'tmp)) - (#{vars 13195}# (list #{y 13050}#)) - (#{exp 13197}# - (let ((#{y 13214}# - (make-struct/no-tail - (vector-ref %expanded-vtables 3) - #f - 'tmp - #{y 13050}#))) - (let ((#{test-exp 13218}# - (let ((#{tmp 13227}# - ($sc-dispatch - #{fender 12696}# - '#(atom #t)))) - (if #{tmp 13227}# - (@apply - (lambda () #{y 13214}#) - #{tmp 13227}#) - (let ((#{then-exp 13245}# - (#{build-dispatch-call 11723}# - #{pvars 12854}# - #{fender 12696}# - #{y 13214}# - #{r 12694}# - #{mod 12698}#)) - (#{else-exp 13246}# + (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 - 1) + 10) #f - #f))) - (make-struct/no-tail - (vector-ref - %expanded-vtables - 10) - #f - #{y 13214}# - #{then-exp 13245}# - #{else-exp 13246}#))))) - (#{then-exp 13219}# - (#{build-dispatch-call 11723}# - #{pvars 12854}# - #{exp 12697}# - #{y 13214}# - #{r 12694}# - #{mod 12698}#)) - (#{else-exp 13220}# - (#{gen-syntax-case 11725}# - #{x 12691}# - #{keys 12692}# - #{clauses 12693}# - #{r 12694}# - #{mod 12698}#))) - (make-struct/no-tail - (vector-ref %expanded-vtables 10) - #f - #{test-exp 13218}# - #{then-exp 13219}# - #{else-exp 13220}#))))) - (let ((#{body 13202}# - (make-struct/no-tail - (vector-ref %expanded-vtables 14) - #f - #{req 13193}# - #f - #f - #f - '() - #{vars 13195}# - #{exp 13197}# - #f))) - (make-struct/no-tail - (vector-ref %expanded-vtables 13) - #f - '() - #{body 13202}#))) - (list (if (eq? #{p 12853}# 'any) - (let ((#{fun-exp 13268}# - (if (equal? - (module-name (current-module)) - '(guile)) - (make-struct/no-tail - (vector-ref %expanded-vtables 7) - #f - 'list) + #{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 5) + (vector-ref %expanded-vtables 10) #f - '(guile) - 'list - #f))) - (#{arg-exps 13269}# (list #{x 12691}#))) - (make-struct/no-tail - (vector-ref %expanded-vtables 11) - #f - #{fun-exp 13268}# - #{arg-exps 13269}#)) - (let ((#{fun-exp 13292}# - (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 13293}# - (list #{x 12691}# - (make-struct/no-tail - (vector-ref - %expanded-vtables - 1) - #f - #{p 12853}#)))) + #{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 11) + (vector-ref %expanded-vtables 14) #f - #{fun-exp 13292}# - #{arg-exps 13293}#)))))))))))) - (#{gen-syntax-case 11725}# - (lambda (#{x 12124}# - #{keys 12125}# - #{clauses 12126}# - #{r 12127}# - #{mod 12128}#) - (if (null? #{clauses 12126}#) - (let ((#{fun-exp 12133}# - (if (equal? (module-name (current-module)) '(guile)) - (make-struct/no-tail - (vector-ref %expanded-vtables 7) - #f - 'syntax-violation) + '() + #{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 5) + (vector-ref %expanded-vtables 11) #f - '(guile) - 'syntax-violation - #f))) - (#{arg-exps 12134}# + #{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 @@ -16755,86 +15013,60 @@ (vector-ref %expanded-vtables 1) #f "source expression failed to match any pattern") - #{x 12124}#))) + #{x 38133}#))) (make-struct/no-tail - (vector-ref %expanded-vtables 11) + (vector-ref %expanded-vtables 12) #f - #{fun-exp 12133}# - #{arg-exps 12134}#)) - (let ((#{tmp 12167}# (car #{clauses 12126}#))) - (let ((#{tmp 12168}# - ($sc-dispatch #{tmp 12167}# '(any any)))) - (if #{tmp 12168}# + '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 12170}# #{exp 12171}#) - (if (if (if (symbol? #{pat 12170}#) + (lambda (#{pat 38165}# #{exp 38166}#) + (if (if (if (symbol? #{pat 38165}#) #t - (if (if (vector? #{pat 12170}#) - (if (= (vector-length #{pat 12170}#) + (if (if (vector? #{pat 38165}#) + (if (= (vector-length #{pat 38165}#) 4) - (eq? (vector-ref #{pat 12170}# 0) + (eq? (vector-ref #{pat 38165}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{pat 12170}# 1)) + (symbol? (vector-ref #{pat 38165}# 1)) #f)) (and-map - (lambda (#{x 12198}#) - (not (if (eq? (if (if (vector? - #{pat 12170}#) - (if (= (vector-length - #{pat 12170}#) - 4) - (eq? (vector-ref - #{pat 12170}# - 0) - 'syntax-object) - #f) - #f) - (vector-ref #{pat 12170}# 1) - #{pat 12170}#) - (if (if (vector? #{x 12198}#) - (if (= (vector-length - #{x 12198}#) - 4) - (eq? (vector-ref - #{x 12198}# - 0) - 'syntax-object) - #f) - #f) - (vector-ref #{x 12198}# 1) - #{x 12198}#)) - (eq? (#{id-var-name 4321}# - #{pat 12170}# - '(())) - (#{id-var-name 4321}# - #{x 12198}# - '(()))) - #f))) + (lambda (#{x 38193}#) + (not (#{free-id=? 28259}# + #{pat 38165}# + #{x 38193}#))) (cons '#(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) - #("i3900" "i3901")) + #("i27835" "i27836")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) - #("i3889" - "i3890" - "i3891" - "i3892" - "i3893")) + #("i27825" + "i27826" + "i27827" + "i27828" + "i27829")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) - ("i3699" "i3697" "i3695" "i3693")) + ("i27638" + "i27636" + "i27634" + "i27632")) #(ribcage (lambda-var-list gen-var @@ -16849,7 +15081,7 @@ expand-local-syntax expand-body expand-macro - expand-application + expand-call expand-expr expand syntax-type @@ -16864,6 +15096,7 @@ valid-bound-ids? bound-id=? free-id=? + resolve-identifier id-var-name same-marks? join-marks @@ -16901,7 +15134,6 @@ id? nonsymbol-id? global-extend - lookup macros-only-env extend-var-env extend-env @@ -16927,6 +15159,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -16938,7 +15171,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -16959,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 @@ -17107,4866 +15341,2443 @@ (top) (top) (top) + (top) + (top) (top)) - ("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)) - #{keys 12125}#)) + #{keys 38134}#)) #f) - (if (if (eq? (if (if (= (vector-length - '#(syntax-object - pad - ((top) - #(ribcage - #(pat exp) - #((top) (top)) - #("i3900" "i3901")) - #(ribcage () () ()) - #(ribcage - #(x - keys - clauses - r - mod) - #((top) - (top) - (top) - (top) - (top)) - #("i3889" - "i3890" - "i3891" - "i3892" - "i3893")) - #(ribcage - (gen-syntax-case - gen-clause - build-dispatch-call - convert-pattern) - ((top) - (top) - (top) - (top)) - ("i3699" - "i3697" - "i3695" - "i3693")) - #(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=? - 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)) - ("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)) - #("i3900" "i3901")) - #(ribcage () () ()) - #(ribcage - #(x keys clauses r mod) - #((top) - (top) - (top) - (top) - (top)) - #("i3889" - "i3890" - "i3891" - "i3892" - "i3893")) - #(ribcage - (gen-syntax-case - gen-clause - build-dispatch-call - convert-pattern) - ((top) (top) (top) (top)) - ("i3699" - "i3697" - "i3695" - "i3693")) - #(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=? - 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)) - ("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)) - #("i3900" "i3901")) - #(ribcage () () ()) - #(ribcage - #(x - keys - clauses - r - mod) - #((top) - (top) - (top) - (top) - (top)) - #("i3889" - "i3890" - "i3891" - "i3892" - "i3893")) - #(ribcage - (gen-syntax-case - gen-clause - build-dispatch-call - convert-pattern) - ((top) - (top) - (top) - (top)) - ("i3699" - "i3697" - "i3695" - "i3693")) - #(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=? - 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)) - ("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)) - #("i3900" "i3901")) - #(ribcage () () ()) - #(ribcage - #(x keys clauses r mod) - #((top) - (top) - (top) - (top) - (top)) - #("i3889" - "i3890" - "i3891" - "i3892" - "i3893")) - #(ribcage - (gen-syntax-case - gen-clause - build-dispatch-call - convert-pattern) - ((top) (top) (top) (top)) - ("i3699" - "i3697" - "i3695" - "i3693")) - #(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=? - 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)) - ("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 4321}# - '#(syntax-object - pad - ((top) - #(ribcage - #(pat exp) - #((top) (top)) - #("i3900" "i3901")) - #(ribcage () () ()) - #(ribcage - #(x keys clauses r mod) - #((top) (top) (top) (top) (top)) - #("i3889" - "i3890" - "i3891" - "i3892" - "i3893")) - #(ribcage - (gen-syntax-case - gen-clause - build-dispatch-call - convert-pattern) - ((top) (top) (top) (top)) - ("i3699" - "i3697" - "i3695" - "i3693")) - #(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=? - 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)) - ("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 4321}# - '#(syntax-object - _ - ((top) - #(ribcage - #(pat exp) - #((top) (top)) - #("i3900" "i3901")) - #(ribcage () () ()) - #(ribcage - #(x keys clauses r mod) - #((top) (top) (top) (top) (top)) - #("i3889" - "i3890" - "i3891" - "i3892" - "i3893")) - #(ribcage - (gen-syntax-case - gen-clause - build-dispatch-call - convert-pattern) - ((top) (top) (top) (top)) - ("i3699" - "i3697" - "i3695" - "i3693")) - #(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=? - 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)) - ("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 4334}# - #{exp 12171}# - #{r 12127}# + (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 12128}#) - (let ((#{labels 12374}# + #{mod 38137}#) + (let ((#{labels 38275}# (list (symbol->string (gensym "i")))) - (#{var 12375}# - (let ((#{id 12413}# - (if (if (vector? #{pat 12170}#) + (#{var 38276}# + (let ((#{id 38314}# + (if (if (vector? #{pat 38165}#) (if (= (vector-length - #{pat 12170}#) + #{pat 38165}#) 4) (eq? (vector-ref - #{pat 12170}# + #{pat 38165}# 0) 'syntax-object) #f) #f) - (vector-ref #{pat 12170}# 1) - #{pat 12170}#))) + (vector-ref #{pat 38165}# 1) + #{pat 38165}#))) (gensym (string-append - (symbol->string #{id 12413}#) + (symbol->string #{id 38314}#) " "))))) - (#{build-application 4269}# + (#{build-call 28205}# #f - (#{build-simple-lambda 4278}# + (#{build-simple-lambda 28214}# #f - (list (syntax->datum #{pat 12170}#)) + (list (syntax->datum #{pat 38165}#)) #f - (list #{var 12375}#) + (list #{var 38276}#) '() - (#{expand 4334}# - #{exp 12171}# - (#{extend-env 4296}# - #{labels 12374}# + (#{expand 28271}# + #{exp 38166}# + (#{extend-env 28233}# + #{labels 38275}# (list (cons 'syntax - (cons #{var 12375}# 0))) - #{r 12127}#) - (#{make-binding-wrap 4316}# - (list #{pat 12170}#) - #{labels 12374}# + (cons #{var 38276}# 0))) + #{r 38136}#) + (#{make-binding-wrap 28252}# + (list #{pat 38165}#) + #{labels 38275}# '(())) - #{mod 12128}#)) - (list #{x 12124}#)))) - (#{gen-clause 11724}# - #{x 12124}# - #{keys 12125}# - (cdr #{clauses 12126}#) - #{r 12127}# - #{pat 12170}# + #{mod 38137}#)) + (list #{x 38133}#)))) + (#{gen-clause 37428}# + #{x 38133}# + #{keys 38134}# + (cdr #{clauses 38135}#) + #{r 38136}# + #{pat 38165}# #t - #{exp 12171}# - #{mod 12128}#))) - #{tmp 12168}#) - (let ((#{tmp 12683}# - ($sc-dispatch #{tmp 12167}# '(any any any)))) - (if #{tmp 12683}# + #{exp 38166}# + #{mod 38137}#))) + #{tmp 38163}#) + (let ((#{tmp 38624}# + ($sc-dispatch #{tmp 38162}# '(any any any)))) + (if #{tmp 38624}# (@apply - (lambda (#{pat 12685}# - #{fender 12686}# - #{exp 12687}#) - (#{gen-clause 11724}# - #{x 12124}# - #{keys 12125}# - (cdr #{clauses 12126}#) - #{r 12127}# - #{pat 12685}# - #{fender 12686}# - #{exp 12687}# - #{mod 12128}#)) - #{tmp 12683}#) + (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 12126}#))))))))))) - (lambda (#{e 11726}# - #{r 11727}# - #{w 11728}# - #{s 11729}# - #{mod 11730}#) - (let ((#{e 11731}# - (#{wrap 4327}# - (begin - (if (if (pair? #{e 11726}#) #{s 11729}# #f) - (set-source-properties! #{e 11726}# #{s 11729}#)) - #{e 11726}#) - #{w 11728}# - #{mod 11730}#))) - (let ((#{tmp 11733}# - ($sc-dispatch - #{e 11731}# - '(_ any each-any . each-any)))) - (if #{tmp 11733}# - (@apply - (lambda (#{val 11758}# #{key 11759}# #{m 11760}#) - (if (and-map - (lambda (#{x 11761}#) - (if (if (symbol? #{x 11761}#) - #t - (if (if (vector? #{x 11761}#) - (if (= (vector-length #{x 11761}#) 4) - (eq? (vector-ref #{x 11761}# 0) - 'syntax-object) + (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) - #f) - (symbol? (vector-ref #{x 11761}# 1)) - #f)) - (not (if (if (if (vector? #{x 11761}#) - (if (= (vector-length #{x 11761}#) - 4) - (eq? (vector-ref #{x 11761}# 0) - 'syntax-object) + (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) - #f) - (symbol? (vector-ref #{x 11761}# 1)) - #f) - (if (eq? (if (if (vector? #{x 11761}#) - (if (= (vector-length - #{x 11761}#) - 4) - (eq? (vector-ref - #{x 11761}# - 0) - 'syntax-object) - #f) - #f) - (vector-ref #{x 11761}# 1) - #{x 11761}#) - (if (if (= (vector-length - '#(syntax-object - ... - ((top) - #(ribcage - () - () - ()) - #(ribcage - () - () - ()) - #(ribcage - #(x) - #((top)) - #("i2219")) - #(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=? - 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)) - ("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)) - #("i2219")) - #(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=? - 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)) - ("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 4321}# - #{x 11761}# - '(())) - (#{id-var-name 4321}# - '#(syntax-object - ... - ((top) - #(ribcage () () ()) - #(ribcage () () ()) - #(ribcage - #(x) - #((top)) - #("i2219")) - #(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=? - 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)) - ("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)) - #f)) - #{key 11759}#) - (let ((#{x 11887}# - (gensym - (string-append (symbol->string 'tmp) " ")))) - (#{build-application 4269}# - #{s 11729}# - (let ((#{req 12017}# (list 'tmp)) - (#{vars 12019}# (list #{x 11887}#)) - (#{exp 12021}# - (#{gen-syntax-case 11725}# - (make-struct/no-tail - (vector-ref %expanded-vtables 3) - #f - 'tmp - #{x 11887}#) - #{key 11759}# - #{m 11760}# - #{r 11727}# - #{mod 11730}#))) - (let ((#{body 12026}# - (make-struct/no-tail - (vector-ref %expanded-vtables 14) - #f - #{req 12017}# - #f - #f - #f - '() - #{vars 12019}# - #{exp 12021}# - #f))) - (make-struct/no-tail - (vector-ref %expanded-vtables 13) - #f - '() - #{body 12026}#))) - (list (#{expand 4334}# - #{val 11758}# - #{r 11727}# - '(()) - #{mod 11730}#)))) - (syntax-violation - 'syntax-case - "invalid literals list" - #{e 11731}#))) - #{tmp 11733}#) - (syntax-violation - #f - "source expression failed to match any pattern" - #{e 11731}#))))))) + (symbol? (vector-ref #{x 37488}# 1)) + #f) + (#{free-id=? 28259}# + #{x 37488}# + '#(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)) + #f)) + #{key 37486}#) + (let ((#{x 37553}# + (gensym + (string-append (symbol->string 'tmp) " ")))) + (#{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 37553}#) + #{key 37486}# + #{m 37487}# + #{r 37431}# + #{mod 37434}#))) + (let ((#{body 37700}# + (make-struct/no-tail + (vector-ref %expanded-vtables 15) + #f + #{req 37691}# + #f + #f + #f + '() + #{vars 37693}# + #{exp 37695}# + #f))) + (make-struct/no-tail + (vector-ref %expanded-vtables 14) + #f + '() + #{body 37700}#))) + (list (#{expand 28271}# + #{val 37485}# + #{r 37431}# + '(()) + #{mod 37434}#)))) + (syntax-violation + 'syntax-case + "invalid literals list" + #{e 37435}#))) + #{tmp 37437}#) + (syntax-violation + #f + "source expression failed to match any pattern" + #{tmp 37436}#)))))))) (set! macroexpand (lambda* - (#{x 14464}# + (#{x 40406}# #:optional - (#{m 14465}# 'e) - (#{esew 14466}# '(eval))) - (#{expand-top-sequence 4330}# - (list #{x 14464}#) + (#{m 40407}# 'e) + (#{esew 40408}# '(eval))) + (#{expand-top-sequence 28267}# + (list #{x 40406}#) '() '((top)) #f - #{m 14465}# - #{esew 14466}# + #{m 40407}# + #{esew 40408}# (cons 'hygiene (module-name (current-module)))))) (set! identifier? - (lambda (#{x 14469}#) - (if (if (vector? #{x 14469}#) - (if (= (vector-length #{x 14469}#) 4) - (eq? (vector-ref #{x 14469}# 0) 'syntax-object) + (lambda (#{x 40411}#) + (if (if (vector? #{x 40411}#) + (if (= (vector-length #{x 40411}#) 4) + (eq? (vector-ref #{x 40411}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{x 14469}# 1)) + (symbol? (vector-ref #{x 40411}# 1)) #f))) (set! datum->syntax - (lambda (#{id 14494}# #{datum 14495}#) - (let ((#{wrap 14500}# (vector-ref #{id 14494}# 2)) - (#{module 14501}# (vector-ref #{id 14494}# 3))) + (lambda (#{id 40436}# #{datum 40437}#) + (let ((#{wrap 40442}# (vector-ref #{id 40436}# 2)) + (#{module 40443}# (vector-ref #{id 40436}# 3))) (vector 'syntax-object - #{datum 14495}# - #{wrap 14500}# - #{module 14501}#)))) + #{datum 40437}# + #{wrap 40442}# + #{module 40443}#)))) (set! syntax->datum - (lambda (#{x 14508}#) - (#{strip 4347}# #{x 14508}# '(())))) + (lambda (#{x 40450}#) + (#{strip 28284}# #{x 40450}# '(())))) (set! syntax-source - (lambda (#{x 14511}#) - (#{source-annotation 4295}# #{x 14511}#))) + (lambda (#{x 40453}#) + (#{source-annotation 28232}# #{x 40453}#))) (set! generate-temporaries - (lambda (#{ls 14664}#) + (lambda (#{ls 40637}#) (begin - (if (not (list? #{ls 14664}#)) + (if (not (list? #{ls 40637}#)) (syntax-violation 'generate-temporaries "invalid argument" - #{ls 14664}#)) - (let ((#{mod 14672}# + #{ls 40637}#)) + (let ((#{mod 40645}# (cons 'hygiene (module-name (current-module))))) - (map (lambda (#{x 14673}#) - (#{wrap 4327}# (gensym) '((top)) #{mod 14672}#)) - #{ls 14664}#))))) + (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) + (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 14677}# #{y 14678}#) + (lambda (#{x 40697}# #{y 40698}#) (begin - (if (not (if (if (vector? #{x 14677}#) - (if (= (vector-length #{x 14677}#) 4) - (eq? (vector-ref #{x 14677}# 0) 'syntax-object) + (if (not (if (if (vector? #{x 40697}#) + (if (= (vector-length #{x 40697}#) 4) + (eq? (vector-ref #{x 40697}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{x 14677}# 1)) + (symbol? (vector-ref #{x 40697}# 1)) #f)) (syntax-violation 'free-identifier=? "invalid argument" - #{x 14677}#)) - (if (not (if (if (vector? #{y 14678}#) - (if (= (vector-length #{y 14678}#) 4) - (eq? (vector-ref #{y 14678}# 0) 'syntax-object) + #{x 40697}#)) + (if (not (if (if (vector? #{y 40698}#) + (if (= (vector-length #{y 40698}#) 4) + (eq? (vector-ref #{y 40698}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{y 14678}# 1)) + (symbol? (vector-ref #{y 40698}# 1)) #f)) (syntax-violation 'free-identifier=? "invalid argument" - #{y 14678}#)) - (if (eq? (if (if (vector? #{x 14677}#) - (if (= (vector-length #{x 14677}#) 4) - (eq? (vector-ref #{x 14677}# 0) 'syntax-object) - #f) - #f) - (vector-ref #{x 14677}# 1) - #{x 14677}#) - (if (if (vector? #{y 14678}#) - (if (= (vector-length #{y 14678}#) 4) - (eq? (vector-ref #{y 14678}# 0) 'syntax-object) - #f) - #f) - (vector-ref #{y 14678}# 1) - #{y 14678}#)) - (eq? (#{id-var-name 4321}# #{x 14677}# '(())) - (#{id-var-name 4321}# #{y 14678}# '(()))) - #f)))) + #{y 40698}#)) + (#{free-id=? 28259}# #{x 40697}# #{y 40698}#)))) (set! bound-identifier=? - (lambda (#{x 14828}# #{y 14829}#) + (lambda (#{x 40773}# #{y 40774}#) (begin - (if (not (if (if (vector? #{x 14828}#) - (if (= (vector-length #{x 14828}#) 4) - (eq? (vector-ref #{x 14828}# 0) 'syntax-object) + (if (not (if (if (vector? #{x 40773}#) + (if (= (vector-length #{x 40773}#) 4) + (eq? (vector-ref #{x 40773}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{x 14828}# 1)) + (symbol? (vector-ref #{x 40773}# 1)) #f)) (syntax-violation 'bound-identifier=? "invalid argument" - #{x 14828}#)) - (if (not (if (if (vector? #{y 14829}#) - (if (= (vector-length #{y 14829}#) 4) - (eq? (vector-ref #{y 14829}# 0) 'syntax-object) + #{x 40773}#)) + (if (not (if (if (vector? #{y 40774}#) + (if (= (vector-length #{y 40774}#) 4) + (eq? (vector-ref #{y 40774}# 0) 'syntax-object) #f) #f) - (symbol? (vector-ref #{y 14829}# 1)) + (symbol? (vector-ref #{y 40774}# 1)) #f)) (syntax-violation 'bound-identifier=? "invalid argument" - #{y 14829}#)) - (if (if (if (vector? #{x 14828}#) - (if (= (vector-length #{x 14828}#) 4) - (eq? (vector-ref #{x 14828}# 0) 'syntax-object) - #f) - #f) - (if (vector? #{y 14829}#) - (if (= (vector-length #{y 14829}#) 4) - (eq? (vector-ref #{y 14829}# 0) 'syntax-object) - #f) - #f) - #f) - (if (eq? (vector-ref #{x 14828}# 1) - (vector-ref #{y 14829}# 1)) - (#{same-marks? 4320}# - (car (vector-ref #{x 14828}# 2)) - (car (vector-ref #{y 14829}# 2))) - #f) - (eq? #{x 14828}# #{y 14829}#))))) + #{y 40774}#)) + (#{bound-id=? 28260}# #{x 40773}# #{y 40774}#)))) (set! syntax-violation (lambda* - (#{who 14962}# - #{message 14963}# - #{form 14964}# + (#{who 40940}# + #{message 40941}# + #{form 40942}# #:optional - (#{subform 14965}# #f)) + (#{subform 40943}# #f)) (begin - (if (not (if (not #{who 14962}#) - (not #{who 14962}#) - (let ((#{t 14983}# (string? #{who 14962}#))) - (if #{t 14983}# - #{t 14983}# - (symbol? #{who 14962}#))))) + (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 14962}#)) - (if (not (string? #{message 14963}#)) + #{who 40940}#)) + (if (not (string? #{message 40941}#)) (syntax-violation 'syntax-violation "invalid argument" - #{message 14963}#)) + #{message 40941}#)) (throw 'syntax-error - #{who 14962}# - #{message 14963}# - (#{source-annotation 4295}# - (if #{form 14964}# - #{form 14964}# - #{subform 14965}#)) - (#{strip 4347}# #{form 14964}# '(())) - (if #{subform 14965}# - (#{strip 4347}# #{subform 14965}# '(())) + #{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))))) (letrec* - ((#{match-each 15186}# - (lambda (#{e 15773}# - #{p 15774}# - #{w 15775}# - #{mod 15776}#) - (if (pair? #{e 15773}#) - (let ((#{first 15777}# - (#{match 15192}# - (car #{e 15773}#) - #{p 15774}# - #{w 15775}# + ((#{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 15776}#))) - (if #{first 15777}# - (let ((#{rest 15780}# - (#{match-each 15186}# - (cdr #{e 15773}#) - #{p 15774}# - #{w 15775}# - #{mod 15776}#))) - (if #{rest 15780}# - (cons #{first 15777}# #{rest 15780}#) + #{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 15773}#) + (if (null? #{e 42071}#) '() - (if (if (vector? #{e 15773}#) - (if (= (vector-length #{e 15773}#) 4) - (eq? (vector-ref #{e 15773}# 0) 'syntax-object) + (if (if (vector? #{e 42071}#) + (if (= (vector-length #{e 42071}#) 4) + (eq? (vector-ref #{e 42071}# 0) 'syntax-object) #f) #f) - (#{match-each 15186}# - (vector-ref #{e 15773}# 1) - #{p 15774}# - (#{join-wraps 4318}# - #{w 15775}# - (vector-ref #{e 15773}# 2)) - (vector-ref #{e 15773}# 3)) + (#{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 15188}# - (lambda (#{e 15808}# #{w 15809}# #{mod 15810}#) - (if (pair? #{e 15808}#) - (let ((#{l 15811}# - (#{match-each-any 15188}# - (cdr #{e 15808}#) - #{w 15809}# - #{mod 15810}#))) - (if #{l 15811}# - (cons (#{wrap 4327}# - (car #{e 15808}#) - #{w 15809}# - #{mod 15810}#) - #{l 15811}#) + (#{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) + (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 15808}#) + (if (null? #{e 42138}#) '() - (if (if (vector? #{e 15808}#) - (if (= (vector-length #{e 15808}#) 4) - (eq? (vector-ref #{e 15808}# 0) 'syntax-object) + (if (if (vector? #{e 42138}#) + (if (= (vector-length #{e 42138}#) 4) + (eq? (vector-ref #{e 42138}# 0) 'syntax-object) #f) #f) - (#{match-each-any 15188}# - (vector-ref #{e 15808}# 1) - (#{join-wraps 4318}# - #{w 15809}# - (vector-ref #{e 15808}# 2)) - #{mod 15810}#) + (#{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 15189}# - (lambda (#{p 15835}# #{r 15836}#) - (if (null? #{p 15835}#) - #{r 15836}# - (if (eq? #{p 15835}# '_) - #{r 15836}# - (if (eq? #{p 15835}# 'any) - (cons '() #{r 15836}#) - (if (pair? #{p 15835}#) - (#{match-empty 15189}# - (car #{p 15835}#) - (#{match-empty 15189}# - (cdr #{p 15835}#) - #{r 15836}#)) - (if (eq? #{p 15835}# 'each-any) - (cons '() #{r 15836}#) - (let ((#{atom-key 15837}# (vector-ref #{p 15835}# 0))) - (if (eqv? #{atom-key 15837}# 'each) - (#{match-empty 15189}# - (vector-ref #{p 15835}# 1) - #{r 15836}#) - (if (eqv? #{atom-key 15837}# 'each+) - (#{match-empty 15189}# - (vector-ref #{p 15835}# 1) - (#{match-empty 15189}# - (reverse (vector-ref #{p 15835}# 2)) - (#{match-empty 15189}# - (vector-ref #{p 15835}# 3) - #{r 15836}#))) - (if (if (eqv? #{atom-key 15837}# 'free-id) + (#{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 - (eqv? #{atom-key 15837}# 'atom)) - #{r 15836}# - (if (eqv? #{atom-key 15837}# 'vector) - (#{match-empty 15189}# - (vector-ref #{p 15835}# 1) - #{r 15836}#))))))))))))) - (#{combine 15190}# - (lambda (#{r* 15856}# #{r 15857}#) - (if (null? (car #{r* 15856}#)) - #{r 15857}# - (cons (map car #{r* 15856}#) - (#{combine 15190}# - (map cdr #{r* 15856}#) - #{r 15857}#))))) - (#{match* 15191}# - (lambda (#{e 15221}# - #{p 15222}# - #{w 15223}# - #{r 15224}# - #{mod 15225}#) - (if (null? #{p 15222}#) - (if (null? #{e 15221}#) #{r 15224}# #f) - (if (pair? #{p 15222}#) - (if (pair? #{e 15221}#) - (#{match 15192}# - (car #{e 15221}#) - (car #{p 15222}#) - #{w 15223}# - (#{match 15192}# - (cdr #{e 15221}#) - (cdr #{p 15222}#) - #{w 15223}# - #{r 15224}# - #{mod 15225}#) - #{mod 15225}#) + (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 15222}# 'each-any) - (let ((#{l 15230}# - (#{match-each-any 15188}# - #{e 15221}# - #{w 15223}# - #{mod 15225}#))) - (if #{l 15230}# - (cons #{l 15230}# #{r 15224}#) + (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 15235}# (vector-ref #{p 15222}# 0))) - (if (eqv? #{atom-key 15235}# 'each) - (if (null? #{e 15221}#) - (#{match-empty 15189}# - (vector-ref #{p 15222}# 1) - #{r 15224}#) - (let ((#{l 15242}# - (#{match-each 15186}# - #{e 15221}# - (vector-ref #{p 15222}# 1) - #{w 15223}# - #{mod 15225}#))) - (if #{l 15242}# + (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 15245}# - (lambda (#{l 15296}#) - (if (null? (car #{l 15296}#)) - #{r 15224}# - (cons (map car #{l 15296}#) - (#{collect 15245}# - (map cdr #{l 15296}#))))))) - (#{collect 15245}# #{l 15242}#)) + ((#{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 15235}# 'each+) + (if (eqv? #{atom-key 41241}# 'each+) (call-with-values (lambda () - (let ((#{x-pat 15305}# (vector-ref #{p 15222}# 1)) - (#{y-pat 15306}# (vector-ref #{p 15222}# 2)) - (#{z-pat 15307}# (vector-ref #{p 15222}# 3))) + (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 15311}# - (lambda (#{e 15313}# #{w 15314}#) - (if (pair? #{e 15313}#) + ((#{f 41323}# + (lambda (#{e 41325}# #{w 41326}#) + (if (pair? #{e 41325}#) (call-with-values (lambda () - (#{f 15311}# - (cdr #{e 15313}#) - #{w 15314}#)) - (lambda (#{xr* 15315}# - #{y-pat 15316}# - #{r 15317}#) - (if #{r 15317}# - (if (null? #{y-pat 15316}#) - (let ((#{xr 15318}# - (#{match 15192}# - (car #{e 15313}#) - #{x-pat 15305}# - #{w 15314}# + (#{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 15225}#))) - (if #{xr 15318}# + #{mod 41231}#))) + (if #{xr 41330}# (values - (cons #{xr 15318}# - #{xr* 15315}#) - #{y-pat 15316}# - #{r 15317}#) + (cons #{xr 41330}# + #{xr* 41327}#) + #{y-pat 41328}# + #{r 41329}#) (values #f #f #f))) (values '() - (cdr #{y-pat 15316}#) - (#{match 15192}# - (car #{e 15313}#) - (car #{y-pat 15316}#) - #{w 15314}# - #{r 15317}# - #{mod 15225}#))) + (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 15313}#) - (if (= (vector-length #{e 15313}#) + (if (if (vector? #{e 41325}#) + (if (= (vector-length #{e 41325}#) 4) - (eq? (vector-ref #{e 15313}# 0) + (eq? (vector-ref #{e 41325}# 0) 'syntax-object) #f) #f) - (#{f 15311}# - (vector-ref #{e 15313}# 1) - (#{join-wraps 4318}# - #{w 15314}# - #{e 15313}#)) + (#{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 15306}# - (#{match 15192}# - #{e 15313}# - #{z-pat 15307}# - #{w 15314}# - #{r 15224}# - #{mod 15225}#))))))) - (#{f 15311}# #{e 15221}# #{w 15223}#)))) - (lambda (#{xr* 15344}# #{y-pat 15345}# #{r 15346}#) - (if #{r 15346}# - (if (null? #{y-pat 15345}#) - (if (null? #{xr* 15344}#) - (#{match-empty 15189}# - (vector-ref #{p 15222}# 1) - #{r 15346}#) - (#{combine 15190}# #{xr* 15344}# #{r 15346}#)) + #{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 15235}# 'free-id) - (if (if (symbol? #{e 15221}#) + (if (eqv? #{atom-key 41241}# 'free-id) + (if (if (symbol? #{e 41227}#) #t - (if (if (vector? #{e 15221}#) - (if (= (vector-length #{e 15221}#) 4) - (eq? (vector-ref #{e 15221}# 0) + (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 15221}# 1)) + (symbol? (vector-ref #{e 41227}# 1)) #f)) - (if (let ((#{i 15677}# - (#{wrap 4327}# - #{e 15221}# - #{w 15223}# - #{mod 15225}#)) - (#{j 15678}# (vector-ref #{p 15222}# 1))) - (if (eq? (if (if (vector? #{i 15677}#) - (if (= (vector-length - #{i 15677}#) - 4) - (eq? (vector-ref - #{i 15677}# - 0) - 'syntax-object) - #f) - #f) - (vector-ref #{i 15677}# 1) - #{i 15677}#) - (if (if (vector? #{j 15678}#) - (if (= (vector-length - #{j 15678}#) - 4) - (eq? (vector-ref - #{j 15678}# - 0) - 'syntax-object) - #f) - #f) - (vector-ref #{j 15678}# 1) - #{j 15678}#)) - (eq? (#{id-var-name 4321}# - #{i 15677}# - '(())) - (#{id-var-name 4321}# - #{j 15678}# - '(()))) - #f)) - #{r 15224}# + (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) #f) - (if (eqv? #{atom-key 15235}# 'atom) + (if (eqv? #{atom-key 41241}# 'atom) (if (equal? - (vector-ref #{p 15222}# 1) - (#{strip 4347}# #{e 15221}# #{w 15223}#)) - #{r 15224}# + (vector-ref #{p 41228}# 1) + (#{strip 28284}# #{e 41227}# #{w 41229}#)) + #{r 41230}# #f) - (if (eqv? #{atom-key 15235}# 'vector) - (if (vector? #{e 15221}#) - (#{match 15192}# - (vector->list #{e 15221}#) - (vector-ref #{p 15222}# 1) - #{w 15223}# - #{r 15224}# - #{mod 15225}#) + (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 15192}# - (lambda (#{e 15738}# - #{p 15739}# - #{w 15740}# - #{r 15741}# - #{mod 15742}#) - (if (not #{r 15741}#) + (#{match 41198}# + (lambda (#{e 41908}# + #{p 41909}# + #{w 41910}# + #{r 41911}# + #{mod 41912}#) + (if (not #{r 41911}#) #f - (if (eq? #{p 15739}# '_) - #{r 15741}# - (if (eq? #{p 15739}# 'any) - (cons (#{wrap 4327}# - #{e 15738}# - #{w 15740}# - #{mod 15742}#) - #{r 15741}#) - (if (if (vector? #{e 15738}#) - (if (= (vector-length #{e 15738}#) 4) - (eq? (vector-ref #{e 15738}# 0) 'syntax-object) + (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) #f) - (#{match* 15191}# - (vector-ref #{e 15738}# 1) - #{p 15739}# - (#{join-wraps 4318}# - #{w 15740}# - (vector-ref #{e 15738}# 2)) - #{r 15741}# - (vector-ref #{e 15738}# 3)) - (#{match* 15191}# - #{e 15738}# - #{p 15739}# - #{w 15740}# - #{r 15741}# - #{mod 15742}#)))))))) + (#{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 15193}# #{p 15194}#) - (if (eq? #{p 15194}# 'any) - (list #{e 15193}#) - (if (eq? #{p 15194}# '_) + (lambda (#{e 41199}# #{p 41200}#) + (if (eq? #{p 41200}# 'any) + (list #{e 41199}#) + (if (eq? #{p 41200}# '_) '() - (if (if (vector? #{e 15193}#) - (if (= (vector-length #{e 15193}#) 4) - (eq? (vector-ref #{e 15193}# 0) 'syntax-object) + (if (if (vector? #{e 41199}#) + (if (= (vector-length #{e 41199}#) 4) + (eq? (vector-ref #{e 41199}# 0) 'syntax-object) #f) #f) - (#{match* 15191}# - (vector-ref #{e 15193}# 1) - #{p 15194}# - (vector-ref #{e 15193}# 2) + (#{match* 41197}# + (vector-ref #{e 41199}# 1) + #{p 41200}# + (vector-ref #{e 41199}# 2) '() - (vector-ref #{e 15193}# 3)) - (#{match* 15191}# - #{e 15193}# - #{p 15194}# + (vector-ref #{e 41199}# 3)) + (#{match* 41197}# + #{e 41199}# + #{p 41200}# '(()) '() #f))))))))) @@ -21975,82 +17786,118 @@ (make-syntax-transformer 'with-syntax 'macro - (lambda (#{x 27949}#) - (let ((#{tmp 27951}# - ($sc-dispatch #{x 27949}# '(_ () any . each-any)))) - (if #{tmp 27951}# + (lambda (#{x 59996}#) + (let ((#{tmp 59998}# + ($sc-dispatch #{x 59996}# '(_ () any . each-any)))) + (if #{tmp 59998}# (@apply - (lambda (#{e1 27955}# #{e2 27956}#) + (lambda (#{e1 60002}# #{e2 60003}#) (cons '#(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i27922" "i27923")) + #("i59969" "i59970")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27919"))) + #(ribcage #(x) #((top)) #("i59966")) + #(ribcage + (with-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + with-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) - (cons '() (cons #{e1 27955}# #{e2 27956}#)))) - #{tmp 27951}#) - (let ((#{tmp 27957}# + (cons '() (cons #{e1 60002}# #{e2 60003}#)))) + #{tmp 59998}#) + (let ((#{tmp 60004}# ($sc-dispatch - #{x 27949}# + #{x 59996}# '(_ ((any any)) any . each-any)))) - (if #{tmp 27957}# + (if #{tmp 60004}# (@apply - (lambda (#{out 27961}# - #{in 27962}# - #{e1 27963}# - #{e2 27964}#) + (lambda (#{out 60008}# + #{in 60009}# + #{e1 60010}# + #{e2 60011}#) (list '#(syntax-object syntax-case ((top) #(ribcage #(out in e1 e2) #((top) (top) (top) (top)) - #("i27928" "i27929" "i27930" "i27931")) + #("i59975" "i59976" "i59977" "i59978")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27919"))) + #(ribcage #(x) #((top)) #("i59966")) + #(ribcage + (with-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + with-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{in 27962}# + #{in 60009}# '() - (list #{out 27961}# + (list #{out 60008}# (cons '#(syntax-object let ((top) #(ribcage #(out in e1 e2) #((top) (top) (top) (top)) - #("i27928" - "i27929" - "i27930" - "i27931")) + #("i59975" + "i59976" + "i59977" + "i59978")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27919"))) + #(ribcage #(x) #((top)) #("i59966")) + #(ribcage + (with-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + with-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) (cons '() - (cons #{e1 27963}# #{e2 27964}#)))))) - #{tmp 27957}#) - (let ((#{tmp 27965}# + (cons #{e1 60010}# #{e2 60011}#)))))) + #{tmp 60004}#) + (let ((#{tmp 60012}# ($sc-dispatch - #{x 27949}# + #{x 59996}# '(_ #(each (any any)) any . each-any)))) - (if #{tmp 27965}# + (if #{tmp 60012}# (@apply - (lambda (#{out 27969}# - #{in 27970}# - #{e1 27971}# - #{e2 27972}#) + (lambda (#{out 60016}# + #{in 60017}# + #{e1 60018}# + #{e2 60019}#) (list '#(syntax-object syntax-case ((top) #(ribcage #(out in e1 e2) #((top) (top) (top) (top)) - #("i27938" "i27939" "i27940" "i27941")) + #("i59985" "i59986" "i59987" "i59988")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27919"))) + #(ribcage #(x) #((top)) #("i59966")) + #(ribcage + (with-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + with-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) (cons '#(syntax-object list @@ -22058,62 +17905,89 @@ #(ribcage #(out in e1 e2) #((top) (top) (top) (top)) - #("i27938" "i27939" "i27940" "i27941")) + #("i59985" "i59986" "i59987" "i59988")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27919"))) + #(ribcage #(x) #((top)) #("i59966")) + #(ribcage + (with-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + with-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{in 27970}#) + #{in 60017}#) '() - (list #{out 27969}# + (list #{out 60016}# (cons '#(syntax-object let ((top) #(ribcage #(out in e1 e2) #((top) (top) (top) (top)) - #("i27938" - "i27939" - "i27940" - "i27941")) + #("i59985" + "i59986" + "i59987" + "i59988")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i27919"))) + #("i59966")) + #(ribcage + (with-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + with-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) (cons '() - (cons #{e1 27971}# - #{e2 27972}#)))))) - #{tmp 27965}#) + (cons #{e1 60018}# + #{e2 60019}#)))))) + #{tmp 60012}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 27949}#)))))))))) + #{x 59996}#)))))))))) (define syntax-rules (make-syntax-transformer 'syntax-rules 'macro - (lambda (#{x 28026}#) - (let ((#{tmp 28028}# + (lambda (#{x 60074}#) + (let ((#{tmp 60076}# ($sc-dispatch - #{x 28026}# + #{x 60074}# '(_ each-any . #(each ((any . any) any)))))) - (if #{tmp 28028}# + (if #{tmp 60076}# (@apply - (lambda (#{k 28032}# - #{keyword 28033}# - #{pattern 28034}# - #{template 28035}#) + (lambda (#{k 60080}# + #{keyword 60081}# + #{pattern 60082}# + #{template 60083}#) (list '#(syntax-object lambda ((top) #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i27989" "i27990" "i27991" "i27992")) + #("i60037" "i60038" "i60039" "i60040")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile)) '(#(syntax-object x @@ -22121,9 +17995,18 @@ #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i27989" "i27990" "i27991" "i27992")) + #("i60037" "i60038" "i60039" "i60040")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile))) (vector '(#(syntax-object @@ -22132,9 +18015,18 @@ #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i27989" "i27990" "i27991" "i27992")) + #("i60037" "i60038" "i60039" "i60040")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile)) . #(syntax-object @@ -22143,9 +18035,18 @@ #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i27989" "i27990" "i27991" "i27992")) + #("i60037" "i60038" "i60039" "i60040")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile))) (cons '#(syntax-object patterns @@ -22153,20 +18054,38 @@ #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i27989" "i27990" "i27991" "i27992")) + #("i60037" "i60038" "i60039" "i60040")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{pattern 28034}#)) + #{pattern 60082}#)) (cons '#(syntax-object syntax-case ((top) #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i27989" "i27990" "i27991" "i27992")) + #("i60037" "i60038" "i60039" "i60040")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile)) (cons '#(syntax-object x @@ -22174,15 +18093,24 @@ #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i27989" "i27990" "i27991" "i27992")) + #("i60037" "i60038" "i60039" "i60040")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile)) - (cons #{k 28032}# - (map (lambda (#{tmp 28000 28036}# - #{tmp 27999 28037}#) + (cons #{k 60080}# + (map (lambda (#{tmp 60048 60084}# + #{tmp 60047 60085}#) (list (cons '#(syntax-object - dummy + _ ((top) #(ribcage #(k @@ -22193,10 +18121,10 @@ (top) (top) (top)) - #("i27989" - "i27990" - "i27991" - "i27992")) + #("i60037" + "i60038" + "i60039" + "i60040")) #(ribcage () () @@ -22204,9 +18132,20 @@ #(ribcage #(x) #((top)) - #("i27986"))) + #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene + guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{tmp 27999 28037}#) + #{tmp 60047 60085}#) (list '#(syntax-object syntax ((top) @@ -22219,10 +18158,10 @@ (top) (top) (top)) - #("i27989" - "i27990" - "i27991" - "i27992")) + #("i60037" + "i60038" + "i60039" + "i60040")) #(ribcage () () @@ -22230,41 +18169,61 @@ #(ribcage #(x) #((top)) - #("i27986"))) + #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene + guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{tmp 28000 28036}#))) - #{template 28035}# - #{pattern 28034}#)))))) - #{tmp 28028}#) - (let ((#{tmp 28038}# + #{tmp 60048 60084}#))) + #{template 60083}# + #{pattern 60082}#)))))) + #{tmp 60076}#) + (let ((#{tmp 60086}# ($sc-dispatch - #{x 28026}# + #{x 60074}# '(_ each-any any . #(each ((any . any) any)))))) - (if (if #{tmp 28038}# + (if (if #{tmp 60086}# (@apply - (lambda (#{k 28042}# - #{docstring 28043}# - #{keyword 28044}# - #{pattern 28045}# - #{template 28046}#) - (string? (syntax->datum #{docstring 28043}#))) - #{tmp 28038}#) + (lambda (#{k 60090}# + #{docstring 60091}# + #{keyword 60092}# + #{pattern 60093}# + #{template 60094}#) + (string? (syntax->datum #{docstring 60091}#))) + #{tmp 60086}#) #f) (@apply - (lambda (#{k 28047}# - #{docstring 28048}# - #{keyword 28049}# - #{pattern 28050}# - #{template 28051}#) + (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)) - #("i28012" "i28013" "i28014" "i28015" "i28016")) + #("i60060" "i60061" "i60062" "i60063" "i60064")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile)) '(#(syntax-object x @@ -22272,11 +18231,20 @@ #(ribcage #(k docstring keyword pattern template) #((top) (top) (top) (top) (top)) - #("i28012" "i28013" "i28014" "i28015" "i28016")) + #("i60060" "i60061" "i60062" "i60063" "i60064")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile))) - #{docstring 28048}# + #{docstring 60096}# (vector '(#(syntax-object macro-type @@ -22284,13 +18252,22 @@ #(ribcage #(k docstring keyword pattern template) #((top) (top) (top) (top) (top)) - #("i28012" - "i28013" - "i28014" - "i28015" - "i28016")) + #("i60060" + "i60061" + "i60062" + "i60063" + "i60064")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile)) . #(syntax-object @@ -22299,13 +18276,22 @@ #(ribcage #(k docstring keyword pattern template) #((top) (top) (top) (top) (top)) - #("i28012" - "i28013" - "i28014" - "i28015" - "i28016")) + #("i60060" + "i60061" + "i60062" + "i60063" + "i60064")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile))) (cons '#(syntax-object patterns @@ -22313,28 +18299,46 @@ #(ribcage #(k docstring keyword pattern template) #((top) (top) (top) (top) (top)) - #("i28012" - "i28013" - "i28014" - "i28015" - "i28016")) + #("i60060" + "i60061" + "i60062" + "i60063" + "i60064")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{pattern 28050}#)) + #{pattern 60098}#)) (cons '#(syntax-object syntax-case ((top) #(ribcage #(k docstring keyword pattern template) #((top) (top) (top) (top) (top)) - #("i28012" - "i28013" - "i28014" - "i28015" - "i28016")) + #("i60060" + "i60061" + "i60062" + "i60063" + "i60064")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile)) (cons '#(syntax-object x @@ -22346,19 +18350,28 @@ pattern template) #((top) (top) (top) (top) (top)) - #("i28012" - "i28013" - "i28014" - "i28015" - "i28016")) + #("i60060" + "i60061" + "i60062" + "i60063" + "i60064")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i27986"))) + #(ribcage #(x) #((top)) #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) (hygiene guile)) - (cons #{k 28047}# - (map (lambda (#{tmp 28025 28052}# - #{tmp 28024 28053}#) + (cons #{k 60095}# + (map (lambda (#{tmp 60073 60100}# + #{tmp 60072 60101}#) (list (cons '#(syntax-object - dummy + _ ((top) #(ribcage #(k @@ -22371,11 +18384,11 @@ (top) (top) (top)) - #("i28012" - "i28013" - "i28014" - "i28015" - "i28016")) + #("i60060" + "i60061" + "i60062" + "i60063" + "i60064")) #(ribcage () () @@ -22383,10 +18396,21 @@ #(ribcage #(x) #((top)) - #("i27986"))) + #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene + guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{tmp 28024 28053}#) + #{tmp 60072 60101}#) (list '#(syntax-object syntax ((top) @@ -22401,11 +18425,11 @@ (top) (top) (top)) - #("i28012" - "i28013" - "i28014" - "i28015" - "i28016")) + #("i60060" + "i60061" + "i60062" + "i60063" + "i60064")) #(ribcage () () @@ -22413,50 +18437,79 @@ #(ribcage #(x) #((top)) - #("i27986"))) + #("i60034")) + #(ribcage + (syntax-rules) + ((top)) + (((hygiene + guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{tmp 28025 28052}#))) - #{template 28051}# - #{pattern 28050}#)))))) - #{tmp 28038}#) + #{tmp 60073 60100}#))) + #{template 60099}# + #{pattern 60098}#)))))) + #{tmp 60086}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 28026}#)))))))) + #{x 60074}#)))))))) (define define-syntax-rule (make-syntax-transformer 'define-syntax-rule 'macro - (lambda (#{x 28090}#) - (let ((#{tmp 28092}# - ($sc-dispatch #{x 28090}# '(_ (any . any) any)))) - (if #{tmp 28092}# + (lambda (#{x 60139}#) + (let ((#{tmp 60141}# + ($sc-dispatch #{x 60139}# '(_ (any . any) any)))) + (if #{tmp 60141}# (@apply - (lambda (#{name 28096}# - #{pattern 28097}# - #{template 28098}#) + (lambda (#{name 60145}# + #{pattern 60146}# + #{template 60147}#) (list '#(syntax-object define-syntax ((top) #(ribcage #(name pattern template) #((top) (top) (top)) - #("i28067" "i28068" "i28069")) + #("i60116" "i60117" "i60118")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i28064"))) + #(ribcage #(x) #((top)) #("i60113")) + #(ribcage + (define-syntax-rule) + ((top)) + (((hygiene guile) + . + #(syntax-object + define-syntax-rule + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{name 28096}# + #{name 60145}# (list '#(syntax-object syntax-rules ((top) #(ribcage #(name pattern template) #((top) (top) (top)) - #("i28067" "i28068" "i28069")) + #("i60116" "i60117" "i60118")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i28064"))) + #(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 @@ -22465,54 +18518,81 @@ #(ribcage #(name pattern template) #((top) (top) (top)) - #("i28067" "i28068" "i28069")) + #("i60116" "i60117" "i60118")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i28064"))) + #(ribcage #(x) #((top)) #("i60113")) + #(ribcage + (define-syntax-rule) + ((top)) + (((hygiene guile) + . + #(syntax-object + define-syntax-rule + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{pattern 28097}#) - #{template 28098}#)))) - #{tmp 28092}#) - (let ((#{tmp 28099}# + #{pattern 60146}#) + #{template 60147}#)))) + #{tmp 60141}#) + (let ((#{tmp 60148}# ($sc-dispatch - #{x 28090}# + #{x 60139}# '(_ (any . any) any any)))) - (if (if #{tmp 28099}# + (if (if #{tmp 60148}# (@apply - (lambda (#{name 28103}# - #{pattern 28104}# - #{docstring 28105}# - #{template 28106}#) - (string? (syntax->datum #{docstring 28105}#))) - #{tmp 28099}#) + (lambda (#{name 60152}# + #{pattern 60153}# + #{docstring 60154}# + #{template 60155}#) + (string? (syntax->datum #{docstring 60154}#))) + #{tmp 60148}#) #f) (@apply - (lambda (#{name 28107}# - #{pattern 28108}# - #{docstring 28109}# - #{template 28110}#) + (lambda (#{name 60156}# + #{pattern 60157}# + #{docstring 60158}# + #{template 60159}#) (list '#(syntax-object define-syntax ((top) #(ribcage #(name pattern docstring template) #((top) (top) (top) (top)) - #("i28082" "i28083" "i28084" "i28085")) + #("i60131" "i60132" "i60133" "i60134")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i28064"))) + #(ribcage #(x) #((top)) #("i60113")) + #(ribcage + (define-syntax-rule) + ((top)) + (((hygiene guile) + . + #(syntax-object + define-syntax-rule + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{name 28107}# + #{name 60156}# (list '#(syntax-object syntax-rules ((top) #(ribcage #(name pattern docstring template) #((top) (top) (top) (top)) - #("i28082" "i28083" "i28084" "i28085")) + #("i60131" "i60132" "i60133" "i60134")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i28064"))) + #(ribcage #(x) #((top)) #("i60113")) + #(ribcage + (define-syntax-rule) + ((top)) + (((hygiene guile) + . + #(syntax-object + define-syntax-rule + ((top)) + (hygiene guile)))))) (hygiene guile)) '() - #{docstring 28109}# + #{docstring 60158}# (list (cons '#(syntax-object _ ((top) @@ -22522,53 +18602,62 @@ docstring template) #((top) (top) (top) (top)) - #("i28082" - "i28083" - "i28084" - "i28085")) + #("i60131" + "i60132" + "i60133" + "i60134")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i28064"))) + #("i60113")) + #(ribcage + (define-syntax-rule) + ((top)) + (((hygiene guile) + . + #(syntax-object + define-syntax-rule + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{pattern 28108}#) - #{template 28110}#)))) - #{tmp 28099}#) + #{pattern 60157}#) + #{template 60159}#)))) + #{tmp 60148}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 28090}#)))))))) + #{x 60139}#)))))))) (define let* (make-syntax-transformer 'let* 'macro - (lambda (#{x 28159}#) - (let ((#{tmp 28161}# + (lambda (#{x 60209}#) + (let ((#{tmp 60211}# ($sc-dispatch - #{x 28159}# + #{x 60209}# '(any #(each (any any)) any . each-any)))) - (if (if #{tmp 28161}# + (if (if #{tmp 60211}# (@apply - (lambda (#{let* 28165}# - #{x 28166}# - #{v 28167}# - #{e1 28168}# - #{e2 28169}#) - (and-map identifier? #{x 28166}#)) - #{tmp 28161}#) + (lambda (#{let* 60215}# + #{x 60216}# + #{v 60217}# + #{e1 60218}# + #{e2 60219}#) + (and-map identifier? #{x 60216}#)) + #{tmp 60211}#) #f) (@apply - (lambda (#{let* 28170}# - #{x 28171}# - #{v 28172}# - #{e1 28173}# - #{e2 28174}#) + (lambda (#{let* 60220}# + #{x 60221}# + #{v 60222}# + #{e1 60223}# + #{e2 60224}#) (letrec* - ((#{f 28175}# - (lambda (#{bindings 28178}#) - (if (null? #{bindings 28178}#) + ((#{f 60225}# + (lambda (#{bindings 60228}#) + (if (null? #{bindings 60228}#) (cons '#(syntax-object let ((top) @@ -22576,27 +18665,36 @@ #(ribcage #(f bindings) #((top) (top)) - #("i28145" "i28146")) + #("i60195" "i60196")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) - #("i28135" - "i28136" - "i28137" - "i28138" - "i28139")) + #("i60185" + "i60186" + "i60187" + "i60188" + "i60189")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i28121"))) + #(ribcage #(x) #((top)) #("i60171")) + #(ribcage + (let*) + ((top)) + (((hygiene guile) + . + #(syntax-object + let* + ((top)) + (hygiene guile)))))) (hygiene guile)) - (cons '() (cons #{e1 28173}# #{e2 28174}#))) - (let ((#{tmp 28179}# - (list (#{f 28175}# (cdr #{bindings 28178}#)) - (car #{bindings 28178}#)))) - (let ((#{tmp 28180}# - ($sc-dispatch #{tmp 28179}# '(any any)))) - (if #{tmp 28180}# + (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 28182}# #{binding 28183}#) + (lambda (#{body 60232}# #{binding 60233}#) (list '#(syntax-object let ((top) @@ -22604,86 +18702,92 @@ #(ribcage #(body binding) #((top) (top)) - #("i28155" "i28156")) + #("i60205" "i60206")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) - #("i28145" "i28146")) + #("i60195" "i60196")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) - #("i28135" - "i28136" - "i28137" - "i28138" - "i28139")) + #("i60185" + "i60186" + "i60187" + "i60188" + "i60189")) #(ribcage () () ()) + #(ribcage #(x) #((top)) #("i60171")) #(ribcage - #(x) - #((top)) - #("i28121"))) + (let*) + ((top)) + (((hygiene guile) + . + #(syntax-object + let* + ((top)) + (hygiene guile)))))) (hygiene guile)) - (list #{binding 28183}#) - #{body 28182}#)) - #{tmp 28180}#) + (list #{binding 60233}#) + #{body 60232}#)) + #{tmp 60230}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 28179}#)))))))) - (#{f 28175}# (map list #{x 28171}# #{v 28172}#)))) - #{tmp 28161}#) + #{tmp 60229}#)))))))) + (#{f 60225}# (map list #{x 60221}# #{v 60222}#)))) + #{tmp 60211}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 28159}#)))))) + #{x 60209}#)))))) (define do (make-syntax-transformer 'do 'macro - (lambda (#{orig-x 28241}#) - (let ((#{tmp 28243}# + (lambda (#{orig-x 60292}#) + (let ((#{tmp 60294}# ($sc-dispatch - #{orig-x 28241}# + #{orig-x 60292}# '(_ #(each (any any . any)) (any . each-any) . each-any)))) - (if #{tmp 28243}# + (if #{tmp 60294}# (@apply - (lambda (#{var 28247}# - #{init 28248}# - #{step 28249}# - #{e0 28250}# - #{e1 28251}# - #{c 28252}#) - (let ((#{tmp 28253}# - (map (lambda (#{v 28256}# #{s 28257}#) - (let ((#{tmp 28259}# - ($sc-dispatch #{s 28257}# '()))) - (if #{tmp 28259}# - (@apply (lambda () #{v 28256}#) #{tmp 28259}#) - (let ((#{tmp 28262}# - ($sc-dispatch #{s 28257}# '(any)))) - (if #{tmp 28262}# + (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 28265}#) #{e 28265}#) - #{tmp 28262}#) + (lambda (#{e 60316}#) #{e 60316}#) + #{tmp 60313}#) (syntax-violation 'do "bad step expression" - #{orig-x 28241}# - #{s 28257}#)))))) - #{var 28247}# - #{step 28249}#))) - (let ((#{tmp 28254}# - ($sc-dispatch #{tmp 28253}# 'each-any))) - (if #{tmp 28254}# + #{orig-x 60292}# + #{s 60308}#)))))) + #{var 60298}# + #{step 60300}#))) + (let ((#{tmp 60305}# + ($sc-dispatch #{tmp 60304}# 'each-any))) + (if #{tmp 60305}# (@apply - (lambda (#{step 28271}#) - (let ((#{tmp 28273}# ($sc-dispatch #{e1 28251}# '()))) - (if #{tmp 28273}# + (lambda (#{step 60322}#) + (let ((#{tmp 60324}# ($sc-dispatch #{e1 60302}# '()))) + (if #{tmp 60324}# (@apply (lambda () (list '#(syntax-object @@ -22693,7 +18797,7 @@ #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init step e0 e1 c) #((top) @@ -22702,17 +18806,26 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene guile) + . + #(syntax-object + do + ((top)) + (hygiene guile)))))) (hygiene guile)) '#(syntax-object doloop @@ -22721,7 +18834,7 @@ #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init step e0 e1 c) #((top) @@ -22730,19 +18843,28 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene guile) + . + #(syntax-object + do + ((top)) + (hygiene guile)))))) (hygiene guile)) - (map list #{var 28247}# #{init 28248}#) + (map list #{var 60298}# #{init 60299}#) (list '#(syntax-object if ((top) @@ -22750,7 +18872,7 @@ #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init step e0 e1 c) #((top) @@ -22759,17 +18881,26 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene guile) + . + #(syntax-object + do + ((top)) + (hygiene guile)))))) (hygiene guile)) (list '#(syntax-object not @@ -22778,7 +18909,7 @@ #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init @@ -22792,19 +18923,29 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene guile) + . + #(syntax-object + do + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{e0 28250}#) + #{e0 60301}#) (cons '#(syntax-object begin ((top) @@ -22812,7 +18953,7 @@ #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init @@ -22826,20 +18967,30 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene guile) + . + #(syntax-object + do + ((top)) + (hygiene + guile)))))) (hygiene guile)) (append - #{c 28252}# + #{c 60303}# (list (cons '#(syntax-object doloop ((top) @@ -22850,7 +19001,7 @@ #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init @@ -22864,12 +19015,12 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () @@ -22877,30 +19028,41 @@ #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene + guile) + . + #(syntax-object + do + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{step 28271}#))))))) - #{tmp 28273}#) - (let ((#{tmp 28277}# + #{step 60322}#))))))) + #{tmp 60324}#) + (let ((#{tmp 60328}# ($sc-dispatch - #{e1 28251}# + #{e1 60302}# '(any . each-any)))) - (if #{tmp 28277}# + (if #{tmp 60328}# (@apply - (lambda (#{e1 28281}# #{e2 28282}#) + (lambda (#{e1 60332}# #{e2 60333}#) (list '#(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i28218" "i28219")) + #("i60269" "i60270")) #(ribcage () () ()) #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init step e0 e1 c) #((top) @@ -22909,17 +19071,26 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene guile) + . + #(syntax-object + do + ((top)) + (hygiene guile)))))) (hygiene guile)) '#(syntax-object doloop @@ -22927,12 +19098,12 @@ #(ribcage #(e1 e2) #((top) (top)) - #("i28218" "i28219")) + #("i60269" "i60270")) #(ribcage () () ()) #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init step e0 e1 c) #((top) @@ -22941,33 +19112,42 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene guile) + . + #(syntax-object + do + ((top)) + (hygiene guile)))))) (hygiene guile)) (map list - #{var 28247}# - #{init 28248}#) + #{var 60298}# + #{init 60299}#) (list '#(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i28218" "i28219")) + #("i60269" "i60270")) #(ribcage () () ()) #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init step e0 e1 c) #((top) @@ -22976,32 +19156,41 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene guile) + . + #(syntax-object + do + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{e0 28250}# + #{e0 60301}# (cons '#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i28218" - "i28219")) + #("i60269" + "i60270")) #(ribcage () () ()) #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init @@ -23015,33 +19204,43 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene guile) + . + #(syntax-object + do + ((top)) + (hygiene + guile)))))) (hygiene guile)) - (cons #{e1 28281}# - #{e2 28282}#)) + (cons #{e1 60332}# + #{e2 60333}#)) (cons '#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i28218" - "i28219")) + #("i60269" + "i60270")) #(ribcage () () ()) #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init @@ -23055,20 +19254,30 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene guile) + . + #(syntax-object + do + ((top)) + (hygiene + guile)))))) (hygiene guile)) (append - #{c 28252}# + #{c 60303}# (list (cons '#(syntax-object doloop ((top) @@ -23077,8 +19286,8 @@ e2) #((top) (top)) - #("i28218" - "i28219")) + #("i60269" + "i60270")) #(ribcage () () @@ -23086,7 +19295,7 @@ #(ribcage #(step) #((top)) - #("i28209")) + #("i60260")) #(ribcage #(var init @@ -23100,12 +19309,12 @@ (top) (top) (top)) - #("i28194" - "i28195" - "i28196" - "i28197" - "i28198" - "i28199")) + #("i60245" + "i60246" + "i60247" + "i60248" + "i60249" + "i60250")) #(ribcage () () @@ -23113,36 +19322,47 @@ #(ribcage #(orig-x) #((top)) - #("i28191"))) + #("i60242")) + #(ribcage + (do) + ((top)) + (((hygiene + guile) + . + #(syntax-object + do + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{step 28271}#))))))) - #{tmp 28277}#) + #{step 60322}#))))))) + #{tmp 60328}#) (syntax-violation #f "source expression failed to match any pattern" - #{e1 28251}#)))))) - #{tmp 28254}#) + #{e1 60302}#)))))) + #{tmp 60305}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 28253}#))))) - #{tmp 28243}#) + #{tmp 60304}#))))) + #{tmp 60294}#) (syntax-violation #f "source expression failed to match any pattern" - #{orig-x 28241}#)))))) + #{orig-x 60292}#)))))) (define quasiquote (make-syntax-transformer 'quasiquote 'macro (letrec* - ((#{quasi 28568}# - (lambda (#{p 28592}# #{lev 28593}#) - (let ((#{tmp 28595}# + ((#{quasi 60620}# + (lambda (#{p 60644}# #{lev 60645}#) + (let ((#{tmp 60647}# ($sc-dispatch - #{p 28592}# + #{p 60644}# '(#(free-id #(syntax-object unquote @@ -23151,7 +19371,7 @@ #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23160,28 +19380,37 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) any)))) - (if #{tmp 28595}# + (if #{tmp 60647}# (@apply - (lambda (#{p 28599}#) - (if (= #{lev 28593}# 0) + (lambda (#{p 60651}#) + (if (= #{lev 60645}# 0) (list '#(syntax-object "value" ((top) - #(ribcage #(p) #((top)) #("i28318")) + #(ribcage #(p) #((top)) #("i60370")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23190,25 +19419,34 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{p 28599}#) - (#{quasicons 28570}# + #{p 60651}#) + (#{quasicons 60622}# '(#(syntax-object "quote" ((top) - #(ribcage #(p) #((top)) #("i28318")) + #(ribcage #(p) #((top)) #("i60370")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23217,23 +19455,32 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("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)) #("i28318")) + #(ribcage #(p) #((top)) #("i60370")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23242,21 +19489,30 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) - (#{quasi 28568}# - (list #{p 28599}#) - (#{1-}# #{lev 28593}#))))) - #{tmp 28595}#) - (let ((#{tmp 28602}# + (#{quasi 60620}# + (list #{p 60651}#) + (#{1-}# #{lev 60645}#))))) + #{tmp 60647}#) + (let ((#{tmp 60654}# ($sc-dispatch - #{p 28592}# + #{p 60644}# '(#(free-id #(syntax-object quasiquote @@ -23265,7 +19521,7 @@ #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23274,28 +19530,37 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) any)))) - (if #{tmp 28602}# + (if #{tmp 60654}# (@apply - (lambda (#{p 28606}#) - (#{quasicons 28570}# + (lambda (#{p 60658}#) + (#{quasicons 60622}# '(#(syntax-object "quote" ((top) - #(ribcage #(p) #((top)) #("i28321")) + #(ribcage #(p) #((top)) #("i60373")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23304,23 +19569,32 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("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)) #("i28321")) + #(ribcage #(p) #((top)) #("i60373")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23329,26 +19603,35 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) - (#{quasi 28568}# - (list #{p 28606}#) - (#{1+}# #{lev 28593}#)))) - #{tmp 28602}#) - (let ((#{tmp 28609}# - ($sc-dispatch #{p 28592}# '(any . any)))) - (if #{tmp 28609}# + (#{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 28613}# #{q 28614}#) - (let ((#{tmp 28616}# + (lambda (#{p 60665}# #{q 60666}#) + (let ((#{tmp 60668}# ($sc-dispatch - #{p 28613}# + #{p 60665}# '(#(free-id #(syntax-object unquote @@ -23356,12 +19639,12 @@ #(ribcage #(p q) #((top) (top)) - #("i28324" "i28325")) + #("i60376" "i60377")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23376,38 +19659,47 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) . each-any)))) - (if #{tmp 28616}# + (if #{tmp 60668}# (@apply - (lambda (#{p 28620}#) - (if (= #{lev 28593}# 0) - (#{quasilist* 28572}# - (map (lambda (#{tmp 28332 28656}#) + (lambda (#{p 60672}#) + (if (= #{lev 60645}# 0) + (#{quasilist* 60624}# + (map (lambda (#{tmp 60384 60711}#) (list '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) - #("i28330")) + #("i60382")) #(ribcage #(p q) #((top) (top)) - #("i28324" "i28325")) + #("i60376" "i60377")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23422,37 +19714,47 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{tmp 28332 28656}#)) - #{p 28620}#) - (#{quasi 28568}# - #{q 28614}# - #{lev 28593}#)) - (#{quasicons 28570}# - (#{quasicons 28570}# + #{tmp 60384 60711}#)) + #{p 60672}#) + (#{quasi 60620}# + #{q 60666}# + #{lev 60645}#)) + (#{quasicons 60622}# + (#{quasicons 60622}# '(#(syntax-object "quote" ((top) #(ribcage #(p) #((top)) - #("i28330")) + #("i60382")) #(ribcage #(p q) #((top) (top)) - #("i28324" "i28325")) + #("i60376" "i60377")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23467,13 +19769,22 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) #(syntax-object unquote @@ -23481,16 +19792,16 @@ #(ribcage #(p) #((top)) - #("i28330")) + #("i60382")) #(ribcage #(p q) #((top) (top)) - #("i28324" "i28325")) + #("i60376" "i60377")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23505,24 +19816,33 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) - (#{quasi 28568}# - #{p 28620}# - (#{1-}# #{lev 28593}#))) - (#{quasi 28568}# - #{q 28614}# - #{lev 28593}#)))) - #{tmp 28616}#) - (let ((#{tmp 28661}# + (#{quasi 60620}# + #{p 60672}# + (#{1-}# #{lev 60645}#))) + (#{quasi 60620}# + #{q 60666}# + #{lev 60645}#)))) + #{tmp 60668}#) + (let ((#{tmp 60716}# ($sc-dispatch - #{p 28613}# + #{p 60665}# '(#(free-id #(syntax-object unquote-splicing @@ -23530,12 +19850,12 @@ #(ribcage #(p q) #((top) (top)) - #("i28324" "i28325")) + #("i60376" "i60377")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23550,40 +19870,49 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) . each-any)))) - (if #{tmp 28661}# + (if #{tmp 60716}# (@apply - (lambda (#{p 28665}#) - (if (= #{lev 28593}# 0) - (#{quasiappend 28571}# - (map (lambda (#{tmp 28337 28668}#) + (lambda (#{p 60720}#) + (if (= #{lev 60645}# 0) + (#{quasiappend 60623}# + (map (lambda (#{tmp 60389 60723}#) (list '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) - #("i28335")) + #("i60387")) #(ribcage #(p q) #((top) (top)) - #("i28324" - "i28325")) + #("i60376" + "i60377")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" - "i28315")) + #("i60366" + "i60367")) #(ribcage (emit quasivector quasilist* @@ -23598,37 +19927,47 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{tmp 28337 28668}#)) - #{p 28665}#) - (#{quasi 28568}# - #{q 28614}# - #{lev 28593}#)) - (#{quasicons 28570}# - (#{quasicons 28570}# + #{tmp 60389 60723}#)) + #{p 60720}#) + (#{quasi 60620}# + #{q 60666}# + #{lev 60645}#)) + (#{quasicons 60622}# + (#{quasicons 60622}# '(#(syntax-object "quote" ((top) #(ribcage #(p) #((top)) - #("i28335")) + #("i60387")) #(ribcage #(p q) #((top) (top)) - #("i28324" "i28325")) + #("i60376" "i60377")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23643,13 +19982,22 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) #(syntax-object unquote-splicing @@ -23657,16 +20005,16 @@ #(ribcage #(p) #((top)) - #("i28335")) + #("i60387")) #(ribcage #(p q) #((top) (top)) - #("i28324" "i28325")) + #("i60376" "i60377")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -23681,57 +20029,66 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) - (#{quasi 28568}# - #{p 28665}# - (#{1-}# #{lev 28593}#))) - (#{quasi 28568}# - #{q 28614}# - #{lev 28593}#)))) - #{tmp 28661}#) - (#{quasicons 28570}# - (#{quasi 28568}# - #{p 28613}# - #{lev 28593}#) - (#{quasi 28568}# - #{q 28614}# - #{lev 28593}#))))))) - #{tmp 28609}#) - (let ((#{tmp 28682}# - ($sc-dispatch #{p 28592}# '#(vector each-any)))) - (if #{tmp 28682}# + (#{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 28686}#) - (let ((#{x 28689}# - (#{vquasi 28569}# - #{x 28686}# - #{lev 28593}#))) - (let ((#{tmp 28691}# + (lambda (#{x 60741}#) + (let ((#{x 60744}# + (#{vquasi 60621}# + #{x 60741}# + #{lev 60645}#))) + (let ((#{tmp 60746}# ($sc-dispatch - #{x 28689}# + #{x 60744}# '(#(atom "quote") each-any)))) - (if #{tmp 28691}# + (if #{tmp 60746}# (@apply - (lambda (#{x 28695}#) + (lambda (#{x 60750}#) (list '#(syntax-object "quote" ((top) #(ribcage #(x) #((top)) - #("i28442")) + #("i60494")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i28439")) + #("i60491")) #(ribcage (emit quasivector quasilist* @@ -23746,36 +20103,45 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - (list->vector #{x 28695}#))) - #{tmp 28691}#) + (list->vector #{x 60750}#))) + #{tmp 60746}#) (letrec* - ((#{f 28697}# - (lambda (#{y 28709}# #{k 28710}#) - (let ((#{tmp 28712}# + ((#{f 60752}# + (lambda (#{y 60764}# #{k 60765}#) + (let ((#{tmp 60767}# ($sc-dispatch - #{y 28709}# + #{y 60764}# '(#(atom "quote") each-any)))) - (if #{tmp 28712}# + (if #{tmp 60767}# (@apply - (lambda (#{y 28715}#) - (#{k 28710}# - (map (lambda (#{tmp 28467 28716}#) + (lambda (#{y 60770}#) + (#{k 60765}# + (map (lambda (#{tmp 60519 60771}#) (list '#(syntax-object "quote" ((top) #(ribcage #(y) #((top)) - #("i28465")) + #("i60517")) #(ribcage () () @@ -23787,13 +20153,13 @@ #((top) (top) (top)) - #("i28447" - "i28448" - "i28449")) + #("i60499" + "i60500" + "i60501")) #(ribcage #(_) #((top)) - #("i28445")) + #("i60497")) #(ribcage () () @@ -23801,7 +20167,7 @@ #(ribcage #(x) #((top)) - #("i28439")) + #("i60491")) #(ribcage (emit quasivector quasilist* @@ -23816,51 +20182,62 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene + guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{tmp 28467 28716}#)) - #{y 28715}#))) - #{tmp 28712}#) - (let ((#{tmp 28717}# + #{tmp 60519 60771}#)) + #{y 60770}#))) + #{tmp 60767}#) + (let ((#{tmp 60772}# ($sc-dispatch - #{y 28709}# + #{y 60764}# '(#(atom "list") . each-any)))) - (if #{tmp 28717}# + (if #{tmp 60772}# (@apply - (lambda (#{y 28720}#) - (#{k 28710}# - #{y 28720}#)) - #{tmp 28717}#) - (let ((#{tmp 28721}# + (lambda (#{y 60775}#) + (#{k 60765}# + #{y 60775}#)) + #{tmp 60772}#) + (let ((#{tmp 60776}# ($sc-dispatch - #{y 28709}# + #{y 60764}# '(#(atom "list*") . #(each+ any (any) ()))))) - (if #{tmp 28721}# + (if #{tmp 60776}# (@apply - (lambda (#{y 28724}# - #{z 28725}#) - (#{f 28697}# - #{z 28725}# - (lambda (#{ls 28726}#) - (#{k 28710}# + (lambda (#{y 60779}# + #{z 60780}#) + (#{f 60752}# + #{z 60780}# + (lambda (#{ls 60781}#) + (#{k 60765}# (append - #{y 28724}# - #{ls 28726}#))))) - #{tmp 28721}#) + #{y 60779}# + #{ls 60781}#))))) + #{tmp 60776}#) (list '#(syntax-object "list->vector" ((top) @@ -23869,14 +20246,14 @@ () ()) #(ribcage - #(#{ g28482}#) - #((m28483 + #(#{ g60534}#) + #((m60535 top)) - #("i28486")) + #("i60538")) #(ribcage #(else) #((top)) - #("i28480")) + #("i60532")) #(ribcage () () @@ -23886,13 +20263,13 @@ #((top) (top) (top)) - #("i28447" - "i28448" - "i28449")) + #("i60499" + "i60500" + "i60501")) #(ribcage #(_) #((top)) - #("i28445")) + #("i60497")) #(ribcage () () @@ -23900,7 +20277,7 @@ #(ribcage #(x) #((top)) - #("i28439")) + #("i60491")) #(ribcage (emit quasivector quasilist* @@ -23915,26 +20292,37 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene + guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{x 28689}#)))))))))) - (#{f 28697}# - #{x 28689}# - (lambda (#{ls 28699}#) - (let ((#{tmp 28701}# + #{x 60744}#)))))))))) + (#{f 60752}# + #{x 60744}# + (lambda (#{ls 60754}#) + (let ((#{tmp 60756}# ($sc-dispatch - #{ls 28699}# + #{ls 60754}# 'each-any))) - (if #{tmp 28701}# + (if #{tmp 60756}# (@apply - (lambda (#{ g28455 28704}#) + (lambda (#{ g60507 60759}#) (cons '#(syntax-object "vector" ((top) @@ -23943,9 +20331,9 @@ () ()) #(ribcage - #(#{ g28455}#) - #((m28456 top)) - #("i28460")) + #(#{ g60507}#) + #((m60508 top)) + #("i60512")) #(ribcage () () @@ -23961,11 +20349,11 @@ #(ribcage #(ls) #((top)) - #("i28454")) + #("i60506")) #(ribcage #(_) #((top)) - #("i28445")) + #("i60497")) #(ribcage () () @@ -23973,7 +20361,7 @@ #(ribcage #(x) #((top)) - #("i28439")) + #("i60491")) #(ribcage (emit quasivector quasilist* @@ -23988,30 +20376,41 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene + guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{ g28455 28704}#)) - #{tmp 28701}#) + #{ g60507 60759}#)) + #{tmp 60756}#) (syntax-violation #f "source expression failed to match any pattern" - #{ls 28699}#)))))))))) - #{tmp 28682}#) + #{ls 60754}#)))))))))) + #{tmp 60737}#) (list '#(syntax-object "quote" ((top) - #(ribcage #(p) #((top)) #("i28345")) + #(ribcage #(p) #((top)) #("i60397")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28314" "i28315")) + #("i60366" "i60367")) #(ribcage (emit quasivector quasilist* @@ -24026,25 +20425,34 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{p 28592}#))))))))))) - (#{vquasi 28569}# - (lambda (#{p 28754}# #{lev 28755}#) - (let ((#{tmp 28757}# - ($sc-dispatch #{p 28754}# '(any . any)))) - (if #{tmp 28757}# + #{p 60644}#))))))))))) + (#{vquasi 60621}# + (lambda (#{p 60809}# #{lev 60810}#) + (let ((#{tmp 60812}# + ($sc-dispatch #{p 60809}# '(any . any)))) + (if #{tmp 60812}# (@apply - (lambda (#{p 28761}# #{q 28762}#) - (let ((#{tmp 28764}# + (lambda (#{p 60816}# #{q 60817}#) + (let ((#{tmp 60819}# ($sc-dispatch - #{p 28761}# + #{p 60816}# '(#(free-id #(syntax-object unquote @@ -24052,12 +20460,12 @@ #(ribcage #(p q) #((top) (top)) - #("i28353" "i28354")) + #("i60405" "i60406")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28349" "i28350")) + #("i60401" "i60402")) #(ribcage (emit quasivector quasilist* @@ -24072,38 +20480,47 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) . each-any)))) - (if #{tmp 28764}# + (if #{tmp 60819}# (@apply - (lambda (#{p 28768}#) - (if (= #{lev 28755}# 0) - (#{quasilist* 28572}# - (map (lambda (#{tmp 28361 28804}#) + (lambda (#{p 60823}#) + (if (= #{lev 60810}# 0) + (#{quasilist* 60624}# + (map (lambda (#{tmp 60413 60862}#) (list '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) - #("i28359")) + #("i60411")) #(ribcage #(p q) #((top) (top)) - #("i28353" "i28354")) + #("i60405" "i60406")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28349" "i28350")) + #("i60401" "i60402")) #(ribcage (emit quasivector quasilist* @@ -24118,32 +20535,41 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{tmp 28361 28804}#)) - #{p 28768}#) - (#{vquasi 28569}# #{q 28762}# #{lev 28755}#)) - (#{quasicons 28570}# - (#{quasicons 28570}# + #{tmp 60413 60862}#)) + #{p 60823}#) + (#{vquasi 60621}# #{q 60817}# #{lev 60810}#)) + (#{quasicons 60622}# + (#{quasicons 60622}# '(#(syntax-object "quote" ((top) - #(ribcage #(p) #((top)) #("i28359")) + #(ribcage #(p) #((top)) #("i60411")) #(ribcage #(p q) #((top) (top)) - #("i28353" "i28354")) + #("i60405" "i60406")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28349" "i28350")) + #("i60401" "i60402")) #(ribcage (emit quasivector quasilist* @@ -24158,27 +20584,36 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("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)) #("i28359")) + #(ribcage #(p) #((top)) #("i60411")) #(ribcage #(p q) #((top) (top)) - #("i28353" "i28354")) + #("i60405" "i60406")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28349" "i28350")) + #("i60401" "i60402")) #(ribcage (emit quasivector quasilist* @@ -24193,22 +20628,31 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) - (#{quasi 28568}# - #{p 28768}# - (#{1-}# #{lev 28755}#))) - (#{vquasi 28569}# #{q 28762}# #{lev 28755}#)))) - #{tmp 28764}#) - (let ((#{tmp 28811}# + (#{quasi 60620}# + #{p 60823}# + (#{1-}# #{lev 60810}#))) + (#{vquasi 60621}# #{q 60817}# #{lev 60810}#)))) + #{tmp 60819}#) + (let ((#{tmp 60869}# ($sc-dispatch - #{p 28761}# + #{p 60816}# '(#(free-id #(syntax-object unquote-splicing @@ -24216,12 +20660,12 @@ #(ribcage #(p q) #((top) (top)) - #("i28353" "i28354")) + #("i60405" "i60406")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28349" "i28350")) + #("i60401" "i60402")) #(ribcage (emit quasivector quasilist* @@ -24236,38 +20680,47 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) . each-any)))) - (if #{tmp 28811}# + (if #{tmp 60869}# (@apply - (lambda (#{p 28815}#) - (if (= #{lev 28755}# 0) - (#{quasiappend 28571}# - (map (lambda (#{tmp 28366 28818}#) + (lambda (#{p 60873}#) + (if (= #{lev 60810}# 0) + (#{quasiappend 60623}# + (map (lambda (#{tmp 60418 60876}#) (list '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) - #("i28364")) + #("i60416")) #(ribcage #(p q) #((top) (top)) - #("i28353" "i28354")) + #("i60405" "i60406")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28349" "i28350")) + #("i60401" "i60402")) #(ribcage (emit quasivector quasilist* @@ -24282,34 +20735,43 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{tmp 28366 28818}#)) - #{p 28815}#) - (#{vquasi 28569}# - #{q 28762}# - #{lev 28755}#)) - (#{quasicons 28570}# - (#{quasicons 28570}# + #{tmp 60418 60876}#)) + #{p 60873}#) + (#{vquasi 60621}# + #{q 60817}# + #{lev 60810}#)) + (#{quasicons 60622}# + (#{quasicons 60622}# '(#(syntax-object "quote" ((top) - #(ribcage #(p) #((top)) #("i28364")) + #(ribcage #(p) #((top)) #("i60416")) #(ribcage #(p q) #((top) (top)) - #("i28353" "i28354")) + #("i60405" "i60406")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28349" "i28350")) + #("i60401" "i60402")) #(ribcage (emit quasivector quasilist* @@ -24324,27 +20786,36 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("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)) #("i28364")) + #(ribcage #(p) #((top)) #("i60416")) #(ribcage #(p q) #((top) (top)) - #("i28353" "i28354")) + #("i60405" "i60406")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i28349" "i28350")) + #("i60401" "i60402")) #(ribcage (emit quasivector quasilist* @@ -24359,27 +20830,36 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile))) - (#{quasi 28568}# - #{p 28815}# - (#{1-}# #{lev 28755}#))) - (#{vquasi 28569}# - #{q 28762}# - #{lev 28755}#)))) - #{tmp 28811}#) - (#{quasicons 28570}# - (#{quasi 28568}# #{p 28761}# #{lev 28755}#) - (#{vquasi 28569}# #{q 28762}# #{lev 28755}#))))))) - #{tmp 28757}#) - (let ((#{tmp 28836}# ($sc-dispatch #{p 28754}# '()))) - (if #{tmp 28836}# + (#{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 @@ -24389,7 +20869,7 @@ #(ribcage #(p lev) #((top) (top)) - #("i28349" "i28350")) + #("i60401" "i60402")) #(ribcage (emit quasivector quasilist* @@ -24398,64 +20878,73 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) ())) - #{tmp 28836}#) + #{tmp 60894}#) (syntax-violation #f "source expression failed to match any pattern" - #{p 28754}#))))))) - (#{quasicons 28570}# - (lambda (#{x 28849}# #{y 28850}#) - (let ((#{tmp 28851}# (list #{x 28849}# #{y 28850}#))) - (let ((#{tmp 28852}# - ($sc-dispatch #{tmp 28851}# '(any any)))) - (if #{tmp 28852}# + #{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 28854}# #{y 28855}#) - (let ((#{tmp 28857}# + (lambda (#{x 60912}# #{y 60913}#) + (let ((#{tmp 60915}# ($sc-dispatch - #{y 28855}# + #{y 60913}# '(#(atom "quote") any)))) - (if #{tmp 28857}# + (if #{tmp 60915}# (@apply - (lambda (#{dy 28861}#) - (let ((#{tmp 28863}# + (lambda (#{dy 60919}#) + (let ((#{tmp 60921}# ($sc-dispatch - #{x 28854}# + #{x 60912}# '(#(atom "quote") any)))) - (if #{tmp 28863}# + (if #{tmp 60921}# (@apply - (lambda (#{dx 28867}#) + (lambda (#{dx 60925}#) (list '#(syntax-object "quote" ((top) #(ribcage #(dx) #((top)) - #("i28388")) + #("i60440")) #(ribcage #(dy) #((top)) - #("i28384")) + #("i60436")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28378" "i28379")) + #("i60430" "i60431")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28373" "i28374")) + #("i60425" "i60426")) #(ribcage (emit quasivector quasilist* @@ -24470,39 +20959,48 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - (cons #{dx 28867}# #{dy 28861}#))) - #{tmp 28863}#) - (if (null? #{dy 28861}#) + (cons #{dx 60925}# #{dy 60919}#))) + #{tmp 60921}#) + (if (null? #{dy 60919}#) (list '#(syntax-object "list" ((top) #(ribcage #(_) #((top)) - #("i28390")) + #("i60442")) #(ribcage #(dy) #((top)) - #("i28384")) + #("i60436")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28378" "i28379")) + #("i60430" "i60431")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28373" "i28374")) + #("i60425" "i60426")) #(ribcage (emit quasivector quasilist* @@ -24517,37 +21015,46 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{x 28854}#) + #{x 60912}#) (list '#(syntax-object "list*" ((top) #(ribcage #(_) #((top)) - #("i28390")) + #("i60442")) #(ribcage #(dy) #((top)) - #("i28384")) + #("i60436")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28378" "i28379")) + #("i60430" "i60431")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28373" "i28374")) + #("i60425" "i60426")) #(ribcage (emit quasivector quasilist* @@ -24562,42 +21069,51 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{x 28854}# - #{y 28855}#))))) - #{tmp 28857}#) - (let ((#{tmp 28872}# + #{x 60912}# + #{y 60913}#))))) + #{tmp 60915}#) + (let ((#{tmp 60930}# ($sc-dispatch - #{y 28855}# + #{y 60913}# '(#(atom "list") . any)))) - (if #{tmp 28872}# + (if #{tmp 60930}# (@apply - (lambda (#{stuff 28876}#) + (lambda (#{stuff 60934}#) (cons '#(syntax-object "list" ((top) #(ribcage #(stuff) #((top)) - #("i28393")) + #("i60445")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28378" "i28379")) + #("i60430" "i60431")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28373" "i28374")) + #("i60425" "i60426")) #(ribcage (emit quasivector quasilist* @@ -24612,41 +21128,50 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - (cons #{x 28854}# #{stuff 28876}#))) - #{tmp 28872}#) - (let ((#{tmp 28877}# + (cons #{x 60912}# #{stuff 60934}#))) + #{tmp 60930}#) + (let ((#{tmp 60935}# ($sc-dispatch - #{y 28855}# + #{y 60913}# '(#(atom "list*") . any)))) - (if #{tmp 28877}# + (if #{tmp 60935}# (@apply - (lambda (#{stuff 28881}#) + (lambda (#{stuff 60939}#) (cons '#(syntax-object "list*" ((top) #(ribcage #(stuff) #((top)) - #("i28396")) + #("i60448")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28378" "i28379")) + #("i60430" "i60431")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28373" "i28374")) + #("i60425" "i60426")) #(ribcage (emit quasivector quasilist* @@ -24661,31 +21186,40 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - (cons #{x 28854}# #{stuff 28881}#))) - #{tmp 28877}#) + (cons #{x 60912}# #{stuff 60939}#))) + #{tmp 60935}#) (list '#(syntax-object "list*" ((top) - #(ribcage #(_) #((top)) #("i28398")) + #(ribcage #(_) #((top)) #("i60450")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28378" "i28379")) + #("i60430" "i60431")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28373" "i28374")) + #("i60425" "i60426")) #(ribcage (emit quasivector quasilist* @@ -24700,29 +21234,38 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{x 28854}# - #{y 28855}#)))))))) - #{tmp 28852}#) + #{x 60912}# + #{y 60913}#)))))))) + #{tmp 60910}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 28851}#)))))) - (#{quasiappend 28571}# - (lambda (#{x 28892}# #{y 28893}#) - (let ((#{tmp 28895}# - ($sc-dispatch #{y 28893}# '(#(atom "quote") ())))) - (if #{tmp 28895}# + #{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 28892}#) + (if (null? #{x 60950}#) '(#(syntax-object "quote" ((top) @@ -24730,7 +21273,7 @@ #(ribcage #(x y) #((top) (top)) - #("i28402" "i28403")) + #("i60454" "i60455")) #(ribcage (emit quasivector quasilist* @@ -24739,32 +21282,41 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) ()) - (if (null? (cdr #{x 28892}#)) - (car #{x 28892}#) - (let ((#{tmp 28900}# - ($sc-dispatch #{x 28892}# 'each-any))) - (if #{tmp 28900}# + (if (null? (cdr #{x 60950}#)) + (car #{x 60950}#) + (let ((#{tmp 60958}# + ($sc-dispatch #{x 60950}# 'each-any))) + (if #{tmp 60958}# (@apply - (lambda (#{p 28904}#) + (lambda (#{p 60962}#) (cons '#(syntax-object "append" ((top) #(ribcage () () ()) - #(ribcage #(p) #((top)) #("i28414")) + #(ribcage #(p) #((top)) #("i60466")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28402" "i28403")) + #("i60454" "i60455")) #(ribcage (emit quasivector quasilist* @@ -24779,29 +21331,38 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{p 28904}#)) - #{tmp 28900}#) + #{p 60962}#)) + #{tmp 60958}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 28892}#)))))) - #{tmp 28895}#) - (if (null? #{x 28892}#) - #{y 28893}# - (let ((#{tmp 28912}# (list #{x 28892}# #{y 28893}#))) - (let ((#{tmp 28913}# - ($sc-dispatch #{tmp 28912}# '(each-any any)))) - (if #{tmp 28913}# + #{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 28915}# #{y 28916}#) + (lambda (#{p 60973}# #{y 60974}#) (cons '#(syntax-object "append" ((top) @@ -24809,13 +21370,13 @@ #(ribcage #(p y) #((top) (top)) - #("i28425" "i28426")) - #(ribcage #(_) #((top)) #("i28417")) + #("i60477" "i60478")) + #(ribcage #(_) #((top)) #("i60469")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i28402" "i28403")) + #("i60454" "i60455")) #(ribcage (emit quasivector quasilist* @@ -24830,44 +21391,53 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - (append #{p 28915}# (list #{y 28916}#)))) - #{tmp 28913}#) + (append #{p 60973}# (list #{y 60974}#)))) + #{tmp 60971}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 28912}#))))))))) - (#{quasilist* 28572}# - (lambda (#{x 28920}# #{y 28921}#) + #{tmp 60970}#))))))))) + (#{quasilist* 60624}# + (lambda (#{x 60978}# #{y 60979}#) (letrec* - ((#{f 28922}# - (lambda (#{x 29011}#) - (if (null? #{x 29011}#) - #{y 28921}# - (#{quasicons 28570}# - (car #{x 29011}#) - (#{f 28922}# (cdr #{x 29011}#))))))) - (#{f 28922}# #{x 28920}#)))) - (#{emit 28574}# - (lambda (#{x 29014}#) - (let ((#{tmp 29016}# - ($sc-dispatch #{x 29014}# '(#(atom "quote") any)))) - (if #{tmp 29016}# + ((#{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 29020}#) + (lambda (#{x 61093}#) (list '#(syntax-object quote ((top) - #(ribcage #(x) #((top)) #("i28492")) + #(ribcage #(x) #((top)) #("i60544")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i28489")) + #(ribcage #(x) #((top)) #("i60541")) #(ribcage (emit quasivector quasilist* @@ -24876,40 +21446,49 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{x 29020}#)) - #{tmp 29016}#) - (let ((#{tmp 29021}# + #{x 61093}#)) + #{tmp 61089}#) + (let ((#{tmp 61094}# ($sc-dispatch - #{x 29014}# + #{x 61087}# '(#(atom "list") . each-any)))) - (if #{tmp 29021}# + (if #{tmp 61094}# (@apply - (lambda (#{x 29025}#) - (let ((#{tmp 29026}# (map #{emit 28574}# #{x 29025}#))) - (let ((#{tmp 29027}# - ($sc-dispatch #{tmp 29026}# 'each-any))) - (if #{tmp 29027}# + (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 (#{ g28497 29029}#) + (lambda (#{ g60549 61102}#) (cons '#(syntax-object list ((top) #(ribcage () () ()) #(ribcage - #(#{ g28497}#) - #((m28498 top)) - #("i28502")) - #(ribcage #(x) #((top)) #("i28495")) + #(#{ g60549}#) + #((m60550 top)) + #("i60554")) + #(ribcage #(x) #((top)) #("i60547")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i28489")) + #(ribcage #(x) #((top)) #("i60541")) #(ribcage (emit quasivector quasilist* @@ -24924,70 +21503,79 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{ g28497 29029}#)) - #{tmp 29027}#) + #{ g60549 61102}#)) + #{tmp 61100}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 29026}#))))) - #{tmp 29021}#) - (let ((#{tmp 29030}# + #{tmp 61099}#))))) + #{tmp 61094}#) + (let ((#{tmp 61103}# ($sc-dispatch - #{x 29014}# + #{x 61087}# '(#(atom "list*") . #(each+ any (any) ()))))) - (if #{tmp 29030}# + (if #{tmp 61103}# (@apply - (lambda (#{x 29034}# #{y 29035}#) + (lambda (#{x 61107}# #{y 61108}#) (letrec* - ((#{f 29036}# - (lambda (#{x* 29039}#) - (if (null? #{x* 29039}#) - (#{emit 28574}# #{y 29035}#) - (let ((#{tmp 29040}# - (list (#{emit 28574}# - (car #{x* 29039}#)) - (#{f 29036}# - (cdr #{x* 29039}#))))) - (let ((#{tmp 29041}# + ((#{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 29040}# + #{tmp 61113}# '(any any)))) - (if #{tmp 29041}# + (if #{tmp 61114}# (@apply - (lambda (#{ g28517 29043}# - #{ g28516 29044}#) + (lambda (#{ g60569 61116}# + #{ g60568 61117}#) (list '#(syntax-object cons ((top) #(ribcage () () ()) #(ribcage - #(#{ g28517}# - #{ g28516}#) - #((m28518 top) - (m28518 top)) - #("i28522" "i28523")) + #(#{ g60569}# + #{ g60568}#) + #((m60570 top) + (m60570 top)) + #("i60574" "i60575")) #(ribcage () () ()) #(ribcage #(f x*) #((top) (top)) - #("i28511" "i28512")) + #("i60563" "i60564")) #(ribcage #(x y) #((top) (top)) - #("i28507" "i28508")) + #("i60559" "i60560")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i28489")) + #("i60541")) #(ribcage (emit quasivector quasilist* @@ -25002,56 +21590,66 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{ g28517 29043}# - #{ g28516 29044}#)) - #{tmp 29041}#) + #{ g60569 61116}# + #{ g60568 61117}#)) + #{tmp 61114}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 29040}#)))))))) - (#{f 29036}# #{x 29034}#))) - #{tmp 29030}#) - (let ((#{tmp 29045}# + #{tmp 61113}#)))))))) + (#{f 61109}# #{x 61107}#))) + #{tmp 61103}#) + (let ((#{tmp 61118}# ($sc-dispatch - #{x 29014}# + #{x 61087}# '(#(atom "append") . each-any)))) - (if #{tmp 29045}# + (if #{tmp 61118}# (@apply - (lambda (#{x 29049}#) - (let ((#{tmp 29050}# - (map #{emit 28574}# #{x 29049}#))) - (let ((#{tmp 29051}# + (lambda (#{x 61122}#) + (let ((#{tmp 61123}# + (map #{emit 60626}# #{x 61122}#))) + (let ((#{tmp 61124}# ($sc-dispatch - #{tmp 29050}# + #{tmp 61123}# 'each-any))) - (if #{tmp 29051}# + (if #{tmp 61124}# (@apply - (lambda (#{ g28529 29053}#) + (lambda (#{ g60581 61126}#) (cons '#(syntax-object append ((top) #(ribcage () () ()) #(ribcage - #(#{ g28529}#) - #((m28530 top)) - #("i28534")) + #(#{ g60581}#) + #((m60582 top)) + #("i60586")) #(ribcage #(x) #((top)) - #("i28527")) + #("i60579")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i28489")) + #("i60541")) #(ribcage (emit quasivector quasilist* @@ -25066,54 +21664,63 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{ g28529 29053}#)) - #{tmp 29051}#) + #{ g60581 61126}#)) + #{tmp 61124}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 29050}#))))) - #{tmp 29045}#) - (let ((#{tmp 29054}# + #{tmp 61123}#))))) + #{tmp 61118}#) + (let ((#{tmp 61127}# ($sc-dispatch - #{x 29014}# + #{x 61087}# '(#(atom "vector") . each-any)))) - (if #{tmp 29054}# + (if #{tmp 61127}# (@apply - (lambda (#{x 29058}#) - (let ((#{tmp 29059}# - (map #{emit 28574}# #{x 29058}#))) - (let ((#{tmp 29060}# + (lambda (#{x 61131}#) + (let ((#{tmp 61132}# + (map #{emit 60626}# #{x 61131}#))) + (let ((#{tmp 61133}# ($sc-dispatch - #{tmp 29059}# + #{tmp 61132}# 'each-any))) - (if #{tmp 29060}# + (if #{tmp 61133}# (@apply - (lambda (#{ g28541 29062}#) + (lambda (#{ g60593 61135}#) (cons '#(syntax-object vector ((top) #(ribcage () () ()) #(ribcage - #(#{ g28541}#) - #((m28542 top)) - #("i28546")) + #(#{ g60593}#) + #((m60594 top)) + #("i60598")) #(ribcage #(x) #((top)) - #("i28539")) + #("i60591")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i28489")) + #("i60541")) #(ribcage (emit quasivector quasilist* @@ -25128,47 +21735,57 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{ g28541 29062}#)) - #{tmp 29060}#) + #{ g60593 61135}#)) + #{tmp 61133}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 29059}#))))) - #{tmp 29054}#) - (let ((#{tmp 29063}# + #{tmp 61132}#))))) + #{tmp 61127}#) + (let ((#{tmp 61136}# ($sc-dispatch - #{x 29014}# + #{x 61087}# '(#(atom "list->vector") any)))) - (if #{tmp 29063}# + (if #{tmp 61136}# (@apply - (lambda (#{x 29067}#) - (let ((#{tmp 29068}# - (#{emit 28574}# #{x 29067}#))) + (lambda (#{x 61140}#) + (let ((#{tmp 61141}# + (#{emit 60626}# #{x 61140}#))) (list '#(syntax-object list->vector ((top) #(ribcage () () ()) #(ribcage - #(#{ g28553}#) - #((m28554 top)) - #("i28557")) + #(#{ g60605}#) + #((m60606 top)) + #("i60609")) #(ribcage #(x) #((top)) - #("i28551")) + #("i60603")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i28489")) + #("i60541")) #(ribcage (emit quasivector quasilist* @@ -25183,188 +21800,215 @@ (top) (top) (top)) - ("i28310" - "i28308" - "i28306" - "i28304" - "i28302" - "i28300" - "i28298"))) + ("i60362" + "i60360" + "i60358" + "i60356" + "i60354" + "i60352" + "i60350")) + #(ribcage + (quasiquote) + ((top)) + (((hygiene guile) + . + #(syntax-object + quasiquote + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{tmp 29068}#))) - #{tmp 29063}#) - (let ((#{tmp 29071}# + #{tmp 61141}#))) + #{tmp 61136}#) + (let ((#{tmp 61144}# ($sc-dispatch - #{x 29014}# + #{x 61087}# '(#(atom "value") any)))) - (if #{tmp 29071}# + (if #{tmp 61144}# (@apply - (lambda (#{x 29075}#) #{x 29075}#) - #{tmp 29071}#) + (lambda (#{x 61148}#) #{x 61148}#) + #{tmp 61144}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 29014}#)))))))))))))))))) - (lambda (#{x 28575}#) - (let ((#{tmp 28577}# - ($sc-dispatch #{x 28575}# '(_ any)))) - (if #{tmp 28577}# + #{x 61087}#)))))))))))))))))) + (lambda (#{x 60627}#) + (let ((#{tmp 60629}# + ($sc-dispatch #{x 60627}# '(_ any)))) + (if #{tmp 60629}# (@apply - (lambda (#{e 28581}#) - (#{emit 28574}# (#{quasi 28568}# #{e 28581}# 0))) - #{tmp 28577}#) + (lambda (#{e 60633}#) + (#{emit 60626}# (#{quasi 60620}# #{e 60633}# 0))) + #{tmp 60629}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 28575}#))))))) + #{x 60627}#))))))) (define include (make-syntax-transformer 'include 'macro - (lambda (#{x 29130}#) + (lambda (#{x 61204}#) (letrec* - ((#{read-file 29131}# - (lambda (#{fn 29240}# #{k 29241}#) - (let ((#{p 29242}# (open-input-file #{fn 29240}#))) + ((#{read-file 61205}# + (lambda (#{fn 61314}# #{k 61315}#) + (let ((#{p 61316}# (open-input-file #{fn 61314}#))) (letrec* - ((#{f 29243}# - (lambda (#{x 29297}# #{result 29298}#) - (if (eof-object? #{x 29297}#) + ((#{f 61317}# + (lambda (#{x 61371}# #{result 61372}#) + (if (eof-object? #{x 61371}#) (begin - (close-input-port #{p 29242}#) - (reverse #{result 29298}#)) - (#{f 29243}# - (read #{p 29242}#) - (cons (datum->syntax #{k 29241}# #{x 29297}#) - #{result 29298}#)))))) - (#{f 29243}# (read #{p 29242}#) '())))))) - (let ((#{tmp 29133}# - ($sc-dispatch #{x 29130}# '(any any)))) - (if #{tmp 29133}# + (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 29137}# #{filename 29138}#) - (let ((#{fn 29139}# (syntax->datum #{filename 29138}#))) - (let ((#{tmp 29140}# - (#{read-file 29131}# - #{fn 29139}# - #{filename 29138}#))) - (let ((#{tmp 29141}# - ($sc-dispatch #{tmp 29140}# 'each-any))) - (if #{tmp 29141}# + (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 29159}#) + (lambda (#{exp 61233}#) (cons '#(syntax-object begin ((top) #(ribcage () () ()) - #(ribcage #(exp) #((top)) #("i29127")) + #(ribcage #(exp) #((top)) #("i61201")) #(ribcage () () ()) #(ribcage () () ()) - #(ribcage #(fn) #((top)) #("i29122")) + #(ribcage #(fn) #((top)) #("i61196")) #(ribcage #(k filename) #((top) (top)) - #("i29118" "i29119")) - #(ribcage (read-file) ((top)) ("i29102")) - #(ribcage #(x) #((top)) #("i29101"))) + #("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 29159}#)) - #{tmp 29141}#) + #{exp 61233}#)) + #{tmp 61215}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 29140}#)))))) - #{tmp 29133}#) + #{tmp 61214}#)))))) + #{tmp 61207}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 29130}#))))))) + #{x 61204}#))))))) (define include-from-path (make-syntax-transformer 'include-from-path 'macro - (lambda (#{x 29317}#) - (let ((#{tmp 29319}# - ($sc-dispatch #{x 29317}# '(any any)))) - (if #{tmp 29319}# + (lambda (#{x 61392}#) + (let ((#{tmp 61394}# + ($sc-dispatch #{x 61392}# '(any any)))) + (if #{tmp 61394}# (@apply - (lambda (#{k 29323}# #{filename 29324}#) - (let ((#{fn 29325}# (syntax->datum #{filename 29324}#))) - (let ((#{tmp 29326}# + (lambda (#{k 61398}# #{filename 61399}#) + (let ((#{fn 61400}# (syntax->datum #{filename 61399}#))) + (let ((#{tmp 61401}# (datum->syntax - #{filename 29324}# - (let ((#{t 29329}# (%search-load-path #{fn 29325}#))) - (if #{t 29329}# - #{t 29329}# + #{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 29317}# - #{filename 29324}#)))))) + #{x 61392}# + #{filename 61399}#)))))) (list '#(syntax-object include ((top) #(ribcage () () ()) - #(ribcage #(fn) #((top)) #("i29311")) + #(ribcage #(fn) #((top)) #("i61386")) #(ribcage () () ()) #(ribcage () () ()) - #(ribcage #(fn) #((top)) #("i29307")) + #(ribcage #(fn) #((top)) #("i61382")) #(ribcage #(k filename) #((top) (top)) - #("i29303" "i29304")) + #("i61378" "i61379")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29300"))) + #(ribcage #(x) #((top)) #("i61375")) + #(ribcage + (include-from-path) + ((top)) + (((hygiene guile) + . + #(syntax-object + include-from-path + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{tmp 29326}#)))) - #{tmp 29319}#) + #{tmp 61401}#)))) + #{tmp 61394}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 29317}#)))))) + #{x 61392}#)))))) (define unquote (make-syntax-transformer 'unquote 'macro - (lambda (#{x 29338}#) + (lambda (#{x 61414}#) (syntax-violation 'unquote "expression not valid outside of quasiquote" - #{x 29338}#)))) + #{x 61414}#)))) (define unquote-splicing (make-syntax-transformer 'unquote-splicing 'macro - (lambda (#{x 29341}#) + (lambda (#{x 61418}#) (syntax-violation 'unquote-splicing "expression not valid outside of quasiquote" - #{x 29341}#)))) + #{x 61418}#)))) (define case (make-syntax-transformer 'case 'macro - (lambda (#{x 29397}#) - (let ((#{tmp 29399}# + (lambda (#{x 61475}#) + (let ((#{tmp 61477}# ($sc-dispatch - #{x 29397}# + #{x 61475}# '(_ any any . each-any)))) - (if #{tmp 29399}# + (if #{tmp 61477}# (@apply - (lambda (#{e 29403}# #{m1 29404}# #{m2 29405}#) - (let ((#{tmp 29406}# + (lambda (#{e 61481}# #{m1 61482}# #{m2 61483}#) + (let ((#{tmp 61484}# (letrec* - ((#{f 29448}# - (lambda (#{clause 29451}# #{clauses 29452}#) - (if (null? #{clauses 29452}#) - (let ((#{tmp 29454}# + ((#{f 61538}# + (lambda (#{clause 61541}# #{clauses 61542}#) + (if (null? #{clauses 61542}#) + (let ((#{tmp 61544}# ($sc-dispatch - #{clause 29451}# + #{clause 61541}# '(#(free-id #(syntax-object else @@ -25373,91 +22017,118 @@ #(ribcage #(f clause clauses) #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene guile) + . + #(syntax-object + case + ((top)) + (hygiene guile)))))) (hygiene guile))) any . each-any)))) - (if #{tmp 29454}# + (if #{tmp 61544}# (@apply - (lambda (#{e1 29458}# #{e2 29459}#) + (lambda (#{e1 61548}# #{e2 61549}#) (cons '#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i29365" "i29366")) + #("i61443" "i61444")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene guile) + . + #(syntax-object + case + ((top)) + (hygiene guile)))))) (hygiene guile)) - (cons #{e1 29458}# #{e2 29459}#))) - #{tmp 29454}#) - (let ((#{tmp 29460}# + (cons #{e1 61548}# #{e2 61549}#))) + #{tmp 61544}#) + (let ((#{tmp 61550}# ($sc-dispatch - #{clause 29451}# + #{clause 61541}# '(each-any any . each-any)))) - (if #{tmp 29460}# + (if #{tmp 61550}# (@apply - (lambda (#{k 29464}# - #{e1 29465}# - #{e2 29466}#) + (lambda (#{k 61554}# + #{e1 61555}# + #{e2 61556}#) (list '#(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) - #("i29371" - "i29372" - "i29373")) + #("i61449" + "i61450" + "i61451")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene guile) + . + #(syntax-object + case + ((top)) + (hygiene guile)))))) (hygiene guile)) (list '#(syntax-object memv @@ -25467,9 +22138,9 @@ #((top) (top) (top)) - #("i29371" - "i29372" - "i29373")) + #("i61449" + "i61450" + "i61451")) #(ribcage () () ()) #(ribcage #(f @@ -25478,22 +22149,32 @@ #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene guile) + . + #(syntax-object + case + ((top)) + (hygiene + guile)))))) (hygiene guile)) '#(syntax-object t @@ -25503,9 +22184,9 @@ #((top) (top) (top)) - #("i29371" - "i29372" - "i29373")) + #("i61449" + "i61450" + "i61451")) #(ribcage () () ()) #(ribcage #(f @@ -25514,22 +22195,32 @@ #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene guile) + . + #(syntax-object + case + ((top)) + (hygiene + guile)))))) (hygiene guile)) (list '#(syntax-object quote @@ -25539,9 +22230,9 @@ #((top) (top) (top)) - #("i29371" - "i29372" - "i29373")) + #("i61449" + "i61450" + "i61451")) #(ribcage () () @@ -25553,17 +22244,17 @@ #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () @@ -25571,10 +22262,21 @@ #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene + guile) + . + #(syntax-object + case + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{k 29464}#)) + #{k 61554}#)) (cons '#(syntax-object begin ((top) @@ -25583,9 +22285,9 @@ #((top) (top) (top)) - #("i29371" - "i29372" - "i29373")) + #("i61449" + "i61450" + "i61451")) #(ribcage () () ()) #(ribcage #(f @@ -25594,76 +22296,95 @@ #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene guile) + . + #(syntax-object + case + ((top)) + (hygiene + guile)))))) (hygiene guile)) - (cons #{e1 29465}# - #{e2 29466}#)))) - #{tmp 29460}#) + (cons #{e1 61555}# + #{e2 61556}#)))) + #{tmp 61550}#) (syntax-violation 'case "bad clause" - #{x 29397}# - #{clause 29451}#))))) - (let ((#{tmp 29474}# - (#{f 29448}# - (car #{clauses 29452}#) - (cdr #{clauses 29452}#)))) - (let ((#{tmp 29477}# + #{x 61475}# + #{clause 61541}#))))) + (let ((#{tmp 61564}# + (#{f 61538}# + (car #{clauses 61542}#) + (cdr #{clauses 61542}#)))) + (let ((#{tmp 61567}# ($sc-dispatch - #{clause 29451}# + #{clause 61541}# '(each-any any . each-any)))) - (if #{tmp 29477}# + (if #{tmp 61567}# (@apply - (lambda (#{k 29481}# - #{e1 29482}# - #{e2 29483}#) + (lambda (#{k 61571}# + #{e1 61572}# + #{e2 61573}#) (list '#(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) - #("i29387" - "i29388" - "i29389")) + #("i61465" + "i61466" + "i61467")) #(ribcage () () ()) #(ribcage #(rest) #((top)) - #("i29383")) + #("i61461")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene guile) + . + #(syntax-object + case + ((top)) + (hygiene guile)))))) (hygiene guile)) (list '#(syntax-object memv @@ -25671,32 +22392,42 @@ #(ribcage #(k e1 e2) #((top) (top) (top)) - #("i29387" - "i29388" - "i29389")) + #("i61465" + "i61466" + "i61467")) #(ribcage () () ()) #(ribcage #(rest) #((top)) - #("i29383")) + #("i61461")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene guile) + . + #(syntax-object + case + ((top)) + (hygiene + guile)))))) (hygiene guile)) '#(syntax-object t @@ -25704,32 +22435,42 @@ #(ribcage #(k e1 e2) #((top) (top) (top)) - #("i29387" - "i29388" - "i29389")) + #("i61465" + "i61466" + "i61467")) #(ribcage () () ()) #(ribcage #(rest) #((top)) - #("i29383")) + #("i61461")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene guile) + . + #(syntax-object + case + ((top)) + (hygiene + guile)))))) (hygiene guile)) (list '#(syntax-object quote @@ -25739,9 +22480,9 @@ #((top) (top) (top)) - #("i29387" - "i29388" - "i29389")) + #("i61465" + "i61466" + "i61467")) #(ribcage () () @@ -25749,7 +22490,7 @@ #(ribcage #(rest) #((top)) - #("i29383")) + #("i61461")) #(ribcage () () @@ -25761,17 +22502,17 @@ #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () @@ -25779,232 +22520,415 @@ #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene + guile) + . + #(syntax-object + case + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{k 29481}#)) + #{k 61571}#)) (cons '#(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) - #("i29387" - "i29388" - "i29389")) + #("i61465" + "i61466" + "i61467")) #(ribcage () () ()) #(ribcage #(rest) #((top)) - #("i29383")) + #("i61461")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) - #("i29356" - "i29357" - "i29358")) + #("i61434" + "i61435" + "i61436")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" - "i29347" - "i29348")) + #("i61424" + "i61425" + "i61426")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29343"))) + #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene guile) + . + #(syntax-object + case + ((top)) + (hygiene + guile)))))) (hygiene guile)) - (cons #{e1 29482}# - #{e2 29483}#)) - #{tmp 29474}#)) - #{tmp 29477}#) + (cons #{e1 61572}# + #{e2 61573}#)) + #{tmp 61564}#)) + #{tmp 61567}#) (syntax-violation 'case "bad clause" - #{x 29397}# - #{clause 29451}#)))))))) - (#{f 29448}# #{m1 29404}# #{m2 29405}#)))) - (let ((#{body 29407}# #{tmp 29406}#)) + #{x 61475}# + #{clause 61541}#)))))))) + (#{f 61538}# #{m1 61482}# #{m2 61483}#)))) + (let ((#{body 61485}# #{tmp 61484}#)) (list '#(syntax-object let ((top) #(ribcage () () ()) - #(ribcage #(body) #((top)) #("i29354")) + #(ribcage #(body) #((top)) #("i61432")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" "i29347" "i29348")) + #("i61424" "i61425" "i61426")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29343"))) + #(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)) #("i29354")) + #(ribcage #(body) #((top)) #("i61432")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i29346" "i29347" "i29348")) + #("i61424" "i61425" "i61426")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29343"))) + #(ribcage #(x) #((top)) #("i61421")) + #(ribcage + (case) + ((top)) + (((hygiene guile) + . + #(syntax-object + case + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{e 29403}#)) - #{body 29407}#)))) - #{tmp 29399}#) + #{e 61481}#)) + #{body 61485}#)))) + #{tmp 61477}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 29397}#)))))) + #{x 61475}#)))))) (define make-variable-transformer - (lambda (#{proc 29501}#) - (if (procedure? #{proc 29501}#) + (lambda (#{proc 61592}#) + (if (procedure? #{proc 61592}#) (letrec* - ((#{trans 29502}# - (lambda (#{x 29508}#) - (#{proc 29501}# #{x 29508}#)))) + ((#{trans 61593}# + (lambda (#{x 61595}#) + (#{proc 61592}# #{x 61595}#)))) (begin (set-procedure-property! - #{trans 29502}# + #{trans 61593}# 'variable-transformer #t) - #{trans 29502}#)) + #{trans 61593}#)) (error "variable transformer not a procedure" - #{proc 29501}#)))) + #{proc 61592}#)))) (define identifier-syntax (make-syntax-transformer 'identifier-syntax 'macro - (lambda (#{x 29540}#) - (let ((#{tmp 29542}# - ($sc-dispatch #{x 29540}# '(_ any)))) - (if #{tmp 29542}# + (lambda (#{x 61632}#) + (let ((#{tmp 61634}# + ($sc-dispatch #{x 61632}# '(_ any)))) + (if #{tmp 61634}# (@apply - (lambda (#{e 29546}#) + (lambda (#{e 61638}#) (list '#(syntax-object lambda ((top) - #(ribcage #(e) #((top)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(ribcage #(x) #((top)) #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{e 29546}#)) + #{e 61638}#)) (list '(#(syntax-object _ ((top) - #(ribcage #(e) #((top)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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)) #("i29515")) + #(ribcage #(e) #((top)) #("i61607")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(ribcage #(x) #((top)) #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) - (cons #{e 29546}# + (cons #{e 61638}# '(#(syntax-object x ((top) #(ribcage #(e) #((top)) - #("i29515")) + #("i61607")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) #(syntax-object ... @@ -26012,55 +22936,82 @@ #(ribcage #(e) #((top)) - #("i29515")) + #("i61607")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile))))))))) - #{tmp 29542}#) - (let ((#{tmp 29547}# + #{tmp 61634}#) + (let ((#{tmp 61639}# ($sc-dispatch - #{x 29540}# + #{x 61632}# '(_ (any any) ((#(free-id #(syntax-object set! ((top) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(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 29547}# + (if (if #{tmp 61639}# (@apply - (lambda (#{id 29551}# - #{exp1 29552}# - #{var 29553}# - #{val 29554}# - #{exp2 29555}#) - (if (identifier? #{id 29551}#) - (identifier? #{var 29553}#) + (lambda (#{id 61643}# + #{exp1 61644}# + #{var 61645}# + #{val 61646}# + #{exp2 61647}#) + (if (identifier? #{id 61643}#) + (identifier? #{var 61645}#) #f)) - #{tmp 29547}#) + #{tmp 61639}#) #f) (@apply - (lambda (#{id 29556}# - #{exp1 29557}# - #{var 29558}# - #{val 29559}# - #{exp2 29560}#) + (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)) - #("i29530" "i29531" "i29532" "i29533" "i29534")) + #("i61622" "i61623" "i61624" "i61625" "i61626")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(ribcage #(x) #((top)) #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) (list '#(syntax-object lambda @@ -26068,13 +23019,22 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(ribcage #(x) #((top)) #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) '(#(syntax-object x @@ -26082,13 +23042,22 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(ribcage #(x) #((top)) #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile))) '#((#(syntax-object macro-type @@ -26096,13 +23065,22 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(ribcage #(x) #((top)) #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) . #(syntax-object @@ -26111,13 +23089,22 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(ribcage #(x) #((top)) #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)))) (list '#(syntax-object syntax-case @@ -26125,13 +23112,22 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(ribcage #(x) #((top)) #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) '#(syntax-object x @@ -26139,13 +23135,22 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(ribcage #(x) #((top)) #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) '(#(syntax-object set! @@ -26153,13 +23158,22 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29512"))) + #(ribcage #(x) #((top)) #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile))) (list (list '#(syntax-object set! @@ -26171,19 +23185,28 @@ (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{var 29558}# - #{val 29559}#) + #{var 61650}# + #{val 61651}#) (list '#(syntax-object syntax ((top) @@ -26194,19 +23217,28 @@ (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{exp2 29560}#)) - (list (cons #{id 29556}# + #{exp2 61652}#)) + (list (cons #{id 61648}# '(#(syntax-object x ((top) @@ -26217,16 +23249,25 @@ (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) #(syntax-object ... @@ -26238,16 +23279,25 @@ (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)))) (list '#(syntax-object syntax @@ -26259,18 +23309,27 @@ (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) - (cons #{exp1 29557}# + (cons #{exp1 61649}# '(#(syntax-object x ((top) @@ -26285,16 +23344,26 @@ (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene + guile)))))) (hygiene guile)) #(syntax-object ... @@ -26310,18 +23379,28 @@ (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene + guile)))))) (hygiene guile)))))) - (list #{id 29556}# + (list #{id 61648}# (list '#(syntax-object identifier? ((top) @@ -26332,16 +23411,25 @@ (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) (list '#(syntax-object syntax @@ -26357,18 +23445,28 @@ (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene + guile)))))) (hygiene guile)) - #{id 29556}#)) + #{id 61648}#)) (list '#(syntax-object syntax ((top) @@ -26379,68 +23477,95 @@ (top) (top) (top)) - #("i29530" - "i29531" - "i29532" - "i29533" - "i29534")) + #("i61622" + "i61623" + "i61624" + "i61625" + "i61626")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i29512"))) + #("i61604")) + #(ribcage + (identifier-syntax) + ((top)) + (((hygiene guile) + . + #(syntax-object + identifier-syntax + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{exp1 29557}#)))))) - #{tmp 29547}#) + #{exp1 61649}#)))))) + #{tmp 61639}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 29540}#)))))))) + #{x 61632}#)))))))) (define define* (make-syntax-transformer 'define* 'macro - (lambda (#{x 29592}#) - (let ((#{tmp 29594}# + (lambda (#{x 61685}#) + (let ((#{tmp 61687}# ($sc-dispatch - #{x 29592}# + #{x 61685}# '(_ (any . any) any . each-any)))) - (if #{tmp 29594}# + (if #{tmp 61687}# (@apply - (lambda (#{id 29598}# - #{args 29599}# - #{b0 29600}# - #{b1 29601}#) + (lambda (#{id 61691}# + #{args 61692}# + #{b0 61693}# + #{b1 61694}#) (list '#(syntax-object define ((top) #(ribcage #(id args b0 b1) #((top) (top) (top) (top)) - #("i29574" "i29575" "i29576" "i29577")) + #("i61667" "i61668" "i61669" "i61670")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29571"))) + #(ribcage #(x) #((top)) #("i61664")) + #(ribcage + (define*) + ((top)) + (((hygiene guile) + . + #(syntax-object + define* + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{id 29598}# + #{id 61691}# (cons '#(syntax-object lambda* ((top) #(ribcage #(id args b0 b1) #((top) (top) (top) (top)) - #("i29574" "i29575" "i29576" "i29577")) + #("i61667" "i61668" "i61669" "i61670")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29571"))) + #(ribcage #(x) #((top)) #("i61664")) + #(ribcage + (define*) + ((top)) + (((hygiene guile) + . + #(syntax-object + define* + ((top)) + (hygiene guile)))))) (hygiene guile)) - (cons #{args 29599}# - (cons #{b0 29600}# #{b1 29601}#))))) - #{tmp 29594}#) - (let ((#{tmp 29602}# - ($sc-dispatch #{x 29592}# '(_ any any)))) - (if (if #{tmp 29602}# + (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 29606}# #{val 29607}#) + (lambda (#{id 61699}# #{val 61700}#) (identifier? '#(syntax-object x @@ -26448,29 +23573,47 @@ #(ribcage #(id val) #((top) (top)) - #("i29584" "i29585")) + #("i61677" "i61678")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29571"))) + #(ribcage #(x) #((top)) #("i61664")) + #(ribcage + (define*) + ((top)) + (((hygiene guile) + . + #(syntax-object + define* + ((top)) + (hygiene guile)))))) (hygiene guile)))) - #{tmp 29602}#) + #{tmp 61695}#) #f) (@apply - (lambda (#{id 29608}# #{val 29609}#) + (lambda (#{id 61701}# #{val 61702}#) (list '#(syntax-object define ((top) #(ribcage #(id val) #((top) (top)) - #("i29588" "i29589")) + #("i61681" "i61682")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i29571"))) + #(ribcage #(x) #((top)) #("i61664")) + #(ribcage + (define*) + ((top)) + (((hygiene guile) + . + #(syntax-object + define* + ((top)) + (hygiene guile)))))) (hygiene guile)) - #{id 29608}# - #{val 29609}#)) - #{tmp 29602}#) + #{id 61701}# + #{val 61702}#)) + #{tmp 61695}#) (syntax-violation #f "source expression failed to match any pattern" - #{x 29592}#)))))))) + #{x 61685}#)))))))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 4fec91719..9ddd9ad66 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -51,7 +51,7 @@ ;;; bound-identifier=? ;;; datum->syntax ;;; define-syntax -;;; fluid-let-syntax +;;; syntax-parameterize ;;; free-identifier=? ;;; generate-temporaries ;;; identifier? @@ -312,9 +312,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) @@ -401,12 +401,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)) @@ -414,7 +416,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) @@ -435,8 +437,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) @@ -484,18 +486,20 @@ ;; 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 ;; (define) define ;; (define-syntax) define-syntax + ;; (define-syntax-parameter) define-syntax-parameter ;; (local-syntax . rec?) let-syntax/letrec-syntax ;; (eval-when) eval-when ;; (syntax . (<var> . <level>)) pattern variables @@ -505,11 +509,11 @@ ;; <level> ::= <nonnegative integer> ;; <var> ::= variable returned by build-lexical-var - ;; a macro is a user-defined syntactic-form. a core is a system-defined - ;; syntactic form. begin, define, define-syntax, and eval-when are - ;; treated specially since they are sensitive to whether the form is - ;; at top-level and (except for eval-when) can denote valid internal - ;; definitions. + ;; a macro is a user-defined syntactic-form. a core is a + ;; system-defined syntactic form. begin, define, define-syntax, + ;; define-syntax-parameter, and eval-when are treated specially + ;; since they are sensitive to whether the form is at top-level and + ;; (except for eval-when) can denote valid internal definitions. ;; a pattern variable is a variable introduced by syntax-case and can ;; be referenced only within a syntax form. @@ -561,22 +565,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))) @@ -736,62 +728,165 @@ (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 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 (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 (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 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) + mod))) + ((string? n) + (resolve-lexical n (if (syntax-object? id) + (syntax-object-module id) + mod))) + (else + (error "unexpected id-var-name" id w n))))) + ;; free-id=? must be passed fully wrapped ids since (free-id=? x y) ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not. (define free-id=? (lambda (i j) - (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator - (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap))))) - + (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)) @@ -882,159 +977,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) - (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) @@ -1057,6 +1164,7 @@ ;; begin none begin keyword ;; define none define keyword ;; define-syntax none define-syntax keyword + ;; define-syntax-parameter none define-syntax-parameter keyword ;; local-syntax rec? letrec-syntax/let-syntax keyword ;; eval-when none eval-when keyword ;; syntax level pattern variable @@ -1067,35 +1175,38 @@ ;; begin-form none begin expression ;; define-form id variable definition ;; define-syntax-form id syntax definition + ;; define-syntax-parameter-form id syntax parameter definition ;; local-syntax-form rec? syntax definition ;; eval-when-form none eval-when form ;; constant none self-evaluating datum ;; other none anything else ;; - ;; For define-form and define-syntax-form, e is the rhs expression. - ;; For all others, e is the entire form. w is the wrap for e. - ;; s is the source for the entire form. mod is the module for e. + ;; For definition forms (define-form, define-syntax-parameter-form, + ;; and define-syntax-form), e is the rhs expression. For all + ;; others, e is the entire form. w is the wrap for e. s is the + ;; source for the entire form. mod is the module for e. ;; - ;; syntax-type expands macros and unwraps as necessary to get to - ;; one of the forms above. It also parses define and define-syntax - ;; forms, although perhaps this should be done by the consumer. + ;; syntax-type expands macros and unwraps as necessary to get to one + ;; of the forms above. It also parses definition forms, although + ;; perhaps this should be done by the consumer. (define syntax-type (lambda (e r w s rib mod for-car?) (cond ((symbol? e) - (let* ((n (id-var-name e w)) - (b (lookup n r mod)) - (type (binding-type b))) - (case type - ((lexical) (values type (binding-value b) e w s mod)) - ((global) (values type n e w s mod)) - ((macro) - (if for-car? - (values type (binding-value b) e w s mod) - (syntax-type (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 @@ -1148,8 +1259,12 @@ (syntax-case e () ((_ name val) (id? #'name) - (values 'define-syntax-form #'name - #'val w s mod)))) + (values 'define-syntax-form #'name #'val w s mod)))) + ((define-syntax-parameter) + (syntax-case e () + ((_ name val) + (id? #'name) + (values 'define-syntax-parameter-form #'name #'val w s mod)))) (else (values 'call #f e w s mod))))))) ((syntax-object? e) @@ -1181,7 +1296,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) @@ -1190,7 +1305,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) @@ -1201,7 +1316,7 @@ 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)) @@ -1219,7 +1334,7 @@ (if (memq 'eval when-list) (expand-sequence #'(e1 e2 ...) r w s mod) (expand-void)))))) - ((define-form define-syntax-form) + ((define-form define-syntax-form define-syntax-parameter-form) (syntax-violation #f "definition in expression context" e (wrap value w mod))) ((syntax) @@ -1231,12 +1346,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) ;; @@ -1374,13 +1489,17 @@ (cons id var-ids) (cons var vars) (cons (cons er (wrap e w mod)) vals) (cons (make-binding 'lexical var) bindings))))) - ((define-syntax-form) + ((define-syntax-form define-syntax-parameter-form) (let ((id (wrap value w mod)) (label (gen-label))) (extend-ribcage! ribcage id label) (parse (cdr body) (cons id ids) (cons label labels) var-ids vars vals - (cons (make-binding 'macro (cons er (wrap e w mod))) + (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 () @@ -1415,7 +1534,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) @@ -1425,6 +1544,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))) @@ -1751,38 +1872,45 @@ (global-extend 'local-syntax 'letrec-syntax #t) (global-extend 'local-syntax 'let-syntax #f) - (global-extend 'core 'fluid-let-syntax - (lambda (e r w s mod) - (syntax-case e () - ((_ ((var val) ...) e1 e2 ...) - (valid-bound-ids? #'(var ...)) - (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...)))) - (for-each - (lambda (id n) - (case (binding-type (lookup n r mod)) - ((displaced-lexical) - (syntax-violation 'fluid-let-syntax - "identifier out of context" - e - (source-wrap id w s mod))))) - #'(var ...) - names) - (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 'fluid-let-syntax "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) @@ -1791,167 +1919,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) @@ -2086,58 +2213,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) @@ -2207,6 +2329,7 @@ (global-extend 'define 'define '()) (global-extend 'define-syntax 'define-syntax '()) + (global-extend 'define-syntax-parameter 'define-syntax-parameter '()) (global-extend 'eval-when 'eval-when '()) @@ -2285,20 +2408,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) @@ -2313,36 +2437,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) @@ -2352,18 +2472,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) @@ -2380,14 +2500,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 @@ -2635,7 +2755,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)) @@ -2645,7 +2765,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 990994a1e..d6502a65f 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)))) @@ -365,9 +365,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))) @@ -383,8 +386,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 @@ -507,8 +511,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)))) @@ -864,7 +870,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) @@ -925,7 +931,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 @@ -963,12 +969,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) @@ -1028,8 +1034,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? @@ -1116,7 +1122,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) @@ -1176,9 +1182,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) @@ -1193,7 +1199,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))) @@ -1344,7 +1350,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")'. @@ -1401,7 +1407,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 3d7db27a8..2a18342d3 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 6a44fb75a..d210a1982 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 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -24,6 +24,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); @@ -33,7 +34,8 @@ SCM call_num2ulong_long_body (void *data); SCM out_of_range_handler (void *data, SCM key, SCM args) { - assert (scm_equal_p (key, scm_from_locale_symbol ("out-of-range"))); + assert (scm_is_true + (scm_equal_p (key, scm_from_locale_symbol ("out-of-range")))); return SCM_BOOL_T; } @@ -55,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)); @@ -70,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)); @@ -79,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)); @@ -107,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 */ @@ -122,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/standalone/test-scm-spawn-thread.c b/test-suite/standalone/test-scm-spawn-thread.c index b632ab0fe..aa790cdbb 100644 --- a/test-suite/standalone/test-scm-spawn-thread.c +++ b/test-suite/standalone/test-scm-spawn-thread.c @@ -48,7 +48,7 @@ inner_main (void *data) thread = scm_spawn_thread (thread_main, 0, thread_handler, 0); timeout = scm_from_unsigned_integer (time (NULL) + 10); - return (void *) scm_join_thread_timed (thread, timeout, SCM_BOOL_F); + return SCM2PTR (scm_join_thread_timed (thread, timeout, SCM_BOOL_F)); } 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 f405df493..832542edc 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) + (with-test-prefix "regexp-quote" (pass-if-exception "no args" exception:wrong-num-args diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index ac9319dc5..968ab35c3 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -796,7 +796,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 |