diff options
88 files changed, 8687 insertions, 13382 deletions
diff --git a/.gitignore b/.gitignore index 928db2060..0ecf41d3e 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 cbbe90948..e95f7eb7c 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=1 +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 diff --git a/configure.ac b/configure.ac index 3f820bfc1..57c06d5ae 100644 --- a/configure.ac +++ b/configure.ac @@ -1716,8 +1716,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..7f60ac67c 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}. @@ -506,7 +514,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 a5b9740f3..0517fc427 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/__scm.h b/libguile/__scm.h index f5551ad7a..3a8b07a6f 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. @@ -261,47 +273,6 @@ #define SCM_DEBUG_REST_ARGUMENT SCM_DEBUG #endif -/* The macro SCM_DEBUG_TYPING_STRICTNESS indicates what level of type checking - * shall be performed with respect to the use of the SCM datatype. The macro - * may be defined to one of the values 0, 1 and 2. - * - * A value of 0 means that there will be no compile time type checking, since - * the SCM datatype will be declared as an integral type. This setting should - * only be used on systems, where casting from integral types to pointers may - * lead to loss of bit information. - * - * A value of 1 means that there will an intermediate level of compile time - * type checking, since the SCM datatype will be declared as a pointer to an - * undefined struct. This setting is the default, since it does not cost - * anything in terms of performance or code size. - * - * A value of 2 provides a maximum level of compile time type checking since - * the SCM datatype will be declared as a struct. This setting should be used - * for _compile time_ type checking only, since the compiled result is likely - * to be quite inefficient. The right way to make use of this option is to do - * a 'make clean; make CFLAGS=-DSCM_DEBUG_TYPING_STRICTNESS=2', fix your - * errors, and then do 'make clean; make'. - */ -#ifndef SCM_DEBUG_TYPING_STRICTNESS -#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 +348,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 +368,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 +376,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 +394,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 +448,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 +478,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..975a20027 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" 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/bytevectors.c b/libguile/bytevectors.c index 5a83967c3..90252a7a0 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 (); @@ -233,6 +236,7 @@ make_bytevector (size_t len, scm_t_array_element_type element_type) 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; @@ -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_bytevector (signed char *contents, size_t len) +scm_c_take_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 diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index 431b7dddd..4b775f244 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -1,7 +1,7 @@ #ifndef SCM_BYTEVECTORS_H #define SCM_BYTEVECTORS_H -/* 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 License @@ -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; @@ -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_bytevector (signed char *, size_t); +SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t, SCM); SCM_INTERNAL int scm_i_print_bytevector (SCM, SCM, scm_print_state *); diff --git a/libguile/continuations.c b/libguile/continuations.c index cf8b6ac03..7e2096698 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -182,6 +182,17 @@ continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED) 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). */ diff --git a/libguile/debug.c b/libguile/debug.c index 88a01d6aa..1a5c197ee 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; 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 2026788c6..e6ef91757 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -27,2551 +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 (module_prefix == SCM_BOOL_F) - { - 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 = (SCM) 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, 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)) - func = scm_dynamic_func (func, dobj); - 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 (not_found_proc != SCM_BOOL_F) - 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 @@ -2622,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/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..e1d03484d 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: 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..78dd4cac4 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 @@ -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 700740319..ebb77cb08 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 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 @@ -108,21 +108,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/foreign.c b/libguile/foreign.c index 68e0efab5..e82a8c581 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -269,8 +269,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 diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index 4f77f65dd..839154a46 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -237,106 +237,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.h b/libguile/gc.h index 104fb0bb3..f062942ec 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -3,7 +3,7 @@ #ifndef SCM_GC_H #define SCM_GC_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 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 @@ -138,20 +138,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; @@ -205,6 +191,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 = PTR2SCM (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 = PTR2SCM (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 = PTR2SCM (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, ...); @@ -247,28 +341,6 @@ 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/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 dfe26c30d..8ed37fac5 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1676,36 +1676,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) @@ -1849,6 +1819,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 diff --git a/libguile/goops.h b/libguile/goops.h index 47a6e4eca..fcb89685a 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -299,13 +299,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/init.c b/libguile/init.c index 94de5c90a..a541eebfa 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -513,9 +513,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..be7670ad7 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,8 @@ # 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" diff --git a/libguile/inline.h b/libguile/inline.h index a78cac515..6b1cf5e77 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -23,9 +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". -*/ + inlining functions, they are turned into ordinary functions. On + platforms that do support inline functions, the definitions are still + compiled into the library, once, in inline.c. */ #include <stdio.h> #include <string.h> @@ -41,174 +41,27 @@ #include "libguile/error.h" -#ifndef SCM_INLINE_C_INCLUDING_INLINE_H +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); -/* 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 . +SCM_INLINE int scm_is_pair (SCM x); +SCM_INLINE int scm_is_string (SCM x); - 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. +SCM_INLINE int scm_get_byte_or_eof (SCM port); +SCM_INLINE int scm_peek_byte_or_eof (SCM port); +SCM_INLINE void scm_putc (char c, SCM port); +SCM_INLINE void scm_puts (const char *str_data, SCM port); - 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. */ - -#include "libguile/bdw-gc.h" - - -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); - - /* 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 +SCM_INLINE SCM scm_words (scm_t_bits car, scm_t_uint16 n_words); - return z; -} +#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES +/* Either inlining, or being included from inline.c. */ -#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 +71,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 +81,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,10 +108,7 @@ 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); @@ -272,10 +116,7 @@ scm_is_string (SCM x) /* Port I/O. */ -#ifndef SCM_INLINE_C_INCLUDING_INLINE_H -SCM_C_EXTERN_INLINE -#endif -int +SCM_INLINE_IMPLEMENTATION int scm_get_byte_or_eof (SCM port) { int c; @@ -300,10 +141,7 @@ scm_get_byte_or_eof (SCM port) } /* 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_INLINE_IMPLEMENTATION int scm_peek_byte_or_eof (SCM port) { int c; @@ -327,20 +165,14 @@ scm_peek_byte_or_eof (SCM port) return c; } -#ifndef SCM_INLINE_C_INCLUDING_INLINE_H -SCM_C_EXTERN_INLINE -#endif -void +SCM_INLINE_IMPLEMENTATION void scm_putc (char c, SCM port) { SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); scm_lfwrite (&c, 1, port); } -#ifndef SCM_INLINE_C_INCLUDING_INLINE_H -SCM_C_EXTERN_INLINE -#endif -void +SCM_INLINE_IMPLEMENTATION void scm_puts (const char *s, SCM port) { SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); diff --git a/libguile/memoize.c b/libguile/memoize.c index 0b1aa5194..801088ccb 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", @@ -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))); } } @@ -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/numbers.c b/libguile/numbers.c index 5aeced6ca..24ae2bc31 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -532,7 +532,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 @@ -548,7 +548,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 @@ -582,7 +582,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 @@ -616,7 +616,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 @@ -631,7 +631,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 @@ -646,7 +646,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 @@ -661,7 +661,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 @@ -788,7 +788,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 @@ -803,10 +803,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 @@ -824,10 +824,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 @@ -846,10 +846,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 @@ -870,10 +870,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, @@ -1005,8 +1004,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)) { @@ -1046,8 +1045,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)) { @@ -1056,8 +1055,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)) { @@ -1067,12 +1066,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 @@ -1165,8 +1164,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)) { @@ -1201,8 +1200,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)) { @@ -1211,8 +1210,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)) { @@ -1222,12 +1221,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 @@ -1540,8 +1539,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)) { @@ -1581,8 +1580,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)) { @@ -1591,8 +1590,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)) { @@ -1602,12 +1601,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 @@ -1710,8 +1709,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)) { @@ -1746,8 +1745,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)) { @@ -1756,8 +1755,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)) { @@ -1767,12 +1766,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 @@ -2072,8 +2071,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)) { @@ -2113,8 +2112,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)) { @@ -2123,8 +2122,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)) { @@ -2134,12 +2133,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 @@ -2207,8 +2206,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)) { @@ -2241,8 +2240,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)) { @@ -2251,8 +2250,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)) { @@ -2262,12 +2261,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 @@ -2554,8 +2553,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)) { @@ -2603,8 +2602,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)) { @@ -2613,8 +2612,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)) { @@ -2624,12 +2623,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 @@ -2768,8 +2767,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)) { @@ -2809,8 +2808,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)) { @@ -2819,8 +2818,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)) { @@ -2830,12 +2829,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 @@ -3250,8 +3249,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)) { @@ -3301,8 +3300,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)) { @@ -3311,8 +3310,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)) { @@ -3322,12 +3321,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 @@ -3454,8 +3453,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)) { @@ -3502,8 +3501,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)) { @@ -3512,8 +3511,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)) { @@ -3523,12 +3522,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 @@ -3912,7 +3911,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)) { @@ -3942,10 +3941,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, @@ -3976,10 +3975,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)) { @@ -5109,12 +5109,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) { @@ -5131,7 +5125,6 @@ idbl2str (double f, char *a, int radix) } else dpt = 1; -#endif do { @@ -5153,7 +5146,6 @@ idbl2str (double f, char *a, int radix) if (dpt > 0) { -#ifndef ENGNOT if ((dpt > 4) && (exp > 6)) { d = (a[0] == '-' ? 2 : 1); @@ -5163,7 +5155,6 @@ idbl2str (double f, char *a, int radix) efmt = 1; } else -#endif { while (--dpt) a[ch++] = '0'; @@ -6186,7 +6177,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)) { @@ -6221,7 +6213,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)) { @@ -6259,7 +6252,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)) { @@ -6297,7 +6291,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)) { @@ -6331,10 +6326,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); } @@ -6393,7 +6390,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)) { @@ -6421,7 +6419,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)) { @@ -6449,7 +6448,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)) { @@ -6482,10 +6482,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); } @@ -6514,9 +6516,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); } @@ -6548,9 +6550,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 @@ -6584,9 +6586,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 @@ -6613,7 +6615,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 @@ -6637,7 +6639,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 @@ -6661,7 +6663,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 @@ -6695,11 +6697,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)) @@ -6738,7 +6740,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)) { @@ -6768,7 +6770,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)) { @@ -6823,7 +6825,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)) { @@ -6846,10 +6848,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); } @@ -6876,11 +6878,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)) @@ -6909,7 +6911,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)) { @@ -6939,7 +6941,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)) { @@ -6983,7 +6985,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)) { @@ -7006,10 +7008,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); } @@ -7038,7 +7040,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))) @@ -7071,7 +7073,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)) @@ -7136,7 +7138,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)) { @@ -7156,7 +7158,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)) { @@ -7180,7 +7182,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)) { @@ -7203,10 +7205,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); } @@ -7246,7 +7248,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)) { @@ -7269,7 +7271,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))) @@ -7356,7 +7358,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)) { @@ -7420,7 +7422,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)) { @@ -7440,7 +7443,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)) { @@ -7464,7 +7467,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)) { @@ -7488,10 +7491,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 @@ -7534,7 +7537,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))) @@ -7567,7 +7570,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: /* @@ -7612,7 +7615,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)) { @@ -7647,7 +7650,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)) { @@ -7670,7 +7673,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)) { @@ -7703,7 +7706,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)) { @@ -7728,10 +7731,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)) \ @@ -7795,7 +7798,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); @@ -7849,7 +7852,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))) @@ -7923,7 +7926,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)) { @@ -8022,7 +8025,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)) { @@ -8061,7 +8064,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)) { @@ -8119,7 +8122,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)) { @@ -8158,10 +8161,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 @@ -8238,7 +8241,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 @@ -8258,8 +8261,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 @@ -8276,7 +8279,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 @@ -8293,7 +8296,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 @@ -8332,9 +8335,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 @@ -8361,7 +8364,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 @@ -8382,7 +8385,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 @@ -8407,7 +8410,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 @@ -8428,7 +8431,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 @@ -8449,7 +8452,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 @@ -8474,7 +8477,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 @@ -8502,7 +8505,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 @@ -8532,7 +8535,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 @@ -8559,17 +8562,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 @@ -8587,7 +8590,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 @@ -8605,7 +8608,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 @@ -8623,7 +8626,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 @@ -8724,7 +8727,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 @@ -8739,7 +8742,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 @@ -8755,7 +8758,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 @@ -8772,7 +8775,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 @@ -8814,7 +8818,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 @@ -8860,7 +8865,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 @@ -8879,7 +8884,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 @@ -8900,7 +8906,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); @@ -9288,46 +9295,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) { @@ -9477,7 +9444,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 @@ -9524,7 +9491,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 @@ -9552,7 +9519,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 @@ -9657,7 +9624,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/objcodes.c b/libguile/objcodes.c index 526751acc..a4657befb 100644 --- a/libguile/objcodes.c +++ b/libguile/objcodes.c @@ -308,17 +308,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_malloc (len); - memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len); - - return scm_c_take_bytevector (s8vector, len); + return scm_c_take_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode), + len, objcode); } #undef FUNC_NAME diff --git a/libguile/ports.c b/libguile/ports.c index 6bb96103c..a4d3bd847 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -621,29 +621,6 @@ scm_new_port_table_entry (scm_t_bits tag) } #undef FUNC_NAME -#if SCM_ENABLE_DEPRECATED==1 -scm_t_port * -scm_add_to_port_table (SCM port) -{ - 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; -} -#endif - - /* Remove a port from the table and destroy it. */ static void diff --git a/libguile/ports.h b/libguile/ports.h index 6a669b660..80da9a02f 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -316,10 +316,6 @@ SCM_API SCM scm_void_port (char * mode_str); SCM_API SCM scm_sys_make_void_port (SCM mode); 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); diff --git a/libguile/print.c b/libguile/print.c index 4afd12c92..31e17f17b 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -529,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 { diff --git a/libguile/procprop.c b/libguile/procprop.c index c3fb90e37..ac2fa12a8 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -22,13 +22,9 @@ # 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" @@ -43,9 +39,6 @@ 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; @@ -123,10 +116,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 @@ -138,11 +127,6 @@ 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); @@ -158,13 +142,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 @@ -179,11 +156,6 @@ 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); if (scm_is_false (props)) diff --git a/libguile/procprop.h b/libguile/procprop.h index c8c156a25..38d692221 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..0018dc9a8 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -146,14 +146,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/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 6eff97d5b..bf146ef15 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -618,7 +618,8 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, c_len = (unsigned) c_total; } - result = scm_c_take_bytevector ((signed char *) c_bv, c_len); + result = scm_c_take_bytevector ((signed char *) c_bv, c_len, + SCM_BOOL_F); } return result; @@ -677,7 +678,8 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, c_len = (unsigned) c_total; } - result = scm_c_take_bytevector ((signed char *) c_bv, c_len); + result = scm_c_take_bytevector ((signed char *) c_bv, c_len, + SCM_BOOL_F); } return result; @@ -919,7 +921,7 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure, bop_buffer_init (buf); if (result_buf.len == 0) - bv = scm_c_take_bytevector (NULL, 0); + bv = scm_c_take_bytevector (NULL, 0, SCM_BOOL_F); else { if (result_buf.total_len > result_buf.len) @@ -930,7 +932,7 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure, SCM_GC_BOP); bv = scm_c_take_bytevector ((signed char *) result_buf.buffer, - result_buf.len); + result_buf.len, SCM_BOOL_F); } return bv; diff --git a/libguile/read.c b/libguile/read.c index 4d22ead8a..6e7804dd8 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1335,29 +1335,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': diff --git a/libguile/smob.c b/libguile/smob.c index c414913fc..ef3f56459 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -475,8 +475,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) @@ -565,28 +565,10 @@ 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); @@ -602,6 +584,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 = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind)); + else + ret = PTR2SCM (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 (SCM2PTR (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 = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind)); + else + ret = PTR2SCM (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 (SCM2PTR (ret), + finalize_smob, NULL, + &prev_finalizer, &prev_finalizer_data); + } + + return ret; +} + void scm_smob_prehistory () diff --git a/libguile/smob.h b/libguile/smob.h index 6a7ceeae6..1bcece68d 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_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) + +/* 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/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/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..7b9b4c428 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) { 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 0d379ff68..e54c27d32 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1489,7 +1489,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding, buf = scm_gc_malloc_pointerless (len, "bytevector"); memcpy (buf, str, len); - bv = scm_c_take_bytevector (buf, len); + bv = scm_c_take_bytevector (buf, len, SCM_BOOL_F); scm_decoding_error (__func__, errno, "input locale conversion error", bv); @@ -2122,66 +2122,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/tags.h b/libguile/tags.h index 26ec16425..c03f43dfe 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 @@ -61,7 +61,6 @@ /* For dealing with the bit level representation of scheme objects we define * scm_t_bits: */ - typedef scm_t_intptr scm_t_signed_bits; typedef scm_t_uintptr scm_t_bits; @@ -70,47 +69,28 @@ typedef scm_t_uintptr scm_t_bits; #define SCM_T_BITS_MAX SCM_T_UINTPTR_MAX -/* But as external interface, we define SCM, which may, according to the - * desired level of type checking, be defined in several ways: - */ -#if (SCM_DEBUG_TYPING_STRICTNESS == 2) -typedef union SCM { struct { scm_t_bits n; } n; } SCM; -# define SCM_UNPACK(x) ((x).n.n) -# define SCM_PACK(x) ((SCM) { { (scm_t_bits) (x) } }) -#elif (SCM_DEBUG_TYPING_STRICTNESS == 1) -/* This is the default, which provides an intermediate level of compile time - * type checking while still resulting in very efficient code. +/* But as external interface, we pack the bits in a union. This makes + * the compiler treat SCM values as a disjoint type, allowing the + * detection of many common errors. */ - typedef struct scm_unused_struct { char scm_unused_field; } *SCM; - -/* - The 0?: constructions makes sure that the code is never executed, - and that there is no performance hit. However, the alternative is - compiled, and does generate a warning when used with the wrong - pointer type. - - The Tru64 and ia64-hp-hpux11.23 compilers fail on `case (0?0=0:x)' - statements, so for them type-checking is disabled. */ -#if defined __DECC || defined __HP_cc -# define SCM_UNPACK(x) ((scm_t_bits) (x)) -#else -# define SCM_UNPACK(x) ((scm_t_bits) (0? (*(SCM*)0=(x)): x)) -#endif +union SCM +{ + scm_t_bits n; +}; -/* - There is no typechecking on SCM_PACK, since all kinds of types - (unsigned long, void*) go in SCM_PACK +#ifndef SCM_USING_PREHISTORIC_COMPILER +/* With GCC at least, wrapping the bits in a union provides no + * performance penalty. */ -# define SCM_PACK(x) ((SCM) (x)) - +typedef union SCM SCM; +#define SCM_UNPACK(x) ((x).n) +#define SCM_PACK(x) ((SCM) { (scm_t_bits) (x) }) #else -/* This should be used as a fall back solution for machines on which casting - * to a pointer may lead to loss of bit information, e. g. in the three least - * significant bits. +/* But we do provide an escape valve for less capable compilers. */ - typedef scm_t_bits SCM; -# define SCM_UNPACK(x) (x) -# define SCM_PACK(x) ((SCM) (x)) +typedef scm_t_bits SCM; +#define SCM_UNPACK(x) (x) +#define SCM_PACK(x) ((SCM) (x)) #endif @@ -663,13 +643,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 dba5d16f1..9a9392057 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -831,7 +831,7 @@ scm_init_guile () else { fprintf (stderr, "Failed to get stack base for current thread.\n"); - exit (1); + exit (EXIT_FAILURE); } } @@ -1597,7 +1597,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, } t->block_asyncs--; - scm_async_click (); + scm_async_tick (); scm_remember_upto_here_2 (cond, mutex); diff --git a/libguile/threads.h b/libguile/threads.h index edecad819..be760dd03 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..4b3c75e9d 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -329,9 +329,9 @@ scm_exit_status (SCM args) if (scm_is_integer (cqa)) return (scm_to_int (cqa)); else if (scm_is_false (cqa)) - return 1; + return EXIT_FAILURE; } - return 0; + return EXIT_SUCCESS; } diff --git a/libguile/vectors.c b/libguile/vectors.c index 2805278f0..e43fa0e0d 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -123,7 +123,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 @@ -241,7 +241,8 @@ scm_c_vector_ref (SCM v, size_t k) 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); @@ -307,8 +308,10 @@ scm_c_vector_set_x (SCM v, size_t k, SCM obj) 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"); } diff --git a/libguile/vm.c b/libguile/vm.c index b9d613a96..8d1c37570 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -390,7 +390,8 @@ really_make_boot_program (long nargs) bp->metalen = 0; u8vec = scm_c_take_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_objcode (u8vec), SCM_BOOL_F, SCM_BOOL_F); SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT); 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 1d1452109..7c9e3c5eb 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2065,33 +2065,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} @@ -3174,15 +3147,6 @@ module '(ice-9 q) '(make-q q-length))}." (process-use-modules (list quoted-args ...)) *unspecified*)))))) -(define-syntax use-syntax - (syntax-rules () - ((_ 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 define-private diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index f4ae2e365..ca1beec30 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -16,851 +16,5 @@ ;;;; (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 - $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)) + #:export ()) - -;;;; 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 ($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))))))) diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index 30a373a7a..e938061a3 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 @@ -381,14 +381,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 2a444a086..9270a6947 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -3,1520 +3,1525 @@ (letrec* ((#{make-void 203}# - (lambda (#{src 761}#) + (lambda (#{src 765}#) (make-struct/no-tail (vector-ref %expanded-vtables 0) - #{src 761}#))) + #{src 765}#))) (#{make-const 205}# - (lambda (#{src 763}# #{exp 764}#) + (lambda (#{src 767}# #{exp 768}#) (make-struct/no-tail (vector-ref %expanded-vtables 1) - #{src 763}# - #{exp 764}#))) + #{src 767}# + #{exp 768}#))) + (#{make-primitive-ref 207}# + (lambda (#{src 771}# #{name 772}#) + (make-struct/no-tail + (vector-ref %expanded-vtables 2) + #{src 771}# + #{name 772}#))) (#{make-lexical-ref 209}# - (lambda (#{src 771}# #{name 772}# #{gensym 773}#) + (lambda (#{src 775}# #{name 776}# #{gensym 777}#) (make-struct/no-tail (vector-ref %expanded-vtables 3) - #{src 771}# - #{name 772}# - #{gensym 773}#))) + #{src 775}# + #{name 776}# + #{gensym 777}#))) (#{make-lexical-set 211}# - (lambda (#{src 777}# - #{name 778}# - #{gensym 779}# - #{exp 780}#) + (lambda (#{src 781}# + #{name 782}# + #{gensym 783}# + #{exp 784}#) (make-struct/no-tail (vector-ref %expanded-vtables 4) - #{src 777}# - #{name 778}# - #{gensym 779}# - #{exp 780}#))) + #{src 781}# + #{name 782}# + #{gensym 783}# + #{exp 784}#))) (#{make-module-ref 213}# - (lambda (#{src 785}# - #{mod 786}# - #{name 787}# - #{public? 788}#) + (lambda (#{src 789}# + #{mod 790}# + #{name 791}# + #{public? 792}#) (make-struct/no-tail (vector-ref %expanded-vtables 5) - #{src 785}# - #{mod 786}# - #{name 787}# - #{public? 788}#))) + #{src 789}# + #{mod 790}# + #{name 791}# + #{public? 792}#))) (#{make-module-set 215}# - (lambda (#{src 793}# - #{mod 794}# - #{name 795}# - #{public? 796}# - #{exp 797}#) + (lambda (#{src 797}# + #{mod 798}# + #{name 799}# + #{public? 800}# + #{exp 801}#) (make-struct/no-tail (vector-ref %expanded-vtables 6) - #{src 793}# - #{mod 794}# - #{name 795}# - #{public? 796}# - #{exp 797}#))) + #{src 797}# + #{mod 798}# + #{name 799}# + #{public? 800}# + #{exp 801}#))) (#{make-toplevel-ref 217}# - (lambda (#{src 803}# #{name 804}#) + (lambda (#{src 807}# #{name 808}#) (make-struct/no-tail (vector-ref %expanded-vtables 7) - #{src 803}# - #{name 804}#))) + #{src 807}# + #{name 808}#))) (#{make-toplevel-set 219}# - (lambda (#{src 807}# #{name 808}# #{exp 809}#) + (lambda (#{src 811}# #{name 812}# #{exp 813}#) (make-struct/no-tail (vector-ref %expanded-vtables 8) - #{src 807}# - #{name 808}# - #{exp 809}#))) + #{src 811}# + #{name 812}# + #{exp 813}#))) (#{make-toplevel-define 221}# - (lambda (#{src 813}# #{name 814}# #{exp 815}#) + (lambda (#{src 817}# #{name 818}# #{exp 819}#) (make-struct/no-tail (vector-ref %expanded-vtables 9) - #{src 813}# - #{name 814}# - #{exp 815}#))) + #{src 817}# + #{name 818}# + #{exp 819}#))) (#{make-conditional 223}# - (lambda (#{src 819}# - #{test 820}# - #{consequent 821}# - #{alternate 822}#) + (lambda (#{src 823}# + #{test 824}# + #{consequent 825}# + #{alternate 826}#) (make-struct/no-tail (vector-ref %expanded-vtables 10) - #{src 819}# - #{test 820}# - #{consequent 821}# - #{alternate 822}#))) - (#{make-application 225}# - (lambda (#{src 827}# #{proc 828}# #{args 829}#) + #{src 823}# + #{test 824}# + #{consequent 825}# + #{alternate 826}#))) + (#{make-call 225}# + (lambda (#{src 831}# #{proc 832}# #{args 833}#) (make-struct/no-tail (vector-ref %expanded-vtables 11) - #{src 827}# - #{proc 828}# - #{args 829}#))) - (#{make-sequence 227}# - (lambda (#{src 833}# #{exps 834}#) + #{src 831}# + #{proc 832}# + #{args 833}#))) + (#{make-primcall 227}# + (lambda (#{src 837}# #{name 838}# #{args 839}#) (make-struct/no-tail (vector-ref %expanded-vtables 12) - #{src 833}# - #{exps 834}#))) - (#{make-lambda 229}# - (lambda (#{src 837}# #{meta 838}# #{body 839}#) + #{src 837}# + #{name 838}# + #{args 839}#))) + (#{make-sequence 229}# + (lambda (#{src 843}# head tail) (make-struct/no-tail (vector-ref %expanded-vtables 13) - #{src 837}# - #{meta 838}# - #{body 839}#))) - (#{make-lambda-case 231}# - (lambda (#{src 843}# - #{req 844}# - #{opt 845}# - #{rest 846}# - #{kw 847}# - #{inits 848}# - #{gensyms 849}# - #{body 850}# - #{alternate 851}#) + #{src 843}# + head tail))) + (#{make-lambda 231}# + (lambda (#{src 847}# #{meta 848}# #{body 849}#) (make-struct/no-tail (vector-ref %expanded-vtables 14) - #{src 843}# - #{req 844}# - #{opt 845}# - #{rest 846}# - #{kw 847}# - #{inits 848}# - #{gensyms 849}# - #{body 850}# - #{alternate 851}#))) - (#{make-let 233}# - (lambda (#{src 861}# - #{names 862}# - #{gensyms 863}# - #{vals 864}# - #{body 865}#) + #{src 847}# + #{meta 848}# + #{body 849}#))) + (#{make-lambda-case 233}# + (lambda (#{src 853}# + #{req 854}# + #{opt 855}# + #{rest 856}# + #{kw 857}# + #{inits 858}# + #{gensyms 859}# + #{body 860}# + #{alternate 861}#) (make-struct/no-tail (vector-ref %expanded-vtables 15) - #{src 861}# - #{names 862}# - #{gensyms 863}# - #{vals 864}# - #{body 865}#))) - (#{make-letrec 235}# + #{src 853}# + #{req 854}# + #{opt 855}# + #{rest 856}# + #{kw 857}# + #{inits 858}# + #{gensyms 859}# + #{body 860}# + #{alternate 861}#))) + (#{make-let 235}# (lambda (#{src 871}# - #{in-order? 872}# - #{names 873}# - #{gensyms 874}# - #{vals 875}# - #{body 876}#) + #{names 872}# + #{gensyms 873}# + #{vals 874}# + #{body 875}#) (make-struct/no-tail (vector-ref %expanded-vtables 16) #{src 871}# - #{in-order? 872}# - #{names 873}# - #{gensyms 874}# - #{vals 875}# - #{body 876}#))) - (#{make-dynlet 237}# - (lambda (#{src 883}# - #{fluids 884}# + #{names 872}# + #{gensyms 873}# + #{vals 874}# + #{body 875}#))) + (#{make-letrec 237}# + (lambda (#{src 881}# + #{in-order? 882}# + #{names 883}# + #{gensyms 884}# #{vals 885}# #{body 886}#) (make-struct/no-tail (vector-ref %expanded-vtables 17) - #{src 883}# - #{fluids 884}# + #{src 881}# + #{in-order? 882}# + #{names 883}# + #{gensyms 884}# #{vals 885}# #{body 886}#))) - (#{lambda? 240}# - (lambda (#{x 891}#) - (if (struct? #{x 891}#) - (eq? (struct-vtable #{x 891}#) - (vector-ref %expanded-vtables 13)) + (#{make-dynlet 239}# + (lambda (#{src 893}# + #{fluids 894}# + #{vals 895}# + #{body 896}#) + (make-struct/no-tail + (vector-ref %expanded-vtables 18) + #{src 893}# + #{fluids 894}# + #{vals 895}# + #{body 896}#))) + (#{lambda? 242}# + (lambda (#{x 901}#) + (if (struct? #{x 901}#) + (eq? (struct-vtable #{x 901}#) + (vector-ref %expanded-vtables 14)) #f))) - (#{lambda-meta 242}# - (lambda (#{x 895}#) (struct-ref #{x 895}# 1))) - (#{set-lambda-meta! 244}# - (lambda (#{x 897}# #{v 898}#) - (struct-set! #{x 897}# 1 #{v 898}#))) - (#{top-level-eval-hook 250}# - (lambda (#{x 901}# #{mod 902}#) - (primitive-eval #{x 901}#))) - (#{local-eval-hook 252}# - (lambda (#{x 905}# #{mod 906}#) - (primitive-eval #{x 905}#))) - (#{put-global-definition-hook 255}# - (lambda (#{symbol 909}# #{type 910}# #{val 911}#) + (#{lambda-meta 244}# + (lambda (#{x 905}#) (struct-ref #{x 905}# 1))) + (#{set-lambda-meta! 246}# + (lambda (#{x 907}# #{v 908}#) + (struct-set! #{x 907}# 1 #{v 908}#))) + (#{top-level-eval-hook 252}# + (lambda (#{x 911}# #{mod 912}#) + (primitive-eval #{x 911}#))) + (#{local-eval-hook 254}# + (lambda (#{x 915}# #{mod 916}#) + (primitive-eval #{x 915}#))) + (#{put-global-definition-hook 257}# + (lambda (#{symbol 919}# #{type 920}# #{val 921}#) (module-define! (current-module) - #{symbol 909}# + #{symbol 919}# (make-syntax-transformer - #{symbol 909}# - #{type 910}# - #{val 911}#)))) - (#{get-global-definition-hook 257}# - (lambda (#{symbol 915}# #{module 916}#) + #{symbol 919}# + #{type 920}# + #{val 921}#)))) + (#{get-global-definition-hook 259}# + (lambda (#{symbol 925}# #{module 926}#) (begin - (if (if (not #{module 916}#) (current-module) #f) + (if (if (not #{module 926}#) (current-module) #f) (warn "module system is booted, we should have a module" - #{symbol 915}#)) + #{symbol 925}#)) (begin - (let ((#{v 922}# (module-variable - (if #{module 916}# - (resolve-module (cdr #{module 916}#)) + (let ((#{v 932}# (module-variable + (if #{module 926}# + (resolve-module (cdr #{module 926}#)) (current-module)) - #{symbol 915}#))) - (if #{v 922}# - (if (variable-bound? #{v 922}#) + #{symbol 925}#))) + (if #{v 932}# + (if (variable-bound? #{v 932}#) (begin - (let ((#{val 927}# (variable-ref #{v 922}#))) - (if (macro? #{val 927}#) - (if (macro-type #{val 927}#) - (cons (macro-type #{val 927}#) - (macro-binding #{val 927}#)) + (let ((#{val 937}# (variable-ref #{v 932}#))) + (if (macro? #{val 937}#) + (if (macro-type #{val 937}#) + (cons (macro-type #{val 937}#) + (macro-binding #{val 937}#)) #f) #f))) #f) #f)))))) - (#{decorate-source 259}# - (lambda (#{e 931}# #{s 932}#) + (#{decorate-source 261}# + (lambda (#{e 941}# #{s 942}#) (begin - (if (if (pair? #{e 931}#) #{s 932}# #f) - (set-source-properties! #{e 931}# #{s 932}#)) - #{e 931}#))) - (#{maybe-name-value! 261}# - (lambda (#{name 937}# #{val 938}#) - (if (#{lambda? 240}# #{val 938}#) + (if (if (pair? #{e 941}#) #{s 942}# #f) + (set-source-properties! #{e 941}# #{s 942}#)) + #{e 941}#))) + (#{maybe-name-value! 263}# + (lambda (#{name 947}# #{val 948}#) + (if (#{lambda? 242}# #{val 948}#) (begin - (let ((#{meta 942}# (#{lambda-meta 242}# #{val 938}#))) - (if (not (assq 'name #{meta 942}#)) - (#{set-lambda-meta! 244}# - #{val 938}# - (cons (cons 'name #{name 937}#) #{meta 942}#)))))))) - (#{build-void 263}# - (lambda (#{source 943}#) - (#{make-void 203}# #{source 943}#))) - (#{build-application 265}# - (lambda (#{source 945}# #{fun-exp 946}# #{arg-exps 947}#) - (#{make-application 225}# - #{source 945}# - #{fun-exp 946}# - #{arg-exps 947}#))) - (#{build-conditional 267}# - (lambda (#{source 951}# - #{test-exp 952}# - #{then-exp 953}# - #{else-exp 954}#) + (let ((#{meta 952}# (#{lambda-meta 244}# #{val 948}#))) + (if (not (assq 'name #{meta 952}#)) + (#{set-lambda-meta! 246}# + #{val 948}# + (cons (cons 'name #{name 947}#) #{meta 952}#)))))))) + (#{build-void 265}# + (lambda (#{source 953}#) + (#{make-void 203}# #{source 953}#))) + (#{build-call 267}# + (lambda (#{source 955}# #{fun-exp 956}# #{arg-exps 957}#) + (#{make-call 225}# + #{source 955}# + #{fun-exp 956}# + #{arg-exps 957}#))) + (#{build-conditional 269}# + (lambda (#{source 961}# + #{test-exp 962}# + #{then-exp 963}# + #{else-exp 964}#) (#{make-conditional 223}# - #{source 951}# - #{test-exp 952}# - #{then-exp 953}# - #{else-exp 954}#))) - (#{build-dynlet 269}# - (lambda (#{source 959}# - #{fluids 960}# - #{vals 961}# - #{body 962}#) - (#{make-dynlet 237}# - #{source 959}# - #{fluids 960}# - #{vals 961}# - #{body 962}#))) - (#{build-lexical-reference 271}# - (lambda (#{type 967}# - #{source 968}# - #{name 969}# - #{var 970}#) + #{source 961}# + #{test-exp 962}# + #{then-exp 963}# + #{else-exp 964}#))) + (#{build-dynlet 271}# + (lambda (#{source 969}# + #{fluids 970}# + #{vals 971}# + #{body 972}#) + (#{make-dynlet 239}# + #{source 969}# + #{fluids 970}# + #{vals 971}# + #{body 972}#))) + (#{build-lexical-reference 273}# + (lambda (#{type 977}# + #{source 978}# + #{name 979}# + #{var 980}#) (#{make-lexical-ref 209}# - #{source 968}# - #{name 969}# - #{var 970}#))) - (#{build-lexical-assignment 273}# - (lambda (#{source 975}# - #{name 976}# - #{var 977}# - #{exp 978}#) + #{source 978}# + #{name 979}# + #{var 980}#))) + (#{build-lexical-assignment 275}# + (lambda (#{source 985}# + #{name 986}# + #{var 987}# + #{exp 988}#) (begin - (#{maybe-name-value! 261}# - #{name 976}# - #{exp 978}#) + (#{maybe-name-value! 263}# + #{name 986}# + #{exp 988}#) (#{make-lexical-set 211}# - #{source 975}# - #{name 976}# - #{var 977}# - #{exp 978}#)))) - (#{analyze-variable 275}# - (lambda (#{mod 983}# - #{var 984}# - #{modref-cont 985}# - #{bare-cont 986}#) - (if (not #{mod 983}#) - (#{bare-cont 986}# #{var 984}#) + #{source 985}# + #{name 986}# + #{var 987}# + #{exp 988}#)))) + (#{analyze-variable 277}# + (lambda (#{mod 993}# + #{var 994}# + #{modref-cont 995}# + #{bare-cont 996}#) + (if (not #{mod 993}#) + (#{bare-cont 996}# #{var 994}#) (begin - (let ((#{kind 993}# (car #{mod 983}#)) - (#{mod 994}# (cdr #{mod 983}#))) - (if (eqv? #{kind 993}# 'public) - (#{modref-cont 985}# #{mod 994}# #{var 984}# #t) - (if (eqv? #{kind 993}# 'private) + (let ((#{kind 1003}# (car #{mod 993}#)) + (#{mod 1004}# (cdr #{mod 993}#))) + (if (memv #{kind 1003}# '(public)) + (#{modref-cont 995}# #{mod 1004}# #{var 994}# #t) + (if (memv #{kind 1003}# '(private)) (if (not (equal? - #{mod 994}# + #{mod 1004}# (module-name (current-module)))) - (#{modref-cont 985}# #{mod 994}# #{var 984}# #f) - (#{bare-cont 986}# #{var 984}#)) - (if (eqv? #{kind 993}# 'bare) - (#{bare-cont 986}# #{var 984}#) - (if (eqv? #{kind 993}# 'hygiene) + (#{modref-cont 995}# #{mod 1004}# #{var 994}# #f) + (#{bare-cont 996}# #{var 994}#)) + (if (memv #{kind 1003}# '(bare)) + (#{bare-cont 996}# #{var 994}#) + (if (memv #{kind 1003}# '(hygiene)) (if (if (not (equal? - #{mod 994}# + #{mod 1004}# (module-name (current-module)))) (module-variable - (resolve-module #{mod 994}#) - #{var 984}#) + (resolve-module #{mod 1004}#) + #{var 994}#) #f) - (#{modref-cont 985}# #{mod 994}# #{var 984}# #f) - (#{bare-cont 986}# #{var 984}#)) + (#{modref-cont 995}# #{mod 1004}# #{var 994}# #f) + (#{bare-cont 996}# #{var 994}#)) (syntax-violation #f "bad module kind" - #{var 984}# - #{mod 994}#)))))))))) - (#{build-global-reference 277}# - (lambda (#{source 1002}# #{var 1003}# #{mod 1004}#) - (#{analyze-variable 275}# - #{mod 1004}# - #{var 1003}# - (lambda (#{mod 1008}# #{var 1009}# #{public? 1010}#) + #{var 994}# + #{mod 1004}#)))))))))) + (#{build-global-reference 279}# + (lambda (#{source 1012}# #{var 1013}# #{mod 1014}#) + (#{analyze-variable 277}# + #{mod 1014}# + #{var 1013}# + (lambda (#{mod 1018}# #{var 1019}# #{public? 1020}#) (#{make-module-ref 213}# - #{source 1002}# - #{mod 1008}# - #{var 1009}# - #{public? 1010}#)) - (lambda (#{var 1014}#) + #{source 1012}# + #{mod 1018}# + #{var 1019}# + #{public? 1020}#)) + (lambda (#{var 1024}#) (#{make-toplevel-ref 217}# - #{source 1002}# - #{var 1014}#))))) - (#{build-global-assignment 279}# - (lambda (#{source 1016}# - #{var 1017}# - #{exp 1018}# - #{mod 1019}#) + #{source 1012}# + #{var 1024}#))))) + (#{build-global-assignment 281}# + (lambda (#{source 1026}# + #{var 1027}# + #{exp 1028}# + #{mod 1029}#) (begin - (#{maybe-name-value! 261}# - #{var 1017}# - #{exp 1018}#) - (#{analyze-variable 275}# - #{mod 1019}# - #{var 1017}# - (lambda (#{mod 1024}# #{var 1025}# #{public? 1026}#) + (#{maybe-name-value! 263}# + #{var 1027}# + #{exp 1028}#) + (#{analyze-variable 277}# + #{mod 1029}# + #{var 1027}# + (lambda (#{mod 1034}# #{var 1035}# #{public? 1036}#) (#{make-module-set 215}# - #{source 1016}# - #{mod 1024}# - #{var 1025}# - #{public? 1026}# - #{exp 1018}#)) - (lambda (#{var 1030}#) + #{source 1026}# + #{mod 1034}# + #{var 1035}# + #{public? 1036}# + #{exp 1028}#)) + (lambda (#{var 1040}#) (#{make-toplevel-set 219}# - #{source 1016}# - #{var 1030}# - #{exp 1018}#)))))) - (#{build-global-definition 281}# - (lambda (#{source 1032}# #{var 1033}# #{exp 1034}#) + #{source 1026}# + #{var 1040}# + #{exp 1028}#)))))) + (#{build-global-definition 283}# + (lambda (#{source 1042}# #{var 1043}# #{exp 1044}#) (begin - (#{maybe-name-value! 261}# - #{var 1033}# - #{exp 1034}#) + (#{maybe-name-value! 263}# + #{var 1043}# + #{exp 1044}#) (#{make-toplevel-define 221}# - #{source 1032}# - #{var 1033}# - #{exp 1034}#)))) - (#{build-simple-lambda 283}# - (lambda (#{src 1038}# - #{req 1039}# - #{rest 1040}# - #{vars 1041}# - #{meta 1042}# - #{exp 1043}#) - (#{make-lambda 229}# - #{src 1038}# - #{meta 1042}# - (#{make-lambda-case 231}# - #{src 1038}# - #{req 1039}# + #{source 1042}# + #{var 1043}# + #{exp 1044}#)))) + (#{build-simple-lambda 285}# + (lambda (#{src 1048}# + #{req 1049}# + #{rest 1050}# + #{vars 1051}# + #{meta 1052}# + #{exp 1053}#) + (#{make-lambda 231}# + #{src 1048}# + #{meta 1052}# + (#{make-lambda-case 233}# + #{src 1048}# + #{req 1049}# #f - #{rest 1040}# + #{rest 1050}# #f '() - #{vars 1041}# - #{exp 1043}# - #f)))) - (#{build-case-lambda 285}# - (lambda (#{src 1050}# #{meta 1051}# #{body 1052}#) - (#{make-lambda 229}# - #{src 1050}# - #{meta 1051}# - #{body 1052}#))) - (#{build-lambda-case 287}# - (lambda (#{src 1056}# - #{req 1057}# - #{opt 1058}# - #{rest 1059}# - #{kw 1060}# - #{inits 1061}# - #{vars 1062}# - #{body 1063}# - #{else-case 1064}#) - (#{make-lambda-case 231}# - #{src 1056}# - #{req 1057}# - #{opt 1058}# - #{rest 1059}# - #{kw 1060}# - #{inits 1061}# - #{vars 1062}# - #{body 1063}# - #{else-case 1064}#))) - (#{build-primref 289}# - (lambda (#{src 1074}# #{name 1075}#) - (if (equal? (module-name (current-module)) '(guile)) - (#{make-toplevel-ref 217}# - #{src 1074}# - #{name 1075}#) - (#{make-module-ref 213}# - #{src 1074}# - '(guile) - #{name 1075}# + #{vars 1051}# + #{exp 1053}# #f)))) - (#{build-data 291}# - (lambda (#{src 1078}# #{exp 1079}#) - (#{make-const 205}# #{src 1078}# #{exp 1079}#))) - (#{build-sequence 293}# - (lambda (#{src 1082}# #{exps 1083}#) - (if (null? (cdr #{exps 1083}#)) - (car #{exps 1083}#) - (#{make-sequence 227}# - #{src 1082}# - #{exps 1083}#)))) - (#{build-let 295}# - (lambda (#{src 1086}# - #{ids 1087}# - #{vars 1088}# - #{val-exps 1089}# - #{body-exp 1090}#) + (#{build-case-lambda 287}# + (lambda (#{src 1060}# #{meta 1061}# #{body 1062}#) + (#{make-lambda 231}# + #{src 1060}# + #{meta 1061}# + #{body 1062}#))) + (#{build-lambda-case 289}# + (lambda (#{src 1066}# + #{req 1067}# + #{opt 1068}# + #{rest 1069}# + #{kw 1070}# + #{inits 1071}# + #{vars 1072}# + #{body 1073}# + #{else-case 1074}#) + (#{make-lambda-case 233}# + #{src 1066}# + #{req 1067}# + #{opt 1068}# + #{rest 1069}# + #{kw 1070}# + #{inits 1071}# + #{vars 1072}# + #{body 1073}# + #{else-case 1074}#))) + (#{build-primcall 291}# + (lambda (#{src 1084}# #{name 1085}# #{args 1086}#) + (#{make-primcall 227}# + #{src 1084}# + #{name 1085}# + #{args 1086}#))) + (#{build-primref 293}# + (lambda (#{src 1090}# #{name 1091}#) + (#{make-primitive-ref 207}# + #{src 1090}# + #{name 1091}#))) + (#{build-data 295}# + (lambda (#{src 1094}# #{exp 1095}#) + (#{make-const 205}# #{src 1094}# #{exp 1095}#))) + (#{build-sequence 297}# + (lambda (#{src 1098}# #{exps 1099}#) + (if (null? (cdr #{exps 1099}#)) + (car #{exps 1099}#) + (#{make-sequence 229}# + #f (car #{exps 1099}#) + (#{build-sequence 297}# #f (cdr #{exps 1099}#)))))) + (#{build-let 299}# + (lambda (#{src 1102}# + #{ids 1103}# + #{vars 1104}# + #{val-exps 1105}# + #{body-exp 1106}#) (begin (for-each - #{maybe-name-value! 261}# - #{ids 1087}# - #{val-exps 1089}#) - (if (null? #{vars 1088}#) - #{body-exp 1090}# - (#{make-let 233}# - #{src 1086}# - #{ids 1087}# - #{vars 1088}# - #{val-exps 1089}# - #{body-exp 1090}#))))) - (#{build-named-let 297}# - (lambda (#{src 1096}# - #{ids 1097}# - #{vars 1098}# - #{val-exps 1099}# - #{body-exp 1100}#) + #{maybe-name-value! 263}# + #{ids 1103}# + #{val-exps 1105}#) + (if (null? #{vars 1104}#) + #{body-exp 1106}# + (#{make-let 235}# + #{src 1102}# + #{ids 1103}# + #{vars 1104}# + #{val-exps 1105}# + #{body-exp 1106}#))))) + (#{build-named-let 301}# + (lambda (#{src 1112}# + #{ids 1113}# + #{vars 1114}# + #{val-exps 1115}# + #{body-exp 1116}#) (begin - (let ((#{f 1110}# (car #{vars 1098}#)) - (#{f-name 1111}# (car #{ids 1097}#)) - (#{vars 1112}# (cdr #{vars 1098}#)) - (#{ids 1113}# (cdr #{ids 1097}#))) + (let ((#{f 1126}# (car #{vars 1114}#)) + (#{f-name 1127}# (car #{ids 1113}#)) + (#{vars 1128}# (cdr #{vars 1114}#)) + (#{ids 1129}# (cdr #{ids 1113}#))) (begin - (let ((#{proc 1115}# - (#{build-simple-lambda 283}# - #{src 1096}# - #{ids 1113}# + (let ((#{proc 1131}# + (#{build-simple-lambda 285}# + #{src 1112}# + #{ids 1129}# #f - #{vars 1112}# + #{vars 1128}# '() - #{body-exp 1100}#))) + #{body-exp 1116}#))) (begin - (#{maybe-name-value! 261}# - #{f-name 1111}# - #{proc 1115}#) + (#{maybe-name-value! 263}# + #{f-name 1127}# + #{proc 1131}#) (for-each - #{maybe-name-value! 261}# - #{ids 1113}# - #{val-exps 1099}#) - (#{make-letrec 235}# - #{src 1096}# + #{maybe-name-value! 263}# + #{ids 1129}# + #{val-exps 1115}#) + (#{make-letrec 237}# + #{src 1112}# #f - (list #{f-name 1111}#) - (list #{f 1110}#) - (list #{proc 1115}#) - (#{build-application 265}# - #{src 1096}# - (#{build-lexical-reference 271}# + (list #{f-name 1127}#) + (list #{f 1126}#) + (list #{proc 1131}#) + (#{build-call 267}# + #{src 1112}# + (#{build-lexical-reference 273}# 'fun - #{src 1096}# - #{f-name 1111}# - #{f 1110}#) - #{val-exps 1099}#))))))))) - (#{build-letrec 299}# - (lambda (#{src 1116}# - #{in-order? 1117}# - #{ids 1118}# - #{vars 1119}# - #{val-exps 1120}# - #{body-exp 1121}#) - (if (null? #{vars 1119}#) - #{body-exp 1121}# + #{src 1112}# + #{f-name 1127}# + #{f 1126}#) + #{val-exps 1115}#))))))))) + (#{build-letrec 303}# + (lambda (#{src 1132}# + #{in-order? 1133}# + #{ids 1134}# + #{vars 1135}# + #{val-exps 1136}# + #{body-exp 1137}#) + (if (null? #{vars 1135}#) + #{body-exp 1137}# (begin (for-each - #{maybe-name-value! 261}# - #{ids 1118}# - #{val-exps 1120}#) - (#{make-letrec 235}# - #{src 1116}# - #{in-order? 1117}# - #{ids 1118}# - #{vars 1119}# - #{val-exps 1120}# - #{body-exp 1121}#))))) - (#{make-syntax-object 303}# - (lambda (#{expression 1128}# - #{wrap 1129}# - #{module 1130}#) + #{maybe-name-value! 263}# + #{ids 1134}# + #{val-exps 1136}#) + (#{make-letrec 237}# + #{src 1132}# + #{in-order? 1133}# + #{ids 1134}# + #{vars 1135}# + #{val-exps 1136}# + #{body-exp 1137}#))))) + (#{make-syntax-object 307}# + (lambda (#{expression 1144}# + #{wrap 1145}# + #{module 1146}#) (vector 'syntax-object - #{expression 1128}# - #{wrap 1129}# - #{module 1130}#))) - (#{syntax-object? 305}# - (lambda (#{x 1134}#) - (if (vector? #{x 1134}#) - (if (= (vector-length #{x 1134}#) 4) - (eq? (vector-ref #{x 1134}# 0) 'syntax-object) + #{expression 1144}# + #{wrap 1145}# + #{module 1146}#))) + (#{syntax-object? 309}# + (lambda (#{x 1150}#) + (if (vector? #{x 1150}#) + (if (= (vector-length #{x 1150}#) 4) + (eq? (vector-ref #{x 1150}# 0) 'syntax-object) #f) #f))) - (#{syntax-object-expression 307}# - (lambda (#{x 1139}#) (vector-ref #{x 1139}# 1))) - (#{syntax-object-wrap 309}# - (lambda (#{x 1141}#) (vector-ref #{x 1141}# 2))) - (#{syntax-object-module 311}# - (lambda (#{x 1143}#) (vector-ref #{x 1143}# 3))) - (#{source-annotation 320}# - (lambda (#{x 1157}#) - (if (#{syntax-object? 305}# #{x 1157}#) - (#{source-annotation 320}# - (#{syntax-object-expression 307}# #{x 1157}#)) - (if (pair? #{x 1157}#) + (#{syntax-object-expression 311}# + (lambda (#{x 1155}#) (vector-ref #{x 1155}# 1))) + (#{syntax-object-wrap 313}# + (lambda (#{x 1157}#) (vector-ref #{x 1157}# 2))) + (#{syntax-object-module 315}# + (lambda (#{x 1159}#) (vector-ref #{x 1159}# 3))) + (#{source-annotation 324}# + (lambda (#{x 1173}#) + (if (#{syntax-object? 309}# #{x 1173}#) + (#{source-annotation 324}# + (#{syntax-object-expression 311}# #{x 1173}#)) + (if (pair? #{x 1173}#) (begin - (let ((#{props 1164}# (source-properties #{x 1157}#))) - (if (pair? #{props 1164}#) #{props 1164}# #f))) + (let ((#{props 1180}# (source-properties #{x 1173}#))) + (if (pair? #{props 1180}#) #{props 1180}# #f))) #f)))) - (#{extend-env 327}# - (lambda (#{labels 1166}# #{bindings 1167}# #{r 1168}#) - (if (null? #{labels 1166}#) - #{r 1168}# - (#{extend-env 327}# - (cdr #{labels 1166}#) - (cdr #{bindings 1167}#) - (cons (cons (car #{labels 1166}#) - (car #{bindings 1167}#)) - #{r 1168}#))))) - (#{extend-var-env 329}# - (lambda (#{labels 1172}# #{vars 1173}# #{r 1174}#) - (if (null? #{labels 1172}#) - #{r 1174}# - (#{extend-var-env 329}# - (cdr #{labels 1172}#) - (cdr #{vars 1173}#) - (cons (cons (car #{labels 1172}#) - (cons 'lexical (car #{vars 1173}#))) - #{r 1174}#))))) - (#{macros-only-env 331}# - (lambda (#{r 1179}#) - (if (null? #{r 1179}#) + (#{extend-env 331}# + (lambda (#{labels 1182}# #{bindings 1183}# #{r 1184}#) + (if (null? #{labels 1182}#) + #{r 1184}# + (#{extend-env 331}# + (cdr #{labels 1182}#) + (cdr #{bindings 1183}#) + (cons (cons (car #{labels 1182}#) + (car #{bindings 1183}#)) + #{r 1184}#))))) + (#{extend-var-env 333}# + (lambda (#{labels 1188}# #{vars 1189}# #{r 1190}#) + (if (null? #{labels 1188}#) + #{r 1190}# + (#{extend-var-env 333}# + (cdr #{labels 1188}#) + (cdr #{vars 1189}#) + (cons (cons (car #{labels 1188}#) + (cons 'lexical (car #{vars 1189}#))) + #{r 1190}#))))) + (#{macros-only-env 335}# + (lambda (#{r 1195}#) + (if (null? #{r 1195}#) '() (begin - (let ((#{a 1182}# (car #{r 1179}#))) - (if (eq? (car (cdr #{a 1182}#)) 'macro) - (cons #{a 1182}# - (#{macros-only-env 331}# (cdr #{r 1179}#))) - (#{macros-only-env 331}# (cdr #{r 1179}#)))))))) - (#{lookup 333}# - (lambda (#{x 1183}# #{r 1184}# #{mod 1185}#) + (let ((#{a 1198}# (car #{r 1195}#))) + (if (eq? (car (cdr #{a 1198}#)) 'macro) + (cons #{a 1198}# + (#{macros-only-env 335}# (cdr #{r 1195}#))) + (#{macros-only-env 335}# (cdr #{r 1195}#)))))))) + (#{lookup 337}# + (lambda (#{x 1199}# #{r 1200}# #{mod 1201}#) (begin - (let ((#{t 1191}# (assq #{x 1183}# #{r 1184}#))) - (if #{t 1191}# - (cdr #{t 1191}#) - (if (symbol? #{x 1183}#) + (let ((#{t 1207}# (assq #{x 1199}# #{r 1200}#))) + (if #{t 1207}# + (cdr #{t 1207}#) + (if (symbol? #{x 1199}#) (begin - (let ((#{t 1197}# - (#{get-global-definition-hook 257}# - #{x 1183}# - #{mod 1185}#))) - (if #{t 1197}# #{t 1197}# '(global)))) + (let ((#{t 1213}# + (#{get-global-definition-hook 259}# + #{x 1199}# + #{mod 1201}#))) + (if #{t 1213}# #{t 1213}# '(global)))) '(displaced-lexical))))))) - (#{global-extend 335}# - (lambda (#{type 1202}# #{sym 1203}# #{val 1204}#) - (#{put-global-definition-hook 255}# - #{sym 1203}# - #{type 1202}# - #{val 1204}#))) - (#{nonsymbol-id? 337}# - (lambda (#{x 1208}#) - (if (#{syntax-object? 305}# #{x 1208}#) + (#{global-extend 339}# + (lambda (#{type 1218}# #{sym 1219}# #{val 1220}#) + (#{put-global-definition-hook 257}# + #{sym 1219}# + #{type 1218}# + #{val 1220}#))) + (#{nonsymbol-id? 341}# + (lambda (#{x 1224}#) + (if (#{syntax-object? 309}# #{x 1224}#) (symbol? - (#{syntax-object-expression 307}# #{x 1208}#)) + (#{syntax-object-expression 311}# #{x 1224}#)) #f))) - (#{id? 339}# - (lambda (#{x 1212}#) - (if (symbol? #{x 1212}#) + (#{id? 343}# + (lambda (#{x 1228}#) + (if (symbol? #{x 1228}#) #t - (if (#{syntax-object? 305}# #{x 1212}#) + (if (#{syntax-object? 309}# #{x 1228}#) (symbol? - (#{syntax-object-expression 307}# #{x 1212}#)) + (#{syntax-object-expression 311}# #{x 1228}#)) #f)))) - (#{id-sym-name&marks 342}# - (lambda (#{x 1219}# #{w 1220}#) - (if (#{syntax-object? 305}# #{x 1219}#) + (#{id-sym-name&marks 346}# + (lambda (#{x 1235}# #{w 1236}#) + (if (#{syntax-object? 309}# #{x 1235}#) (values - (#{syntax-object-expression 307}# #{x 1219}#) - (#{join-marks 389}# - (car #{w 1220}#) - (car (#{syntax-object-wrap 309}# #{x 1219}#)))) - (values #{x 1219}# (car #{w 1220}#))))) - (#{gen-label 352}# + (#{syntax-object-expression 311}# #{x 1235}#) + (#{join-marks 393}# + (car #{w 1236}#) + (car (#{syntax-object-wrap 313}# #{x 1235}#)))) + (values #{x 1235}# (car #{w 1236}#))))) + (#{gen-label 356}# (lambda () (symbol->string (gensym "i")))) - (#{gen-labels 354}# - (lambda (#{ls 1226}#) - (if (null? #{ls 1226}#) + (#{gen-labels 358}# + (lambda (#{ls 1242}#) + (if (null? #{ls 1242}#) '() - (cons (#{gen-label 352}#) - (#{gen-labels 354}# (cdr #{ls 1226}#)))))) - (#{make-ribcage 357}# - (lambda (#{symnames 1228}# - #{marks 1229}# - #{labels 1230}#) + (cons (#{gen-label 356}#) + (#{gen-labels 358}# (cdr #{ls 1242}#)))))) + (#{make-ribcage 361}# + (lambda (#{symnames 1244}# + #{marks 1245}# + #{labels 1246}#) (vector 'ribcage - #{symnames 1228}# - #{marks 1229}# - #{labels 1230}#))) - (#{ribcage-symnames 361}# - (lambda (#{x 1239}#) (vector-ref #{x 1239}# 1))) - (#{ribcage-marks 363}# - (lambda (#{x 1241}#) (vector-ref #{x 1241}# 2))) - (#{ribcage-labels 365}# - (lambda (#{x 1243}#) (vector-ref #{x 1243}# 3))) - (#{set-ribcage-symnames! 367}# - (lambda (#{x 1245}# #{update 1246}#) - (vector-set! #{x 1245}# 1 #{update 1246}#))) - (#{set-ribcage-marks! 369}# - (lambda (#{x 1249}# #{update 1250}#) - (vector-set! #{x 1249}# 2 #{update 1250}#))) - (#{set-ribcage-labels! 371}# - (lambda (#{x 1253}# #{update 1254}#) - (vector-set! #{x 1253}# 3 #{update 1254}#))) - (#{anti-mark 377}# - (lambda (#{w 1257}#) - (cons (cons #f (car #{w 1257}#)) - (cons 'shift (cdr #{w 1257}#))))) - (#{extend-ribcage! 381}# - (lambda (#{ribcage 1263}# #{id 1264}# #{label 1265}#) + #{symnames 1244}# + #{marks 1245}# + #{labels 1246}#))) + (#{ribcage-symnames 365}# + (lambda (#{x 1255}#) (vector-ref #{x 1255}# 1))) + (#{ribcage-marks 367}# + (lambda (#{x 1257}#) (vector-ref #{x 1257}# 2))) + (#{ribcage-labels 369}# + (lambda (#{x 1259}#) (vector-ref #{x 1259}# 3))) + (#{set-ribcage-symnames! 371}# + (lambda (#{x 1261}# #{update 1262}#) + (vector-set! #{x 1261}# 1 #{update 1262}#))) + (#{set-ribcage-marks! 373}# + (lambda (#{x 1265}# #{update 1266}#) + (vector-set! #{x 1265}# 2 #{update 1266}#))) + (#{set-ribcage-labels! 375}# + (lambda (#{x 1269}# #{update 1270}#) + (vector-set! #{x 1269}# 3 #{update 1270}#))) + (#{anti-mark 381}# + (lambda (#{w 1273}#) + (cons (cons #f (car #{w 1273}#)) + (cons 'shift (cdr #{w 1273}#))))) + (#{extend-ribcage! 385}# + (lambda (#{ribcage 1279}# #{id 1280}# #{label 1281}#) (begin - (#{set-ribcage-symnames! 367}# - #{ribcage 1263}# - (cons (#{syntax-object-expression 307}# #{id 1264}#) - (#{ribcage-symnames 361}# #{ribcage 1263}#))) - (#{set-ribcage-marks! 369}# - #{ribcage 1263}# - (cons (car (#{syntax-object-wrap 309}# #{id 1264}#)) - (#{ribcage-marks 363}# #{ribcage 1263}#))) - (#{set-ribcage-labels! 371}# - #{ribcage 1263}# - (cons #{label 1265}# - (#{ribcage-labels 365}# #{ribcage 1263}#)))))) - (#{make-binding-wrap 383}# - (lambda (#{ids 1270}# #{labels 1271}# #{w 1272}#) - (if (null? #{ids 1270}#) - #{w 1272}# - (cons (car #{w 1272}#) + (#{set-ribcage-symnames! 371}# + #{ribcage 1279}# + (cons (#{syntax-object-expression 311}# #{id 1280}#) + (#{ribcage-symnames 365}# #{ribcage 1279}#))) + (#{set-ribcage-marks! 373}# + #{ribcage 1279}# + (cons (car (#{syntax-object-wrap 313}# #{id 1280}#)) + (#{ribcage-marks 367}# #{ribcage 1279}#))) + (#{set-ribcage-labels! 375}# + #{ribcage 1279}# + (cons #{label 1281}# + (#{ribcage-labels 369}# #{ribcage 1279}#)))))) + (#{make-binding-wrap 387}# + (lambda (#{ids 1286}# #{labels 1287}# #{w 1288}#) + (if (null? #{ids 1286}#) + #{w 1288}# + (cons (car #{w 1288}#) (cons (begin - (let ((#{labelvec 1279}# - (list->vector #{labels 1271}#))) + (let ((#{labelvec 1295}# + (list->vector #{labels 1287}#))) (begin - (let ((#{n 1281}# - (vector-length #{labelvec 1279}#))) + (let ((#{n 1297}# + (vector-length #{labelvec 1295}#))) (begin - (let ((#{symnamevec 1284}# - (make-vector #{n 1281}#)) - (#{marksvec 1285}# - (make-vector #{n 1281}#))) + (let ((#{symnamevec 1300}# + (make-vector #{n 1297}#)) + (#{marksvec 1301}# + (make-vector #{n 1297}#))) (begin (letrec* - ((#{f 1289}# - (lambda (#{ids 1290}# #{i 1291}#) - (if (not (null? #{ids 1290}#)) + ((#{f 1305}# + (lambda (#{ids 1306}# #{i 1307}#) + (if (not (null? #{ids 1306}#)) (call-with-values (lambda () - (#{id-sym-name&marks 342}# - (car #{ids 1290}#) - #{w 1272}#)) - (lambda (#{symname 1292}# - #{marks 1293}#) + (#{id-sym-name&marks 346}# + (car #{ids 1306}#) + #{w 1288}#)) + (lambda (#{symname 1308}# + #{marks 1309}#) (begin (vector-set! - #{symnamevec 1284}# - #{i 1291}# - #{symname 1292}#) + #{symnamevec 1300}# + #{i 1307}# + #{symname 1308}#) (vector-set! - #{marksvec 1285}# - #{i 1291}# - #{marks 1293}#) - (#{f 1289}# - (cdr #{ids 1290}#) - (#{1+}# #{i 1291}#))))))))) - (begin (#{f 1289}# #{ids 1270}# 0))) - (#{make-ribcage 357}# - #{symnamevec 1284}# - #{marksvec 1285}# - #{labelvec 1279}#)))))))) - (cdr #{w 1272}#)))))) - (#{smart-append 385}# - (lambda (#{m1 1298}# #{m2 1299}#) - (if (null? #{m2 1299}#) - #{m1 1298}# - (append #{m1 1298}# #{m2 1299}#)))) - (#{join-wraps 387}# - (lambda (#{w1 1302}# #{w2 1303}#) + #{marksvec 1301}# + #{i 1307}# + #{marks 1309}#) + (#{f 1305}# + (cdr #{ids 1306}#) + (#{1+}# #{i 1307}#))))))))) + (begin (#{f 1305}# #{ids 1286}# 0))) + (#{make-ribcage 361}# + #{symnamevec 1300}# + #{marksvec 1301}# + #{labelvec 1295}#)))))))) + (cdr #{w 1288}#)))))) + (#{smart-append 389}# + (lambda (#{m1 1314}# #{m2 1315}#) + (if (null? #{m2 1315}#) + #{m1 1314}# + (append #{m1 1314}# #{m2 1315}#)))) + (#{join-wraps 391}# + (lambda (#{w1 1318}# #{w2 1319}#) (begin - (let ((#{m1 1308}# (car #{w1 1302}#)) - (#{s1 1309}# (cdr #{w1 1302}#))) - (if (null? #{m1 1308}#) - (if (null? #{s1 1309}#) - #{w2 1303}# - (cons (car #{w2 1303}#) - (#{smart-append 385}# - #{s1 1309}# - (cdr #{w2 1303}#)))) - (cons (#{smart-append 385}# - #{m1 1308}# - (car #{w2 1303}#)) - (#{smart-append 385}# - #{s1 1309}# - (cdr #{w2 1303}#)))))))) - (#{join-marks 389}# - (lambda (#{m1 1318}# #{m2 1319}#) - (#{smart-append 385}# #{m1 1318}# #{m2 1319}#))) - (#{same-marks? 391}# - (lambda (#{x 1322}# #{y 1323}#) + (let ((#{m1 1324}# (car #{w1 1318}#)) + (#{s1 1325}# (cdr #{w1 1318}#))) + (if (null? #{m1 1324}#) + (if (null? #{s1 1325}#) + #{w2 1319}# + (cons (car #{w2 1319}#) + (#{smart-append 389}# + #{s1 1325}# + (cdr #{w2 1319}#)))) + (cons (#{smart-append 389}# + #{m1 1324}# + (car #{w2 1319}#)) + (#{smart-append 389}# + #{s1 1325}# + (cdr #{w2 1319}#)))))))) + (#{join-marks 393}# + (lambda (#{m1 1334}# #{m2 1335}#) + (#{smart-append 389}# #{m1 1334}# #{m2 1335}#))) + (#{same-marks? 395}# + (lambda (#{x 1338}# #{y 1339}#) (begin - (let ((#{t 1328}# (eq? #{x 1322}# #{y 1323}#))) - (if #{t 1328}# - #{t 1328}# - (if (not (null? #{x 1322}#)) - (if (not (null? #{y 1323}#)) - (if (eq? (car #{x 1322}#) (car #{y 1323}#)) - (#{same-marks? 391}# - (cdr #{x 1322}#) - (cdr #{y 1323}#)) + (let ((#{t 1344}# (eq? #{x 1338}# #{y 1339}#))) + (if #{t 1344}# + #{t 1344}# + (if (not (null? #{x 1338}#)) + (if (not (null? #{y 1339}#)) + (if (eq? (car #{x 1338}#) (car #{y 1339}#)) + (#{same-marks? 395}# + (cdr #{x 1338}#) + (cdr #{y 1339}#)) #f) #f) #f)))))) - (#{id-var-name 393}# - (lambda (#{id 1334}# #{w 1335}#) + (#{id-var-name 397}# + (lambda (#{id 1350}# #{w 1351}#) (letrec* - ((#{search 1340}# - (lambda (#{sym 1356}# #{subst 1357}# #{marks 1358}#) - (if (null? #{subst 1357}#) - (values #f #{marks 1358}#) + ((#{search 1356}# + (lambda (#{sym 1372}# #{subst 1373}# #{marks 1374}#) + (if (null? #{subst 1373}#) + (values #f #{marks 1374}#) (begin - (let ((#{fst 1363}# (car #{subst 1357}#))) - (if (eq? #{fst 1363}# 'shift) - (#{search 1340}# - #{sym 1356}# - (cdr #{subst 1357}#) - (cdr #{marks 1358}#)) + (let ((#{fst 1379}# (car #{subst 1373}#))) + (if (eq? #{fst 1379}# 'shift) + (#{search 1356}# + #{sym 1372}# + (cdr #{subst 1373}#) + (cdr #{marks 1374}#)) (begin - (let ((#{symnames 1365}# - (#{ribcage-symnames 361}# #{fst 1363}#))) - (if (vector? #{symnames 1365}#) - (#{search-vector-rib 1344}# - #{sym 1356}# - #{subst 1357}# - #{marks 1358}# - #{symnames 1365}# - #{fst 1363}#) - (#{search-list-rib 1342}# - #{sym 1356}# - #{subst 1357}# - #{marks 1358}# - #{symnames 1365}# - #{fst 1363}#)))))))))) - (#{search-list-rib 1342}# - (lambda (#{sym 1366}# - #{subst 1367}# - #{marks 1368}# - #{symnames 1369}# - #{ribcage 1370}#) + (let ((#{symnames 1381}# + (#{ribcage-symnames 365}# #{fst 1379}#))) + (if (vector? #{symnames 1381}#) + (#{search-vector-rib 1360}# + #{sym 1372}# + #{subst 1373}# + #{marks 1374}# + #{symnames 1381}# + #{fst 1379}#) + (#{search-list-rib 1358}# + #{sym 1372}# + #{subst 1373}# + #{marks 1374}# + #{symnames 1381}# + #{fst 1379}#)))))))))) + (#{search-list-rib 1358}# + (lambda (#{sym 1382}# + #{subst 1383}# + #{marks 1384}# + #{symnames 1385}# + #{ribcage 1386}#) (letrec* - ((#{f 1379}# - (lambda (#{symnames 1380}# #{i 1381}#) - (if (null? #{symnames 1380}#) - (#{search 1340}# - #{sym 1366}# - (cdr #{subst 1367}#) - #{marks 1368}#) - (if (if (eq? (car #{symnames 1380}#) #{sym 1366}#) - (#{same-marks? 391}# - #{marks 1368}# + ((#{f 1395}# + (lambda (#{symnames 1396}# #{i 1397}#) + (if (null? #{symnames 1396}#) + (#{search 1356}# + #{sym 1382}# + (cdr #{subst 1383}#) + #{marks 1384}#) + (if (if (eq? (car #{symnames 1396}#) #{sym 1382}#) + (#{same-marks? 395}# + #{marks 1384}# (list-ref - (#{ribcage-marks 363}# #{ribcage 1370}#) - #{i 1381}#)) + (#{ribcage-marks 367}# #{ribcage 1386}#) + #{i 1397}#)) #f) (values (list-ref - (#{ribcage-labels 365}# #{ribcage 1370}#) - #{i 1381}#) - #{marks 1368}#) - (#{f 1379}# - (cdr #{symnames 1380}#) - (#{1+}# #{i 1381}#))))))) - (begin (#{f 1379}# #{symnames 1369}# 0))))) - (#{search-vector-rib 1344}# - (lambda (#{sym 1390}# - #{subst 1391}# - #{marks 1392}# - #{symnames 1393}# - #{ribcage 1394}#) + (#{ribcage-labels 369}# #{ribcage 1386}#) + #{i 1397}#) + #{marks 1384}#) + (#{f 1395}# + (cdr #{symnames 1396}#) + (#{1+}# #{i 1397}#))))))) + (begin (#{f 1395}# #{symnames 1385}# 0))))) + (#{search-vector-rib 1360}# + (lambda (#{sym 1406}# + #{subst 1407}# + #{marks 1408}# + #{symnames 1409}# + #{ribcage 1410}#) (begin - (let ((#{n 1401}# (vector-length #{symnames 1393}#))) + (let ((#{n 1417}# (vector-length #{symnames 1409}#))) (letrec* - ((#{f 1404}# - (lambda (#{i 1405}#) - (if (= #{i 1405}# #{n 1401}#) - (#{search 1340}# - #{sym 1390}# - (cdr #{subst 1391}#) - #{marks 1392}#) + ((#{f 1420}# + (lambda (#{i 1421}#) + (if (= #{i 1421}# #{n 1417}#) + (#{search 1356}# + #{sym 1406}# + (cdr #{subst 1407}#) + #{marks 1408}#) (if (if (eq? (vector-ref - #{symnames 1393}# - #{i 1405}#) - #{sym 1390}#) - (#{same-marks? 391}# - #{marks 1392}# + #{symnames 1409}# + #{i 1421}#) + #{sym 1406}#) + (#{same-marks? 395}# + #{marks 1408}# (vector-ref - (#{ribcage-marks 363}# #{ribcage 1394}#) - #{i 1405}#)) + (#{ribcage-marks 367}# #{ribcage 1410}#) + #{i 1421}#)) #f) (values (vector-ref - (#{ribcage-labels 365}# #{ribcage 1394}#) - #{i 1405}#) - #{marks 1392}#) - (#{f 1404}# (#{1+}# #{i 1405}#))))))) - (begin (#{f 1404}# 0)))))))) + (#{ribcage-labels 369}# #{ribcage 1410}#) + #{i 1421}#) + #{marks 1408}#) + (#{f 1420}# (#{1+}# #{i 1421}#))))))) + (begin (#{f 1420}# 0)))))))) (begin - (if (symbol? #{id 1334}#) + (if (symbol? #{id 1350}#) (begin - (let ((#{t 1417}# - (#{search 1340}# - #{id 1334}# - (cdr #{w 1335}#) - (car #{w 1335}#)))) - (if #{t 1417}# #{t 1417}# #{id 1334}#))) - (if (#{syntax-object? 305}# #{id 1334}#) + (let ((#{t 1433}# + (#{search 1356}# + #{id 1350}# + (cdr #{w 1351}#) + (car #{w 1351}#)))) + (if #{t 1433}# #{t 1433}# #{id 1350}#))) + (if (#{syntax-object? 309}# #{id 1350}#) (begin - (let ((#{id 1426}# - (#{syntax-object-expression 307}# #{id 1334}#)) - (#{w1 1427}# - (#{syntax-object-wrap 309}# #{id 1334}#))) + (let ((#{id 1442}# + (#{syntax-object-expression 311}# #{id 1350}#)) + (#{w1 1443}# + (#{syntax-object-wrap 313}# #{id 1350}#))) (begin - (let ((#{marks 1429}# - (#{join-marks 389}# - (car #{w 1335}#) - (car #{w1 1427}#)))) + (let ((#{marks 1445}# + (#{join-marks 393}# + (car #{w 1351}#) + (car #{w1 1443}#)))) (call-with-values (lambda () - (#{search 1340}# - #{id 1426}# - (cdr #{w 1335}#) - #{marks 1429}#)) - (lambda (#{new-id 1433}# #{marks 1434}#) + (#{search 1356}# + #{id 1442}# + (cdr #{w 1351}#) + #{marks 1445}#)) + (lambda (#{new-id 1449}# #{marks 1450}#) (begin - (let ((#{t 1439}# #{new-id 1433}#)) - (if #{t 1439}# - #{t 1439}# + (let ((#{t 1455}# #{new-id 1449}#)) + (if #{t 1455}# + #{t 1455}# (begin - (let ((#{t 1442}# - (#{search 1340}# - #{id 1426}# - (cdr #{w1 1427}#) - #{marks 1434}#))) - (if #{t 1442}# - #{t 1442}# - #{id 1426}#)))))))))))) + (let ((#{t 1458}# + (#{search 1356}# + #{id 1442}# + (cdr #{w1 1443}#) + #{marks 1450}#))) + (if #{t 1458}# + #{t 1458}# + #{id 1442}#)))))))))))) (syntax-violation 'id-var-name "invalid id" - #{id 1334}#))))))) - (#{free-id=? 395}# - (lambda (#{i 1447}# #{j 1448}#) + #{id 1350}#))))))) + (#{free-id=? 399}# + (lambda (#{i 1463}# #{j 1464}#) (if (eq? (begin - (let ((#{x 1454}# #{i 1447}#)) - (if (#{syntax-object? 305}# #{x 1454}#) - (#{syntax-object-expression 307}# #{x 1454}#) - #{x 1454}#))) + (let ((#{x 1470}# #{i 1463}#)) + (if (#{syntax-object? 309}# #{x 1470}#) + (#{syntax-object-expression 311}# #{x 1470}#) + #{x 1470}#))) (begin - (let ((#{x 1457}# #{j 1448}#)) - (if (#{syntax-object? 305}# #{x 1457}#) - (#{syntax-object-expression 307}# #{x 1457}#) - #{x 1457}#)))) - (eq? (#{id-var-name 393}# #{i 1447}# '(())) - (#{id-var-name 393}# #{j 1448}# '(()))) + (let ((#{x 1473}# #{j 1464}#)) + (if (#{syntax-object? 309}# #{x 1473}#) + (#{syntax-object-expression 311}# #{x 1473}#) + #{x 1473}#)))) + (eq? (#{id-var-name 397}# #{i 1463}# '(())) + (#{id-var-name 397}# #{j 1464}# '(()))) #f))) - (#{bound-id=? 397}# - (lambda (#{i 1461}# #{j 1462}#) - (if (if (#{syntax-object? 305}# #{i 1461}#) - (#{syntax-object? 305}# #{j 1462}#) + (#{bound-id=? 401}# + (lambda (#{i 1477}# #{j 1478}#) + (if (if (#{syntax-object? 309}# #{i 1477}#) + (#{syntax-object? 309}# #{j 1478}#) #f) - (if (eq? (#{syntax-object-expression 307}# #{i 1461}#) - (#{syntax-object-expression 307}# #{j 1462}#)) - (#{same-marks? 391}# - (car (#{syntax-object-wrap 309}# #{i 1461}#)) - (car (#{syntax-object-wrap 309}# #{j 1462}#))) + (if (eq? (#{syntax-object-expression 311}# #{i 1477}#) + (#{syntax-object-expression 311}# #{j 1478}#)) + (#{same-marks? 395}# + (car (#{syntax-object-wrap 313}# #{i 1477}#)) + (car (#{syntax-object-wrap 313}# #{j 1478}#))) #f) - (eq? #{i 1461}# #{j 1462}#)))) - (#{valid-bound-ids? 399}# - (lambda (#{ids 1471}#) + (eq? #{i 1477}# #{j 1478}#)))) + (#{valid-bound-ids? 403}# + (lambda (#{ids 1487}#) (if (letrec* - ((#{all-ids? 1476}# - (lambda (#{ids 1477}#) + ((#{all-ids? 1492}# + (lambda (#{ids 1493}#) (begin - (let ((#{t 1480}# (null? #{ids 1477}#))) - (if #{t 1480}# - #{t 1480}# - (if (#{id? 339}# (car #{ids 1477}#)) - (#{all-ids? 1476}# (cdr #{ids 1477}#)) + (let ((#{t 1496}# (null? #{ids 1493}#))) + (if #{t 1496}# + #{t 1496}# + (if (#{id? 343}# (car #{ids 1493}#)) + (#{all-ids? 1492}# (cdr #{ids 1493}#)) #f))))))) - (begin (#{all-ids? 1476}# #{ids 1471}#))) - (#{distinct-bound-ids? 401}# #{ids 1471}#) + (begin (#{all-ids? 1492}# #{ids 1487}#))) + (#{distinct-bound-ids? 405}# #{ids 1487}#) #f))) - (#{distinct-bound-ids? 401}# - (lambda (#{ids 1485}#) + (#{distinct-bound-ids? 405}# + (lambda (#{ids 1501}#) (letrec* - ((#{distinct? 1489}# - (lambda (#{ids 1490}#) + ((#{distinct? 1505}# + (lambda (#{ids 1506}#) (begin - (let ((#{t 1493}# (null? #{ids 1490}#))) - (if #{t 1493}# - #{t 1493}# - (if (not (#{bound-id-member? 403}# - (car #{ids 1490}#) - (cdr #{ids 1490}#))) - (#{distinct? 1489}# (cdr #{ids 1490}#)) + (let ((#{t 1509}# (null? #{ids 1506}#))) + (if #{t 1509}# + #{t 1509}# + (if (not (#{bound-id-member? 407}# + (car #{ids 1506}#) + (cdr #{ids 1506}#))) + (#{distinct? 1505}# (cdr #{ids 1506}#)) #f))))))) - (begin (#{distinct? 1489}# #{ids 1485}#))))) - (#{bound-id-member? 403}# - (lambda (#{x 1497}# #{list 1498}#) - (if (not (null? #{list 1498}#)) + (begin (#{distinct? 1505}# #{ids 1501}#))))) + (#{bound-id-member? 407}# + (lambda (#{x 1513}# #{list 1514}#) + (if (not (null? #{list 1514}#)) (begin - (let ((#{t 1505}# - (#{bound-id=? 397}# - #{x 1497}# - (car #{list 1498}#)))) - (if #{t 1505}# - #{t 1505}# - (#{bound-id-member? 403}# - #{x 1497}# - (cdr #{list 1498}#))))) + (let ((#{t 1521}# + (#{bound-id=? 401}# + #{x 1513}# + (car #{list 1514}#)))) + (if #{t 1521}# + #{t 1521}# + (#{bound-id-member? 407}# + #{x 1513}# + (cdr #{list 1514}#))))) #f))) - (#{wrap 405}# - (lambda (#{x 1507}# #{w 1508}# #{defmod 1509}#) - (if (if (null? (car #{w 1508}#)) - (null? (cdr #{w 1508}#)) + (#{wrap 409}# + (lambda (#{x 1523}# #{w 1524}# #{defmod 1525}#) + (if (if (null? (car #{w 1524}#)) + (null? (cdr #{w 1524}#)) #f) - #{x 1507}# - (if (#{syntax-object? 305}# #{x 1507}#) - (#{make-syntax-object 303}# - (#{syntax-object-expression 307}# #{x 1507}#) - (#{join-wraps 387}# - #{w 1508}# - (#{syntax-object-wrap 309}# #{x 1507}#)) - (#{syntax-object-module 311}# #{x 1507}#)) - (if (null? #{x 1507}#) - #{x 1507}# - (#{make-syntax-object 303}# - #{x 1507}# - #{w 1508}# - #{defmod 1509}#)))))) - (#{source-wrap 407}# - (lambda (#{x 1524}# - #{w 1525}# - #{s 1526}# - #{defmod 1527}#) - (#{wrap 405}# - (#{decorate-source 259}# #{x 1524}# #{s 1526}#) - #{w 1525}# - #{defmod 1527}#))) - (#{chi-sequence 409}# - (lambda (#{body 1532}# - #{r 1533}# - #{w 1534}# - #{s 1535}# - #{mod 1536}#) - (#{build-sequence 293}# - #{s 1535}# + #{x 1523}# + (if (#{syntax-object? 309}# #{x 1523}#) + (#{make-syntax-object 307}# + (#{syntax-object-expression 311}# #{x 1523}#) + (#{join-wraps 391}# + #{w 1524}# + (#{syntax-object-wrap 313}# #{x 1523}#)) + (#{syntax-object-module 315}# #{x 1523}#)) + (if (null? #{x 1523}#) + #{x 1523}# + (#{make-syntax-object 307}# + #{x 1523}# + #{w 1524}# + #{defmod 1525}#)))))) + (#{source-wrap 411}# + (lambda (#{x 1540}# + #{w 1541}# + #{s 1542}# + #{defmod 1543}#) + (#{wrap 409}# + (#{decorate-source 261}# #{x 1540}# #{s 1542}#) + #{w 1541}# + #{defmod 1543}#))) + (#{chi-sequence 413}# + (lambda (#{body 1548}# + #{r 1549}# + #{w 1550}# + #{s 1551}# + #{mod 1552}#) + (#{build-sequence 297}# + #{s 1551}# (letrec* - ((#{dobody 1547}# - (lambda (#{body 1548}# - #{r 1549}# - #{w 1550}# - #{mod 1551}#) - (if (null? #{body 1548}#) + ((#{dobody 1563}# + (lambda (#{body 1564}# + #{r 1565}# + #{w 1566}# + #{mod 1567}#) + (if (null? #{body 1564}#) '() (begin - (let ((#{first 1553}# - (#{chi 419}# - (car #{body 1548}#) - #{r 1549}# - #{w 1550}# - #{mod 1551}#))) - (cons #{first 1553}# - (#{dobody 1547}# - (cdr #{body 1548}#) - #{r 1549}# - #{w 1550}# - #{mod 1551}#)))))))) + (let ((#{first 1569}# + (#{chi 423}# + (car #{body 1564}#) + #{r 1565}# + #{w 1566}# + #{mod 1567}#))) + (cons #{first 1569}# + (#{dobody 1563}# + (cdr #{body 1564}#) + #{r 1565}# + #{w 1566}# + #{mod 1567}#)))))))) (begin - (#{dobody 1547}# - #{body 1532}# - #{r 1533}# - #{w 1534}# - #{mod 1536}#)))))) - (#{chi-top-sequence 411}# - (lambda (#{body 1554}# - #{r 1555}# - #{w 1556}# - #{s 1557}# - #{m 1558}# - #{esew 1559}# - #{mod 1560}#) + (#{dobody 1563}# + #{body 1548}# + #{r 1549}# + #{w 1550}# + #{mod 1552}#)))))) + (#{chi-top-sequence 415}# + (lambda (#{body 1570}# + #{r 1571}# + #{w 1572}# + #{s 1573}# + #{m 1574}# + #{esew 1575}# + #{mod 1576}#) (letrec* - ((#{scan 1569}# - (lambda (#{body 1570}# - #{r 1571}# - #{w 1572}# - #{s 1573}# - #{m 1574}# - #{esew 1575}# - #{mod 1576}# - #{exps 1577}#) - (if (null? #{body 1570}#) - #{exps 1577}# + ((#{scan 1585}# + (lambda (#{body 1586}# + #{r 1587}# + #{w 1588}# + #{s 1589}# + #{m 1590}# + #{esew 1591}# + #{mod 1592}# + #{exps 1593}#) + (if (null? #{body 1586}#) + #{exps 1593}# (call-with-values (lambda () (call-with-values (lambda () (begin - (let ((#{e 1590}# (car #{body 1570}#))) - (#{syntax-type 417}# - #{e 1590}# - #{r 1571}# - #{w 1572}# + (let ((#{e 1606}# (car #{body 1586}#))) + (#{syntax-type 421}# + #{e 1606}# + #{r 1587}# + #{w 1588}# (begin - (let ((#{t 1593}# - (#{source-annotation 320}# - #{e 1590}#))) - (if #{t 1593}# #{t 1593}# #{s 1573}#))) + (let ((#{t 1609}# + (#{source-annotation 324}# + #{e 1606}#))) + (if #{t 1609}# #{t 1609}# #{s 1589}#))) #f - #{mod 1576}# + #{mod 1592}# #f)))) - (lambda (#{type 1595}# - #{value 1596}# - #{e 1597}# - #{w 1598}# - #{s 1599}# - #{mod 1600}#) - (if (eqv? #{type 1595}# 'begin-form) - (let ((#{tmp 1608}# #{e 1597}#)) - (let ((#{tmp 1609}# - ($sc-dispatch #{tmp 1608}# '(_)))) - (if #{tmp 1609}# - (@apply (lambda () #{exps 1577}#) #{tmp 1609}#) - (let ((#{tmp 1610}# + (lambda (#{type 1611}# + #{value 1612}# + #{e 1613}# + #{w 1614}# + #{s 1615}# + #{mod 1616}#) + (if (memv #{type 1611}# '(begin-form)) + (let ((#{tmp 1624}# #{e 1613}#)) + (let ((#{tmp 1625}# + ($sc-dispatch #{tmp 1624}# '(_)))) + (if #{tmp 1625}# + (@apply (lambda () #{exps 1593}#) #{tmp 1625}#) + (let ((#{tmp 1626}# ($sc-dispatch - #{tmp 1608}# + #{tmp 1624}# '(_ any . each-any)))) - (if #{tmp 1610}# + (if #{tmp 1626}# (@apply - (lambda (#{e1 1613}# #{e2 1614}#) - (#{scan 1569}# - (cons #{e1 1613}# #{e2 1614}#) - #{r 1571}# - #{w 1598}# - #{s 1599}# - #{m 1574}# - #{esew 1575}# - #{mod 1600}# - #{exps 1577}#)) - #{tmp 1610}#) + (lambda (#{e1 1629}# #{e2 1630}#) + (#{scan 1585}# + (cons #{e1 1629}# #{e2 1630}#) + #{r 1587}# + #{w 1614}# + #{s 1615}# + #{m 1590}# + #{esew 1591}# + #{mod 1616}# + #{exps 1593}#)) + #{tmp 1626}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 1608}#)))))) - (if (eqv? #{type 1595}# 'local-syntax-form) - (#{chi-local-syntax 429}# - #{value 1596}# - #{e 1597}# - #{r 1571}# - #{w 1598}# - #{s 1599}# - #{mod 1600}# - (lambda (#{body 1617}# - #{r 1618}# - #{w 1619}# - #{s 1620}# - #{mod 1621}#) - (#{scan 1569}# - #{body 1617}# - #{r 1618}# - #{w 1619}# - #{s 1620}# - #{m 1574}# - #{esew 1575}# - #{mod 1621}# - #{exps 1577}#))) - (if (eqv? #{type 1595}# 'eval-when-form) - (let ((#{tmp 1628}# #{e 1597}#)) - (let ((#{tmp 1629}# + #{tmp 1624}#)))))) + (if (memv #{type 1611}# '(local-syntax-form)) + (#{chi-local-syntax 433}# + #{value 1612}# + #{e 1613}# + #{r 1587}# + #{w 1614}# + #{s 1615}# + #{mod 1616}# + (lambda (#{body 1633}# + #{r 1634}# + #{w 1635}# + #{s 1636}# + #{mod 1637}#) + (#{scan 1585}# + #{body 1633}# + #{r 1634}# + #{w 1635}# + #{s 1636}# + #{m 1590}# + #{esew 1591}# + #{mod 1637}# + #{exps 1593}#))) + (if (memv #{type 1611}# '(eval-when-form)) + (let ((#{tmp 1644}# #{e 1613}#)) + (let ((#{tmp 1645}# ($sc-dispatch - #{tmp 1628}# + #{tmp 1644}# '(_ each-any any . each-any)))) - (if #{tmp 1629}# + (if #{tmp 1645}# (@apply - (lambda (#{x 1633}# - #{e1 1634}# - #{e2 1635}#) + (lambda (#{x 1649}# + #{e1 1650}# + #{e2 1651}#) (begin - (let ((#{when-list 1638}# - (#{chi-when-list 415}# - #{e 1597}# - #{x 1633}# - #{w 1598}#)) - (#{body 1639}# - (cons #{e1 1634}# - #{e2 1635}#))) - (if (eq? #{m 1574}# 'e) + (let ((#{when-list 1654}# + (#{chi-when-list 419}# + #{e 1613}# + #{x 1649}# + #{w 1614}#)) + (#{body 1655}# + (cons #{e1 1650}# + #{e2 1651}#))) + (if (eq? #{m 1590}# 'e) (if (memq 'eval - #{when-list 1638}#) - (#{scan 1569}# - #{body 1639}# - #{r 1571}# - #{w 1598}# - #{s 1599}# + #{when-list 1654}#) + (#{scan 1585}# + #{body 1655}# + #{r 1587}# + #{w 1614}# + #{s 1615}# (if (memq 'expand - #{when-list 1638}#) + #{when-list 1654}#) 'c&e 'e) '(eval) - #{mod 1600}# - #{exps 1577}#) + #{mod 1616}# + #{exps 1593}#) (begin (if (memq 'expand - #{when-list 1638}#) - (#{top-level-eval-hook 250}# - (#{chi-top-sequence 411}# - #{body 1639}# - #{r 1571}# - #{w 1598}# - #{s 1599}# + #{when-list 1654}#) + (#{top-level-eval-hook 252}# + (#{chi-top-sequence 415}# + #{body 1655}# + #{r 1587}# + #{w 1614}# + #{s 1615}# 'e '(eval) - #{mod 1600}#) - #{mod 1600}#)) - #{exps 1577}#)) + #{mod 1616}#) + #{mod 1616}#)) + #{exps 1593}#)) (if (memq 'load - #{when-list 1638}#) + #{when-list 1654}#) (if (begin - (let ((#{t 1648}# + (let ((#{t 1664}# (memq 'compile - #{when-list 1638}#))) - (if #{t 1648}# - #{t 1648}# + #{when-list 1654}#))) + (if #{t 1664}# + #{t 1664}# (begin - (let ((#{t 1651}# + (let ((#{t 1667}# (memq 'expand - #{when-list 1638}#))) - (if #{t 1651}# - #{t 1651}# - (if (eq? #{m 1574}# + #{when-list 1654}#))) + (if #{t 1667}# + #{t 1667}# + (if (eq? #{m 1590}# 'c&e) (memq 'eval - #{when-list 1638}#) + #{when-list 1654}#) #f))))))) - (#{scan 1569}# - #{body 1639}# - #{r 1571}# - #{w 1598}# - #{s 1599}# + (#{scan 1585}# + #{body 1655}# + #{r 1587}# + #{w 1614}# + #{s 1615}# 'c&e '(compile load) - #{mod 1600}# - #{exps 1577}#) - (if (if (eq? #{m 1574}# 'c) - #t - (eq? #{m 1574}# 'c&e)) - (#{scan 1569}# - #{body 1639}# - #{r 1571}# - #{w 1598}# - #{s 1599}# + #{mod 1616}# + #{exps 1593}#) + (if (memq #{m 1590}# + '(c c&e)) + (#{scan 1585}# + #{body 1655}# + #{r 1587}# + #{w 1614}# + #{s 1615}# 'c '(load) - #{mod 1600}# - #{exps 1577}#) - #{exps 1577}#)) + #{mod 1616}# + #{exps 1593}#) + #{exps 1593}#)) (if (begin - (let ((#{t 1659}# + (let ((#{t 1675}# (memq 'compile - #{when-list 1638}#))) - (if #{t 1659}# - #{t 1659}# + #{when-list 1654}#))) + (if #{t 1675}# + #{t 1675}# (begin - (let ((#{t 1662}# + (let ((#{t 1678}# (memq 'expand - #{when-list 1638}#))) - (if #{t 1662}# - #{t 1662}# - (if (eq? #{m 1574}# + #{when-list 1654}#))) + (if #{t 1678}# + #{t 1678}# + (if (eq? #{m 1590}# 'c&e) (memq 'eval - #{when-list 1638}#) + #{when-list 1654}#) #f))))))) (begin - (#{top-level-eval-hook 250}# - (#{chi-top-sequence 411}# - #{body 1639}# - #{r 1571}# - #{w 1598}# - #{s 1599}# + (#{top-level-eval-hook 252}# + (#{chi-top-sequence 415}# + #{body 1655}# + #{r 1587}# + #{w 1614}# + #{s 1615}# 'e '(eval) - #{mod 1600}#) - #{mod 1600}#) - #{exps 1577}#) - #{exps 1577}#)))))) - #{tmp 1629}#) + #{mod 1616}#) + #{mod 1616}#) + #{exps 1593}#) + #{exps 1593}#)))))) + #{tmp 1645}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 1628}#)))) - (if (eqv? #{type 1595}# 'define-syntax-form) + #{tmp 1644}#)))) + (if (memv #{type 1611}# '(define-syntax-form)) (begin - (let ((#{n 1670}# - (#{id-var-name 393}# - #{value 1596}# - #{w 1598}#)) - (#{r 1671}# - (#{macros-only-env 331}# - #{r 1571}#))) - (if (eqv? #{m 1574}# 'c) - (if (memq 'compile #{esew 1575}#) + (let ((#{n 1686}# + (#{id-var-name 397}# + #{value 1612}# + #{w 1614}#)) + (#{r 1687}# + (#{macros-only-env 335}# + #{r 1587}#))) + (if (memv #{m 1590}# '(c)) + (if (memq 'compile #{esew 1591}#) (begin - (let ((#{e 1674}# - (#{chi-install-global 413}# - #{n 1670}# - (#{chi 419}# - #{e 1597}# - #{r 1671}# - #{w 1598}# - #{mod 1600}#)))) + (let ((#{e 1690}# + (#{chi-install-global 417}# + #{n 1686}# + (#{chi 423}# + #{e 1613}# + #{r 1687}# + #{w 1614}# + #{mod 1616}#)))) (begin - (#{top-level-eval-hook 250}# - #{e 1674}# - #{mod 1600}#) - (if (memq 'load #{esew 1575}#) - (cons #{e 1674}# #{exps 1577}#) - #{exps 1577}#)))) - (if (memq 'load #{esew 1575}#) - (cons (#{chi-install-global 413}# - #{n 1670}# - (#{chi 419}# - #{e 1597}# - #{r 1671}# - #{w 1598}# - #{mod 1600}#)) - #{exps 1577}#) - #{exps 1577}#)) - (if (eqv? #{m 1574}# 'c&e) + (#{top-level-eval-hook 252}# + #{e 1690}# + #{mod 1616}#) + (if (memq 'load #{esew 1591}#) + (cons #{e 1690}# #{exps 1593}#) + #{exps 1593}#)))) + (if (memq 'load #{esew 1591}#) + (cons (#{chi-install-global 417}# + #{n 1686}# + (#{chi 423}# + #{e 1613}# + #{r 1687}# + #{w 1614}# + #{mod 1616}#)) + #{exps 1593}#) + #{exps 1593}#)) + (if (memv #{m 1590}# '(c&e)) (begin - (let ((#{e 1677}# - (#{chi-install-global 413}# - #{n 1670}# - (#{chi 419}# - #{e 1597}# - #{r 1671}# - #{w 1598}# - #{mod 1600}#)))) + (let ((#{e 1693}# + (#{chi-install-global 417}# + #{n 1686}# + (#{chi 423}# + #{e 1613}# + #{r 1687}# + #{w 1614}# + #{mod 1616}#)))) (begin - (#{top-level-eval-hook 250}# - #{e 1677}# - #{mod 1600}#) - (cons #{e 1677}# - #{exps 1577}#)))) + (#{top-level-eval-hook 252}# + #{e 1693}# + #{mod 1616}#) + (cons #{e 1693}# + #{exps 1593}#)))) (begin - (if (memq 'eval #{esew 1575}#) - (#{top-level-eval-hook 250}# - (#{chi-install-global 413}# - #{n 1670}# - (#{chi 419}# - #{e 1597}# - #{r 1671}# - #{w 1598}# - #{mod 1600}#)) - #{mod 1600}#)) - #{exps 1577}#))))) - (if (eqv? #{type 1595}# 'define-form) + (if (memq 'eval #{esew 1591}#) + (#{top-level-eval-hook 252}# + (#{chi-install-global 417}# + #{n 1686}# + (#{chi 423}# + #{e 1613}# + #{r 1687}# + #{w 1614}# + #{mod 1616}#)) + #{mod 1616}#)) + #{exps 1593}#))))) + (if (memv #{type 1611}# '(define-form)) (begin - (let ((#{n 1682}# - (#{id-var-name 393}# - #{value 1596}# - #{w 1598}#))) + (let ((#{n 1698}# + (#{id-var-name 397}# + #{value 1612}# + #{w 1614}#))) (begin - (let ((#{type 1684}# - (car (#{lookup 333}# - #{n 1682}# - #{r 1571}# - #{mod 1600}#)))) - (if (if (eqv? #{type 1684}# 'global) - #t - (if (eqv? #{type 1684}# 'core) - #t - (if (eqv? #{type 1684}# - 'macro) - #t - (eqv? #{type 1684}# - 'module-ref)))) + (let ((#{type 1700}# + (car (#{lookup 337}# + #{n 1698}# + #{r 1587}# + #{mod 1616}#)))) + (if (memv #{type 1700}# + '(global + core + macro + module-ref)) (begin - (if (if (if (eq? #{m 1574}# 'c) - #t - (eq? #{m 1574}# 'c&e)) + (if (if (memq #{m 1590}# + '(c c&e)) (if (not (module-local-variable (current-module) - #{n 1682}#)) + #{n 1698}#)) (current-module) #f) #f) (begin - (let ((#{old 1691}# + (let ((#{old 1707}# (module-variable (current-module) - #{n 1682}#))) + #{n 1698}#))) (if (if (variable? - #{old 1691}#) + #{old 1707}#) (variable-bound? - #{old 1691}#) + #{old 1707}#) #f) (module-define! (current-module) - #{n 1682}# + #{n 1698}# (variable-ref - #{old 1691}#)) + #{old 1707}#)) (module-add! (current-module) - #{n 1682}# + #{n 1698}# (make-undefined-variable)))))) - (cons (if (eq? #{m 1574}# 'c&e) + (cons (if (eq? #{m 1590}# 'c&e) (begin - (let ((#{x 1695}# - (#{build-global-definition 281}# - #{s 1599}# - #{n 1682}# - (#{chi 419}# - #{e 1597}# - #{r 1571}# - #{w 1598}# - #{mod 1600}#)))) + (let ((#{x 1711}# + (#{build-global-definition 283}# + #{s 1615}# + #{n 1698}# + (#{chi 423}# + #{e 1613}# + #{r 1587}# + #{w 1614}# + #{mod 1616}#)))) (begin - (#{top-level-eval-hook 250}# - #{x 1695}# - #{mod 1600}#) - #{x 1695}#))) + (#{top-level-eval-hook 252}# + #{x 1711}# + #{mod 1616}#) + #{x 1711}#))) (lambda () - (#{build-global-definition 281}# - #{s 1599}# - #{n 1682}# - (#{chi 419}# - #{e 1597}# - #{r 1571}# - #{w 1598}# - #{mod 1600}#)))) - #{exps 1577}#)) - (if (eqv? #{type 1684}# - 'displaced-lexical) + (#{build-global-definition 283}# + #{s 1615}# + #{n 1698}# + (#{chi 423}# + #{e 1613}# + #{r 1587}# + #{w 1614}# + #{mod 1616}#)))) + #{exps 1593}#)) + (if (memv #{type 1700}# + '(displaced-lexical)) (syntax-violation #f "identifier out of context" - #{e 1597}# - (#{wrap 405}# - #{value 1596}# - #{w 1598}# - #{mod 1600}#)) + #{e 1613}# + (#{wrap 409}# + #{value 1612}# + #{w 1614}# + #{mod 1616}#)) (syntax-violation #f "cannot define keyword at top level" - #{e 1597}# - (#{wrap 405}# - #{value 1596}# - #{w 1598}# - #{mod 1600}#)))))))) - (cons (if (eq? #{m 1574}# 'c&e) + #{e 1613}# + (#{wrap 409}# + #{value 1612}# + #{w 1614}# + #{mod 1616}#)))))))) + (cons (if (eq? #{m 1590}# 'c&e) (begin - (let ((#{x 1700}# - (#{chi-expr 421}# - #{type 1595}# - #{value 1596}# - #{e 1597}# - #{r 1571}# - #{w 1598}# - #{s 1599}# - #{mod 1600}#))) + (let ((#{x 1716}# + (#{chi-expr 425}# + #{type 1611}# + #{value 1612}# + #{e 1613}# + #{r 1587}# + #{w 1614}# + #{s 1615}# + #{mod 1616}#))) (begin - (#{top-level-eval-hook 250}# - #{x 1700}# - #{mod 1600}#) - #{x 1700}#))) + (#{top-level-eval-hook 252}# + #{x 1716}# + #{mod 1616}#) + #{x 1716}#))) (lambda () - (#{chi-expr 421}# - #{type 1595}# - #{value 1596}# - #{e 1597}# - #{r 1571}# - #{w 1598}# - #{s 1599}# - #{mod 1600}#))) - #{exps 1577}#))))))))) - (lambda (#{exps 1701}#) - (#{scan 1569}# - (cdr #{body 1570}#) - #{r 1571}# - #{w 1572}# - #{s 1573}# - #{m 1574}# - #{esew 1575}# - #{mod 1576}# - #{exps 1701}#))))))) + (#{chi-expr 425}# + #{type 1611}# + #{value 1612}# + #{e 1613}# + #{r 1587}# + #{w 1614}# + #{s 1615}# + #{mod 1616}#))) + #{exps 1593}#))))))))) + (lambda (#{exps 1717}#) + (#{scan 1585}# + (cdr #{body 1586}#) + #{r 1587}# + #{w 1588}# + #{s 1589}# + #{m 1590}# + #{esew 1591}# + #{mod 1592}# + #{exps 1717}#))))))) (begin (call-with-values (lambda () - (#{scan 1569}# - #{body 1554}# - #{r 1555}# - #{w 1556}# - #{s 1557}# - #{m 1558}# - #{esew 1559}# - #{mod 1560}# + (#{scan 1585}# + #{body 1570}# + #{r 1571}# + #{w 1572}# + #{s 1573}# + #{m 1574}# + #{esew 1575}# + #{mod 1576}# '())) - (lambda (#{exps 1703}#) - (if (null? #{exps 1703}#) - (#{build-void 263}# #{s 1557}#) - (#{build-sequence 293}# - #{s 1557}# + (lambda (#{exps 1719}#) + (if (null? #{exps 1719}#) + (#{build-void 265}# #{s 1573}#) + (#{build-sequence 297}# + #{s 1573}# (letrec* - ((#{lp 1708}# - (lambda (#{in 1709}# #{out 1710}#) - (if (null? #{in 1709}#) - #{out 1710}# + ((#{lp 1724}# + (lambda (#{in 1725}# #{out 1726}#) + (if (null? #{in 1725}#) + #{out 1726}# (begin - (let ((#{e 1712}# (car #{in 1709}#))) - (#{lp 1708}# - (cdr #{in 1709}#) - (cons (if (procedure? #{e 1712}#) - (#{e 1712}#) - #{e 1712}#) - #{out 1710}#)))))))) - (begin (#{lp 1708}# #{exps 1703}# '()))))))))))) - (#{chi-install-global 413}# - (lambda (#{name 1713}# #{e 1714}#) - (#{build-global-definition 281}# + (let ((#{e 1728}# (car #{in 1725}#))) + (#{lp 1724}# + (cdr #{in 1725}#) + (cons (if (procedure? #{e 1728}#) + (#{e 1728}#) + #{e 1728}#) + #{out 1726}#)))))))) + (begin (#{lp 1724}# #{exps 1719}# '()))))))))))) + (#{chi-install-global 417}# + (lambda (#{name 1729}# #{e 1730}#) + (#{build-global-definition 283}# #f - #{name 1713}# - (#{build-application 265}# + #{name 1729}# + (#{build-primcall 291}# #f - (#{build-primref 289}# - #f - 'make-syntax-transformer) - (list (#{build-data 291}# #f #{name 1713}#) - (#{build-data 291}# #f 'macro) - #{e 1714}#))))) - (#{chi-when-list 415}# - (lambda (#{e 1722}# #{when-list 1723}# #{w 1724}#) + 'make-syntax-transformer + (list (#{build-data 295}# #f #{name 1729}#) + (#{build-data 295}# #f 'macro) + #{e 1730}#))))) + (#{chi-when-list 419}# + (lambda (#{e 1737}# #{when-list 1738}# #{w 1739}#) (letrec* - ((#{f 1731}# - (lambda (#{when-list 1732}# #{situations 1733}#) - (if (null? #{when-list 1732}#) - #{situations 1733}# - (#{f 1731}# - (cdr #{when-list 1732}#) + ((#{f 1746}# + (lambda (#{when-list 1747}# #{situations 1748}#) + (if (null? #{when-list 1747}#) + #{situations 1748}# + (#{f 1746}# + (cdr #{when-list 1747}#) (cons (begin - (let ((#{x 1735}# (car #{when-list 1732}#))) - (if (#{free-id=? 395}# - #{x 1735}# + (let ((#{x 1750}# (car #{when-list 1747}#))) + (if (#{free-id=? 399}# + #{x 1750}# '#(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i1734")) + #(ribcage #(x) #((top)) #("i1749")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) - #("i1728" "i1729" "i1730")) + #("i1743" "i1744" "i1745")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) - #("i1725" "i1726" "i1727")) + #("i1740" "i1741" "i1742")) #(ribcage (lambda-var-list gen-var @@ -1531,7 +1536,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -1609,6 +1614,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -1620,7 +1626,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -1642,7 +1648,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -1789,8 +1796,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -1823,14 +1834,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -1838,33 +1849,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -1897,17 +1908,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -1934,25 +1945,25 @@ ("i40" "i39" "i38"))) (hygiene guile))) 'compile - (if (#{free-id=? 395}# - #{x 1735}# + (if (#{free-id=? 399}# + #{x 1750}# '#(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i1734")) + #(ribcage #(x) #((top)) #("i1749")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) - #("i1728" "i1729" "i1730")) + #("i1743" "i1744" "i1745")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) - #("i1725" "i1726" "i1727")) + #("i1740" "i1741" "i1742")) #(ribcage (lambda-var-list gen-var @@ -1967,7 +1978,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -2045,6 +2056,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -2056,7 +2068,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -2078,7 +2090,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -2225,8 +2238,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -2259,14 +2276,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -2274,33 +2291,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -2333,17 +2350,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -2370,25 +2387,25 @@ ("i40" "i39" "i38"))) (hygiene guile))) 'load - (if (#{free-id=? 395}# - #{x 1735}# + (if (#{free-id=? 399}# + #{x 1750}# '#(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i1734")) + #(ribcage #(x) #((top)) #("i1749")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) - #("i1728" "i1729" "i1730")) + #("i1743" "i1744" "i1745")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) - #("i1725" "i1726" "i1727")) + #("i1740" "i1741" "i1742")) #(ribcage (lambda-var-list gen-var @@ -2403,7 +2420,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -2481,6 +2498,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -2492,7 +2510,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -2514,7 +2532,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -2661,8 +2680,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -2695,14 +2718,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -2710,33 +2733,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -2769,17 +2792,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -2806,25 +2829,25 @@ ("i40" "i39" "i38"))) (hygiene guile))) 'eval - (if (#{free-id=? 395}# - #{x 1735}# + (if (#{free-id=? 399}# + #{x 1750}# '#(syntax-object expand ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i1734")) + #(ribcage #(x) #((top)) #("i1749")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) - #("i1728" "i1729" "i1730")) + #("i1743" "i1744" "i1745")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) - #("i1725" "i1726" "i1727")) + #("i1740" "i1741" "i1742")) #(ribcage (lambda-var-list gen-var @@ -2839,7 +2862,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -2917,6 +2940,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -2928,7 +2952,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -2950,7 +2974,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -3097,8 +3122,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -3131,14 +3160,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -3146,33 +3175,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -3205,17 +3234,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -3245,243 +3274,243 @@ (syntax-violation 'eval-when "invalid situation" - #{e 1722}# - (#{wrap 405}# - #{x 1735}# - #{w 1724}# + #{e 1737}# + (#{wrap 409}# + #{x 1750}# + #{w 1739}# #f)))))))) - #{situations 1733}#)))))) - (begin (#{f 1731}# #{when-list 1723}# '()))))) - (#{syntax-type 417}# - (lambda (#{e 1745}# - #{r 1746}# - #{w 1747}# - #{s 1748}# - #{rib 1749}# - #{mod 1750}# - #{for-car? 1751}#) - (if (symbol? #{e 1745}#) + #{situations 1748}#)))))) + (begin (#{f 1746}# #{when-list 1738}# '()))))) + (#{syntax-type 421}# + (lambda (#{e 1760}# + #{r 1761}# + #{w 1762}# + #{s 1763}# + #{rib 1764}# + #{mod 1765}# + #{for-car? 1766}#) + (if (symbol? #{e 1760}#) (begin - (let ((#{n 1763}# - (#{id-var-name 393}# #{e 1745}# #{w 1747}#))) + (let ((#{n 1778}# + (#{id-var-name 397}# #{e 1760}# #{w 1762}#))) (begin - (let ((#{b 1765}# - (#{lookup 333}# - #{n 1763}# - #{r 1746}# - #{mod 1750}#))) + (let ((#{b 1780}# + (#{lookup 337}# + #{n 1778}# + #{r 1761}# + #{mod 1765}#))) (begin - (let ((#{type 1767}# (car #{b 1765}#))) - (if (eqv? #{type 1767}# 'lexical) + (let ((#{type 1782}# (car #{b 1780}#))) + (if (memv #{type 1782}# '(lexical)) (values - #{type 1767}# - (cdr #{b 1765}#) - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#) - (if (eqv? #{type 1767}# 'global) + #{type 1782}# + (cdr #{b 1780}#) + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#) + (if (memv #{type 1782}# '(global)) (values - #{type 1767}# - #{n 1763}# - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#) - (if (eqv? #{type 1767}# 'macro) - (if #{for-car? 1751}# + #{type 1782}# + #{n 1778}# + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#) + (if (memv #{type 1782}# '(macro)) + (if #{for-car? 1766}# (values - #{type 1767}# - (cdr #{b 1765}#) - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#) - (#{syntax-type 417}# - (#{chi-macro 425}# - (cdr #{b 1765}#) - #{e 1745}# - #{r 1746}# - #{w 1747}# - #{s 1748}# - #{rib 1749}# - #{mod 1750}#) - #{r 1746}# + #{type 1782}# + (cdr #{b 1780}#) + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#) + (#{syntax-type 421}# + (#{chi-macro 429}# + (cdr #{b 1780}#) + #{e 1760}# + #{r 1761}# + #{w 1762}# + #{s 1763}# + #{rib 1764}# + #{mod 1765}#) + #{r 1761}# '(()) - #{s 1748}# - #{rib 1749}# - #{mod 1750}# + #{s 1763}# + #{rib 1764}# + #{mod 1765}# #f)) (values - #{type 1767}# - (cdr #{b 1765}#) - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#)))))))))) - (if (pair? #{e 1745}#) + #{type 1782}# + (cdr #{b 1780}#) + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#)))))))))) + (if (pair? #{e 1760}#) (begin - (let ((#{first 1781}# (car #{e 1745}#))) + (let ((#{first 1796}# (car #{e 1760}#))) (call-with-values (lambda () - (#{syntax-type 417}# - #{first 1781}# - #{r 1746}# - #{w 1747}# - #{s 1748}# - #{rib 1749}# - #{mod 1750}# + (#{syntax-type 421}# + #{first 1796}# + #{r 1761}# + #{w 1762}# + #{s 1763}# + #{rib 1764}# + #{mod 1765}# #t)) - (lambda (#{ftype 1782}# - #{fval 1783}# - #{fe 1784}# - #{fw 1785}# - #{fs 1786}# - #{fmod 1787}#) - (if (eqv? #{ftype 1782}# 'lexical) + (lambda (#{ftype 1797}# + #{fval 1798}# + #{fe 1799}# + #{fw 1800}# + #{fs 1801}# + #{fmod 1802}#) + (if (memv #{ftype 1797}# '(lexical)) (values 'lexical-call - #{fval 1783}# - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#) - (if (eqv? #{ftype 1782}# 'global) + #{fval 1798}# + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#) + (if (memv #{ftype 1797}# '(global)) (values 'global-call - (#{make-syntax-object 303}# - #{fval 1783}# - #{w 1747}# - #{fmod 1787}#) - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#) - (if (eqv? #{ftype 1782}# 'macro) - (#{syntax-type 417}# - (#{chi-macro 425}# - #{fval 1783}# - #{e 1745}# - #{r 1746}# - #{w 1747}# - #{s 1748}# - #{rib 1749}# - #{mod 1750}#) - #{r 1746}# + (#{make-syntax-object 307}# + #{fval 1798}# + #{w 1762}# + #{fmod 1802}#) + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#) + (if (memv #{ftype 1797}# '(macro)) + (#{syntax-type 421}# + (#{chi-macro 429}# + #{fval 1798}# + #{e 1760}# + #{r 1761}# + #{w 1762}# + #{s 1763}# + #{rib 1764}# + #{mod 1765}#) + #{r 1761}# '(()) - #{s 1748}# - #{rib 1749}# - #{mod 1750}# - #{for-car? 1751}#) - (if (eqv? #{ftype 1782}# 'module-ref) + #{s 1763}# + #{rib 1764}# + #{mod 1765}# + #{for-car? 1766}#) + (if (memv #{ftype 1797}# '(module-ref)) (call-with-values (lambda () - (#{fval 1783}# - #{e 1745}# - #{r 1746}# - #{w 1747}#)) - (lambda (#{e 1799}# - #{r 1800}# - #{w 1801}# - #{s 1802}# - #{mod 1803}#) - (#{syntax-type 417}# - #{e 1799}# - #{r 1800}# - #{w 1801}# - #{s 1802}# - #{rib 1749}# - #{mod 1803}# - #{for-car? 1751}#))) - (if (eqv? #{ftype 1782}# 'core) + (#{fval 1798}# + #{e 1760}# + #{r 1761}# + #{w 1762}#)) + (lambda (#{e 1814}# + #{r 1815}# + #{w 1816}# + #{s 1817}# + #{mod 1818}#) + (#{syntax-type 421}# + #{e 1814}# + #{r 1815}# + #{w 1816}# + #{s 1817}# + #{rib 1764}# + #{mod 1818}# + #{for-car? 1766}#))) + (if (memv #{ftype 1797}# '(core)) (values 'core-form - #{fval 1783}# - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#) - (if (eqv? #{ftype 1782}# 'local-syntax) + #{fval 1798}# + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#) + (if (memv #{ftype 1797}# '(local-syntax)) (values 'local-syntax-form - #{fval 1783}# - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#) - (if (eqv? #{ftype 1782}# 'begin) + #{fval 1798}# + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#) + (if (memv #{ftype 1797}# '(begin)) (values 'begin-form #f - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#) - (if (eqv? #{ftype 1782}# 'eval-when) + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#) + (if (memv #{ftype 1797}# '(eval-when)) (values 'eval-when-form #f - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#) - (if (eqv? #{ftype 1782}# 'define) - (let ((#{tmp 1814}# #{e 1745}#)) - (let ((#{tmp 1815}# + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#) + (if (memv #{ftype 1797}# '(define)) + (let ((#{tmp 1829}# #{e 1760}#)) + (let ((#{tmp 1830}# ($sc-dispatch - #{tmp 1814}# + #{tmp 1829}# '(_ any any)))) - (if (if #{tmp 1815}# + (if (if #{tmp 1830}# (@apply - (lambda (#{name 1818}# - #{val 1819}#) - (#{id? 339}# #{name 1818}#)) - #{tmp 1815}#) + (lambda (#{name 1833}# + #{val 1834}#) + (#{id? 343}# #{name 1833}#)) + #{tmp 1830}#) #f) (@apply - (lambda (#{name 1822}# - #{val 1823}#) + (lambda (#{name 1837}# + #{val 1838}#) (values 'define-form - #{name 1822}# - #{val 1823}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#)) - #{tmp 1815}#) - (let ((#{tmp 1824}# + #{name 1837}# + #{val 1838}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#)) + #{tmp 1830}#) + (let ((#{tmp 1839}# ($sc-dispatch - #{tmp 1814}# + #{tmp 1829}# '(_ (any . any) any . each-any)))) - (if (if #{tmp 1824}# + (if (if #{tmp 1839}# (@apply - (lambda (#{name 1829}# - #{args 1830}# - #{e1 1831}# - #{e2 1832}#) - (if (#{id? 339}# - #{name 1829}#) - (#{valid-bound-ids? 399}# - (#{lambda-var-list 449}# - #{args 1830}#)) + (lambda (#{name 1844}# + #{args 1845}# + #{e1 1846}# + #{e2 1847}#) + (if (#{id? 343}# + #{name 1844}#) + (#{valid-bound-ids? 403}# + (#{lambda-var-list 453}# + #{args 1845}#)) #f)) - #{tmp 1824}#) + #{tmp 1839}#) #f) (@apply - (lambda (#{name 1839}# - #{args 1840}# - #{e1 1841}# - #{e2 1842}#) + (lambda (#{name 1854}# + #{args 1855}# + #{e1 1856}# + #{e2 1857}#) (values 'define-form - (#{wrap 405}# - #{name 1839}# - #{w 1747}# - #{mod 1750}#) - (#{decorate-source 259}# + (#{wrap 409}# + #{name 1854}# + #{w 1762}# + #{mod 1765}#) + (#{decorate-source 261}# (cons '#(syntax-object lambda ((top) @@ -3494,10 +3523,10 @@ (top) (top) (top)) - #("i1835" - "i1836" - "i1837" - "i1838")) + #("i1850" + "i1851" + "i1852" + "i1853")) #(ribcage () () @@ -3519,12 +3548,12 @@ (top) (top) (top)) - #("i1788" - "i1789" - "i1790" - "i1791" - "i1792" - "i1793")) + #("i1803" + "i1804" + "i1805" + "i1806" + "i1807" + "i1808")) #(ribcage () () @@ -3532,7 +3561,7 @@ #(ribcage #(first) #((top)) - #("i1780")) + #("i1795")) #(ribcage () () @@ -3560,13 +3589,13 @@ (top) (top) (top)) - #("i1752" - "i1753" - "i1754" - "i1755" - "i1756" - "i1757" - "i1758")) + #("i1767" + "i1768" + "i1769" + "i1770" + "i1771" + "i1772" + "i1773")) #(ribcage (lambda-var-list gen-var @@ -3581,7 +3610,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -3659,6 +3688,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -3670,7 +3700,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -3692,7 +3722,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -3839,8 +3870,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -3873,14 +3908,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -3888,33 +3923,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -3947,17 +3982,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -3988,43 +4023,43 @@ "i38"))) (hygiene guile)) - (#{wrap 405}# - (cons #{args 1840}# - (cons #{e1 1841}# - #{e2 1842}#)) - #{w 1747}# - #{mod 1750}#)) - #{s 1748}#) + (#{wrap 409}# + (cons #{args 1855}# + (cons #{e1 1856}# + #{e2 1857}#)) + #{w 1762}# + #{mod 1765}#)) + #{s 1763}#) '(()) - #{s 1748}# - #{mod 1750}#)) - #{tmp 1824}#) - (let ((#{tmp 1845}# + #{s 1763}# + #{mod 1765}#)) + #{tmp 1839}#) + (let ((#{tmp 1860}# ($sc-dispatch - #{tmp 1814}# + #{tmp 1829}# '(_ any)))) - (if (if #{tmp 1845}# + (if (if #{tmp 1860}# (@apply - (lambda (#{name 1847}#) - (#{id? 339}# - #{name 1847}#)) - #{tmp 1845}#) + (lambda (#{name 1862}#) + (#{id? 343}# + #{name 1862}#)) + #{tmp 1860}#) #f) (@apply - (lambda (#{name 1849}#) + (lambda (#{name 1864}#) (values 'define-form - (#{wrap 405}# - #{name 1849}# - #{w 1747}# - #{mod 1750}#) + (#{wrap 409}# + #{name 1864}# + #{w 1762}# + #{mod 1765}#) '(#(syntax-object if ((top) #(ribcage #(name) #((top)) - #("i1848")) + #("i1863")) #(ribcage () () @@ -4046,12 +4081,12 @@ (top) (top) (top)) - #("i1788" - "i1789" - "i1790" - "i1791" - "i1792" - "i1793")) + #("i1803" + "i1804" + "i1805" + "i1806" + "i1807" + "i1808")) #(ribcage () () @@ -4059,7 +4094,7 @@ #(ribcage #(first) #((top)) - #("i1780")) + #("i1795")) #(ribcage () () @@ -4087,13 +4122,13 @@ (top) (top) (top)) - #("i1752" - "i1753" - "i1754" - "i1755" - "i1756" - "i1757" - "i1758")) + #("i1767" + "i1768" + "i1769" + "i1770" + "i1771" + "i1772" + "i1773")) #(ribcage (lambda-var-list gen-var @@ -4108,7 +4143,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -4186,6 +4221,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -4197,7 +4233,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -4219,7 +4255,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -4366,8 +4403,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -4400,14 +4441,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -4415,33 +4456,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -4474,17 +4515,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -4520,7 +4561,7 @@ #(ribcage #(name) #((top)) - #("i1848")) + #("i1863")) #(ribcage () () @@ -4542,12 +4583,12 @@ (top) (top) (top)) - #("i1788" - "i1789" - "i1790" - "i1791" - "i1792" - "i1793")) + #("i1803" + "i1804" + "i1805" + "i1806" + "i1807" + "i1808")) #(ribcage () () @@ -4555,7 +4596,7 @@ #(ribcage #(first) #((top)) - #("i1780")) + #("i1795")) #(ribcage () () @@ -4583,13 +4624,13 @@ (top) (top) (top)) - #("i1752" - "i1753" - "i1754" - "i1755" - "i1756" - "i1757" - "i1758")) + #("i1767" + "i1768" + "i1769" + "i1770" + "i1771" + "i1772" + "i1773")) #(ribcage (lambda-var-list gen-var @@ -4604,7 +4645,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -4682,6 +4723,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -4693,7 +4735,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -4715,7 +4757,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -4862,8 +4905,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -4896,14 +4943,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -4911,33 +4958,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -4970,17 +5017,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -5016,7 +5063,7 @@ #(ribcage #(name) #((top)) - #("i1848")) + #("i1863")) #(ribcage () () @@ -5038,12 +5085,12 @@ (top) (top) (top)) - #("i1788" - "i1789" - "i1790" - "i1791" - "i1792" - "i1793")) + #("i1803" + "i1804" + "i1805" + "i1806" + "i1807" + "i1808")) #(ribcage () () @@ -5051,7 +5098,7 @@ #(ribcage #(first) #((top)) - #("i1780")) + #("i1795")) #(ribcage () () @@ -5079,13 +5126,13 @@ (top) (top) (top)) - #("i1752" - "i1753" - "i1754" - "i1755" - "i1756" - "i1757" - "i1758")) + #("i1767" + "i1768" + "i1769" + "i1770" + "i1771" + "i1772" + "i1773")) #(ribcage (lambda-var-list gen-var @@ -5100,7 +5147,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -5178,6 +5225,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -5189,7 +5237,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -5211,7 +5259,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -5358,8 +5407,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -5392,14 +5445,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -5407,33 +5460,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -5466,17 +5519,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -5507,817 +5560,814 @@ "i38"))) (hygiene guile))) '(()) - #{s 1748}# - #{mod 1750}#)) - #{tmp 1845}#) + #{s 1763}# + #{mod 1765}#)) + #{tmp 1860}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 1814}#)))))))) - (if (eqv? #{ftype 1782}# 'define-syntax) - (let ((#{tmp 1852}# #{e 1745}#)) - (let ((#{tmp 1853}# + #{tmp 1829}#)))))))) + (if (memv #{ftype 1797}# '(define-syntax)) + (let ((#{tmp 1867}# #{e 1760}#)) + (let ((#{tmp 1868}# ($sc-dispatch - #{tmp 1852}# + #{tmp 1867}# '(_ any any)))) - (if (if #{tmp 1853}# + (if (if #{tmp 1868}# (@apply - (lambda (#{name 1856}# - #{val 1857}#) - (#{id? 339}# - #{name 1856}#)) - #{tmp 1853}#) + (lambda (#{name 1871}# + #{val 1872}#) + (#{id? 343}# + #{name 1871}#)) + #{tmp 1868}#) #f) (@apply - (lambda (#{name 1860}# - #{val 1861}#) + (lambda (#{name 1875}# + #{val 1876}#) (values 'define-syntax-form - #{name 1860}# - #{val 1861}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#)) - #{tmp 1853}#) + #{name 1875}# + #{val 1876}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#)) + #{tmp 1868}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 1852}#)))) + #{tmp 1867}#)))) (values 'call #f - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#))))))))))))))) - (if (#{syntax-object? 305}# #{e 1745}#) - (#{syntax-type 417}# - (#{syntax-object-expression 307}# #{e 1745}#) - #{r 1746}# - (#{join-wraps 387}# - #{w 1747}# - (#{syntax-object-wrap 309}# #{e 1745}#)) + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#))))))))))))))) + (if (#{syntax-object? 309}# #{e 1760}#) + (#{syntax-type 421}# + (#{syntax-object-expression 311}# #{e 1760}#) + #{r 1761}# + (#{join-wraps 391}# + #{w 1762}# + (#{syntax-object-wrap 313}# #{e 1760}#)) (begin - (let ((#{t 1867}# - (#{source-annotation 320}# #{e 1745}#))) - (if #{t 1867}# #{t 1867}# #{s 1748}#))) - #{rib 1749}# + (let ((#{t 1882}# + (#{source-annotation 324}# #{e 1760}#))) + (if #{t 1882}# #{t 1882}# #{s 1763}#))) + #{rib 1764}# (begin - (let ((#{t 1871}# - (#{syntax-object-module 311}# #{e 1745}#))) - (if #{t 1871}# #{t 1871}# #{mod 1750}#))) - #{for-car? 1751}#) - (if (self-evaluating? #{e 1745}#) + (let ((#{t 1886}# + (#{syntax-object-module 315}# #{e 1760}#))) + (if #{t 1886}# #{t 1886}# #{mod 1765}#))) + #{for-car? 1766}#) + (if (self-evaluating? #{e 1760}#) (values 'constant #f - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#) + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#) (values 'other #f - #{e 1745}# - #{w 1747}# - #{s 1748}# - #{mod 1750}#))))))) - (#{chi 419}# - (lambda (#{e 1876}# #{r 1877}# #{w 1878}# #{mod 1879}#) + #{e 1760}# + #{w 1762}# + #{s 1763}# + #{mod 1765}#))))))) + (#{chi 423}# + (lambda (#{e 1891}# #{r 1892}# #{w 1893}# #{mod 1894}#) (call-with-values (lambda () - (#{syntax-type 417}# - #{e 1876}# - #{r 1877}# - #{w 1878}# - (#{source-annotation 320}# #{e 1876}#) + (#{syntax-type 421}# + #{e 1891}# + #{r 1892}# + #{w 1893}# + (#{source-annotation 324}# #{e 1891}#) #f - #{mod 1879}# + #{mod 1894}# #f)) - (lambda (#{type 1884}# - #{value 1885}# - #{e 1886}# - #{w 1887}# - #{s 1888}# - #{mod 1889}#) - (#{chi-expr 421}# - #{type 1884}# - #{value 1885}# - #{e 1886}# - #{r 1877}# - #{w 1887}# - #{s 1888}# - #{mod 1889}#))))) - (#{chi-expr 421}# - (lambda (#{type 1896}# - #{value 1897}# - #{e 1898}# - #{r 1899}# - #{w 1900}# - #{s 1901}# - #{mod 1902}#) - (if (eqv? #{type 1896}# 'lexical) - (#{build-lexical-reference 271}# + (lambda (#{type 1899}# + #{value 1900}# + #{e 1901}# + #{w 1902}# + #{s 1903}# + #{mod 1904}#) + (#{chi-expr 425}# + #{type 1899}# + #{value 1900}# + #{e 1901}# + #{r 1892}# + #{w 1902}# + #{s 1903}# + #{mod 1904}#))))) + (#{chi-expr 425}# + (lambda (#{type 1911}# + #{value 1912}# + #{e 1913}# + #{r 1914}# + #{w 1915}# + #{s 1916}# + #{mod 1917}#) + (if (memv #{type 1911}# '(lexical)) + (#{build-lexical-reference 273}# 'value - #{s 1901}# - #{e 1898}# - #{value 1897}#) - (if (if (eqv? #{type 1896}# 'core) - #t - (eqv? #{type 1896}# 'core-form)) - (#{value 1897}# - #{e 1898}# - #{r 1899}# - #{w 1900}# - #{s 1901}# - #{mod 1902}#) - (if (eqv? #{type 1896}# 'module-ref) + #{s 1916}# + #{e 1913}# + #{value 1912}#) + (if (memv #{type 1911}# '(core core-form)) + (#{value 1912}# + #{e 1913}# + #{r 1914}# + #{w 1915}# + #{s 1916}# + #{mod 1917}#) + (if (memv #{type 1911}# '(module-ref)) (call-with-values (lambda () - (#{value 1897}# #{e 1898}# #{r 1899}# #{w 1900}#)) - (lambda (#{e 1913}# - #{r 1914}# - #{w 1915}# - #{s 1916}# - #{mod 1917}#) - (#{chi 419}# + (#{value 1912}# #{e 1913}# #{r 1914}# #{w 1915}#)) + (lambda (#{e 1928}# + #{r 1929}# + #{w 1930}# + #{s 1931}# + #{mod 1932}#) + (#{chi 423}# + #{e 1928}# + #{r 1929}# + #{w 1930}# + #{mod 1932}#))) + (if (memv #{type 1911}# '(lexical-call)) + (#{chi-call 427}# + (begin + (let ((#{id 1940}# (car #{e 1913}#))) + (#{build-lexical-reference 273}# + 'fun + (#{source-annotation 324}# #{id 1940}#) + (if (#{syntax-object? 309}# #{id 1940}#) + (syntax->datum #{id 1940}#) + #{id 1940}#) + #{value 1912}#))) + #{e 1913}# + #{r 1914}# + #{w 1915}# + #{s 1916}# + #{mod 1917}#) + (if (memv #{type 1911}# '(global-call)) + (#{chi-call 427}# + (#{build-global-reference 279}# + (#{source-annotation 324}# (car #{e 1913}#)) + (if (#{syntax-object? 309}# #{value 1912}#) + (#{syntax-object-expression 311}# #{value 1912}#) + #{value 1912}#) + (if (#{syntax-object? 309}# #{value 1912}#) + (#{syntax-object-module 315}# #{value 1912}#) + #{mod 1917}#)) #{e 1913}# #{r 1914}# #{w 1915}# - #{mod 1917}#))) - (if (eqv? #{type 1896}# 'lexical-call) - (#{chi-application 423}# - (begin - (let ((#{id 1925}# (car #{e 1898}#))) - (#{build-lexical-reference 271}# - 'fun - (#{source-annotation 320}# #{id 1925}#) - (if (#{syntax-object? 305}# #{id 1925}#) - (syntax->datum #{id 1925}#) - #{id 1925}#) - #{value 1897}#))) - #{e 1898}# - #{r 1899}# - #{w 1900}# - #{s 1901}# - #{mod 1902}#) - (if (eqv? #{type 1896}# 'global-call) - (#{chi-application 423}# - (#{build-global-reference 277}# - (#{source-annotation 320}# (car #{e 1898}#)) - (if (#{syntax-object? 305}# #{value 1897}#) - (#{syntax-object-expression 307}# #{value 1897}#) - #{value 1897}#) - (if (#{syntax-object? 305}# #{value 1897}#) - (#{syntax-object-module 311}# #{value 1897}#) - #{mod 1902}#)) - #{e 1898}# - #{r 1899}# - #{w 1900}# - #{s 1901}# - #{mod 1902}#) - (if (eqv? #{type 1896}# 'constant) - (#{build-data 291}# - #{s 1901}# - (#{strip 445}# - (#{source-wrap 407}# - #{e 1898}# - #{w 1900}# - #{s 1901}# - #{mod 1902}#) + #{s 1916}# + #{mod 1917}#) + (if (memv #{type 1911}# '(constant)) + (#{build-data 295}# + #{s 1916}# + (#{strip 449}# + (#{source-wrap 411}# + #{e 1913}# + #{w 1915}# + #{s 1916}# + #{mod 1917}#) '(()))) - (if (eqv? #{type 1896}# 'global) - (#{build-global-reference 277}# - #{s 1901}# - #{value 1897}# - #{mod 1902}#) - (if (eqv? #{type 1896}# 'call) - (#{chi-application 423}# - (#{chi 419}# - (car #{e 1898}#) - #{r 1899}# - #{w 1900}# - #{mod 1902}#) - #{e 1898}# - #{r 1899}# - #{w 1900}# - #{s 1901}# - #{mod 1902}#) - (if (eqv? #{type 1896}# 'begin-form) - (let ((#{tmp 1932}# #{e 1898}#)) - (let ((#{tmp 1933}# + (if (memv #{type 1911}# '(global)) + (#{build-global-reference 279}# + #{s 1916}# + #{value 1912}# + #{mod 1917}#) + (if (memv #{type 1911}# '(call)) + (#{chi-call 427}# + (#{chi 423}# + (car #{e 1913}#) + #{r 1914}# + #{w 1915}# + #{mod 1917}#) + #{e 1913}# + #{r 1914}# + #{w 1915}# + #{s 1916}# + #{mod 1917}#) + (if (memv #{type 1911}# '(begin-form)) + (let ((#{tmp 1947}# #{e 1913}#)) + (let ((#{tmp 1948}# ($sc-dispatch - #{tmp 1932}# + #{tmp 1947}# '(_ any . each-any)))) - (if #{tmp 1933}# + (if #{tmp 1948}# (@apply - (lambda (#{e1 1936}# #{e2 1937}#) - (#{chi-sequence 409}# - (cons #{e1 1936}# #{e2 1937}#) - #{r 1899}# - #{w 1900}# - #{s 1901}# - #{mod 1902}#)) - #{tmp 1933}#) + (lambda (#{e1 1951}# #{e2 1952}#) + (#{chi-sequence 413}# + (cons #{e1 1951}# #{e2 1952}#) + #{r 1914}# + #{w 1915}# + #{s 1916}# + #{mod 1917}#)) + #{tmp 1948}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 1932}#)))) - (if (eqv? #{type 1896}# 'local-syntax-form) - (#{chi-local-syntax 429}# - #{value 1897}# - #{e 1898}# - #{r 1899}# - #{w 1900}# - #{s 1901}# - #{mod 1902}# - #{chi-sequence 409}#) - (if (eqv? #{type 1896}# 'eval-when-form) - (let ((#{tmp 1941}# #{e 1898}#)) - (let ((#{tmp 1942}# + #{tmp 1947}#)))) + (if (memv #{type 1911}# '(local-syntax-form)) + (#{chi-local-syntax 433}# + #{value 1912}# + #{e 1913}# + #{r 1914}# + #{w 1915}# + #{s 1916}# + #{mod 1917}# + #{chi-sequence 413}#) + (if (memv #{type 1911}# '(eval-when-form)) + (let ((#{tmp 1956}# #{e 1913}#)) + (let ((#{tmp 1957}# ($sc-dispatch - #{tmp 1941}# + #{tmp 1956}# '(_ each-any any . each-any)))) - (if #{tmp 1942}# + (if #{tmp 1957}# (@apply - (lambda (#{x 1946}# - #{e1 1947}# - #{e2 1948}#) + (lambda (#{x 1961}# + #{e1 1962}# + #{e2 1963}#) (begin - (let ((#{when-list 1950}# - (#{chi-when-list 415}# - #{e 1898}# - #{x 1946}# - #{w 1900}#))) - (if (memq 'eval #{when-list 1950}#) - (#{chi-sequence 409}# - (cons #{e1 1947}# #{e2 1948}#) - #{r 1899}# - #{w 1900}# - #{s 1901}# - #{mod 1902}#) - (#{chi-void 433}#))))) - #{tmp 1942}#) + (let ((#{when-list 1965}# + (#{chi-when-list 419}# + #{e 1913}# + #{x 1961}# + #{w 1915}#))) + (if (memq 'eval #{when-list 1965}#) + (#{chi-sequence 413}# + (cons #{e1 1962}# #{e2 1963}#) + #{r 1914}# + #{w 1915}# + #{s 1916}# + #{mod 1917}#) + (#{chi-void 437}#))))) + #{tmp 1957}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 1941}#)))) - (if (if (eqv? #{type 1896}# 'define-form) - #t - (eqv? #{type 1896}# 'define-syntax-form)) + #{tmp 1956}#)))) + (if (memv #{type 1911}# + '(define-form define-syntax-form)) (syntax-violation #f "definition in expression context" - #{e 1898}# - (#{wrap 405}# - #{value 1897}# - #{w 1900}# - #{mod 1902}#)) - (if (eqv? #{type 1896}# 'syntax) + #{e 1913}# + (#{wrap 409}# + #{value 1912}# + #{w 1915}# + #{mod 1917}#)) + (if (memv #{type 1911}# '(syntax)) (syntax-violation #f "reference to pattern variable outside syntax form" - (#{source-wrap 407}# - #{e 1898}# - #{w 1900}# - #{s 1901}# - #{mod 1902}#)) - (if (eqv? #{type 1896}# 'displaced-lexical) + (#{source-wrap 411}# + #{e 1913}# + #{w 1915}# + #{s 1916}# + #{mod 1917}#)) + (if (memv #{type 1911}# '(displaced-lexical)) (syntax-violation #f "reference to identifier outside its scope" - (#{source-wrap 407}# - #{e 1898}# - #{w 1900}# - #{s 1901}# - #{mod 1902}#)) + (#{source-wrap 411}# + #{e 1913}# + #{w 1915}# + #{s 1916}# + #{mod 1917}#)) (syntax-violation #f "unexpected syntax" - (#{source-wrap 407}# - #{e 1898}# - #{w 1900}# - #{s 1901}# - #{mod 1902}#)))))))))))))))))) - (#{chi-application 423}# - (lambda (#{x 1957}# - #{e 1958}# - #{r 1959}# - #{w 1960}# - #{s 1961}# - #{mod 1962}#) - (let ((#{tmp 1969}# #{e 1958}#)) - (let ((#{tmp 1970}# - ($sc-dispatch #{tmp 1969}# '(any . each-any)))) - (if #{tmp 1970}# + (#{source-wrap 411}# + #{e 1913}# + #{w 1915}# + #{s 1916}# + #{mod 1917}#)))))))))))))))))) + (#{chi-call 427}# + (lambda (#{x 1972}# + #{e 1973}# + #{r 1974}# + #{w 1975}# + #{s 1976}# + #{mod 1977}#) + (let ((#{tmp 1984}# #{e 1973}#)) + (let ((#{tmp 1985}# + ($sc-dispatch #{tmp 1984}# '(any . each-any)))) + (if #{tmp 1985}# (@apply - (lambda (#{e0 1973}# #{e1 1974}#) - (#{build-application 265}# - #{s 1961}# - #{x 1957}# - (map (lambda (#{e 1975}#) - (#{chi 419}# - #{e 1975}# - #{r 1959}# - #{w 1960}# - #{mod 1962}#)) - #{e1 1974}#))) - #{tmp 1970}#) + (lambda (#{e0 1988}# #{e1 1989}#) + (#{build-call 267}# + #{s 1976}# + #{x 1972}# + (map (lambda (#{e 1990}#) + (#{chi 423}# + #{e 1990}# + #{r 1974}# + #{w 1975}# + #{mod 1977}#)) + #{e1 1989}#))) + #{tmp 1985}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 1969}#)))))) - (#{chi-macro 425}# - (lambda (#{p 1978}# - #{e 1979}# - #{r 1980}# - #{w 1981}# - #{s 1982}# - #{rib 1983}# - #{mod 1984}#) + #{tmp 1984}#)))))) + (#{chi-macro 429}# + (lambda (#{p 1993}# + #{e 1994}# + #{r 1995}# + #{w 1996}# + #{s 1997}# + #{rib 1998}# + #{mod 1999}#) (letrec* - ((#{rebuild-macro-output 1993}# - (lambda (#{x 1994}# #{m 1995}#) - (if (pair? #{x 1994}#) - (#{decorate-source 259}# - (cons (#{rebuild-macro-output 1993}# - (car #{x 1994}#) - #{m 1995}#) - (#{rebuild-macro-output 1993}# - (cdr #{x 1994}#) - #{m 1995}#)) - #{s 1982}#) - (if (#{syntax-object? 305}# #{x 1994}#) + ((#{rebuild-macro-output 2008}# + (lambda (#{x 2009}# #{m 2010}#) + (if (pair? #{x 2009}#) + (#{decorate-source 261}# + (cons (#{rebuild-macro-output 2008}# + (car #{x 2009}#) + #{m 2010}#) + (#{rebuild-macro-output 2008}# + (cdr #{x 2009}#) + #{m 2010}#)) + #{s 1997}#) + (if (#{syntax-object? 309}# #{x 2009}#) (begin - (let ((#{w 2003}# - (#{syntax-object-wrap 309}# #{x 1994}#))) + (let ((#{w 2018}# + (#{syntax-object-wrap 313}# #{x 2009}#))) (begin - (let ((#{ms 2006}# (car #{w 2003}#)) - (#{s 2007}# (cdr #{w 2003}#))) - (if (if (pair? #{ms 2006}#) - (eq? (car #{ms 2006}#) #f) + (let ((#{ms 2021}# (car #{w 2018}#)) + (#{s 2022}# (cdr #{w 2018}#))) + (if (if (pair? #{ms 2021}#) + (eq? (car #{ms 2021}#) #f) #f) - (#{make-syntax-object 303}# - (#{syntax-object-expression 307}# #{x 1994}#) - (cons (cdr #{ms 2006}#) - (if #{rib 1983}# - (cons #{rib 1983}# (cdr #{s 2007}#)) - (cdr #{s 2007}#))) - (#{syntax-object-module 311}# #{x 1994}#)) - (#{make-syntax-object 303}# - (#{decorate-source 259}# - (#{syntax-object-expression 307}# #{x 1994}#) - #{s 2007}#) - (cons (cons #{m 1995}# #{ms 2006}#) - (if #{rib 1983}# - (cons #{rib 1983}# - (cons 'shift #{s 2007}#)) - (cons 'shift #{s 2007}#))) - (#{syntax-object-module 311}# #{x 1994}#))))))) - (if (vector? #{x 1994}#) + (#{make-syntax-object 307}# + (#{syntax-object-expression 311}# #{x 2009}#) + (cons (cdr #{ms 2021}#) + (if #{rib 1998}# + (cons #{rib 1998}# (cdr #{s 2022}#)) + (cdr #{s 2022}#))) + (#{syntax-object-module 315}# #{x 2009}#)) + (#{make-syntax-object 307}# + (#{decorate-source 261}# + (#{syntax-object-expression 311}# #{x 2009}#) + #{s 2022}#) + (cons (cons #{m 2010}# #{ms 2021}#) + (if #{rib 1998}# + (cons #{rib 1998}# + (cons 'shift #{s 2022}#)) + (cons 'shift #{s 2022}#))) + (#{syntax-object-module 315}# #{x 2009}#))))))) + (if (vector? #{x 2009}#) (begin - (let ((#{n 2019}# (vector-length #{x 1994}#))) + (let ((#{n 2034}# (vector-length #{x 2009}#))) (begin - (let ((#{v 2021}# - (#{decorate-source 259}# - (make-vector #{n 2019}#) - #{x 1994}#))) + (let ((#{v 2036}# + (#{decorate-source 261}# + (make-vector #{n 2034}#) + #{x 2009}#))) (letrec* - ((#{loop 2024}# - (lambda (#{i 2025}#) - (if (= #{i 2025}# #{n 2019}#) - (begin (if #f #f) #{v 2021}#) + ((#{loop 2039}# + (lambda (#{i 2040}#) + (if (= #{i 2040}# #{n 2034}#) + (begin (if #f #f) #{v 2036}#) (begin (vector-set! - #{v 2021}# - #{i 2025}# - (#{rebuild-macro-output 1993}# - (vector-ref #{x 1994}# #{i 2025}#) - #{m 1995}#)) - (#{loop 2024}# (#{1+}# #{i 2025}#))))))) - (begin (#{loop 2024}# 0))))))) - (if (symbol? #{x 1994}#) + #{v 2036}# + #{i 2040}# + (#{rebuild-macro-output 2008}# + (vector-ref #{x 2009}# #{i 2040}#) + #{m 2010}#)) + (#{loop 2039}# (#{1+}# #{i 2040}#))))))) + (begin (#{loop 2039}# 0))))))) + (if (symbol? #{x 2009}#) (syntax-violation #f "encountered raw symbol in macro output" - (#{source-wrap 407}# - #{e 1979}# - #{w 1981}# - (cdr #{w 1981}#) - #{mod 1984}#) - #{x 1994}#) - (#{decorate-source 259}# #{x 1994}# #{s 1982}#)))))))) + (#{source-wrap 411}# + #{e 1994}# + #{w 1996}# + (cdr #{w 1996}#) + #{mod 1999}#) + #{x 2009}#) + (#{decorate-source 261}# #{x 2009}# #{s 1997}#)))))))) (begin - (#{rebuild-macro-output 1993}# - (#{p 1978}# - (#{source-wrap 407}# - #{e 1979}# - (#{anti-mark 377}# #{w 1981}#) - #{s 1982}# - #{mod 1984}#)) + (#{rebuild-macro-output 2008}# + (#{p 1993}# + (#{source-wrap 411}# + #{e 1994}# + (#{anti-mark 381}# #{w 1996}#) + #{s 1997}# + #{mod 1999}#)) (gensym "m")))))) - (#{chi-body 427}# - (lambda (#{body 2035}# - #{outer-form 2036}# - #{r 2037}# - #{w 2038}# - #{mod 2039}#) + (#{chi-body 431}# + (lambda (#{body 2050}# + #{outer-form 2051}# + #{r 2052}# + #{w 2053}# + #{mod 2054}#) (begin - (let ((#{r 2047}# - (cons '("placeholder" placeholder) #{r 2037}#))) + (let ((#{r 2062}# + (cons '("placeholder" placeholder) #{r 2052}#))) (begin - (let ((#{ribcage 2049}# - (#{make-ribcage 357}# '() '() '()))) + (let ((#{ribcage 2064}# + (#{make-ribcage 361}# '() '() '()))) (begin - (let ((#{w 2052}# - (cons (car #{w 2038}#) - (cons #{ribcage 2049}# (cdr #{w 2038}#))))) + (let ((#{w 2067}# + (cons (car #{w 2053}#) + (cons #{ribcage 2064}# (cdr #{w 2053}#))))) (letrec* - ((#{parse 2064}# - (lambda (#{body 2065}# - #{ids 2066}# - #{labels 2067}# - #{var-ids 2068}# - #{vars 2069}# - #{vals 2070}# - #{bindings 2071}#) - (if (null? #{body 2065}#) + ((#{parse 2079}# + (lambda (#{body 2080}# + #{ids 2081}# + #{labels 2082}# + #{var-ids 2083}# + #{vars 2084}# + #{vals 2085}# + #{bindings 2086}#) + (if (null? #{body 2080}#) (syntax-violation #f "no expressions in body" - #{outer-form 2036}#) + #{outer-form 2051}#) (begin - (let ((#{e 2076}# (cdr (car #{body 2065}#))) - (#{er 2077}# (car (car #{body 2065}#)))) + (let ((#{e 2091}# (cdr (car #{body 2080}#))) + (#{er 2092}# (car (car #{body 2080}#)))) (call-with-values (lambda () - (#{syntax-type 417}# - #{e 2076}# - #{er 2077}# + (#{syntax-type 421}# + #{e 2091}# + #{er 2092}# '(()) - (#{source-annotation 320}# #{er 2077}#) - #{ribcage 2049}# - #{mod 2039}# + (#{source-annotation 324}# #{er 2092}#) + #{ribcage 2064}# + #{mod 2054}# #f)) - (lambda (#{type 2079}# - #{value 2080}# - #{e 2081}# - #{w 2082}# - #{s 2083}# - #{mod 2084}#) - (if (eqv? #{type 2079}# 'define-form) + (lambda (#{type 2094}# + #{value 2095}# + #{e 2096}# + #{w 2097}# + #{s 2098}# + #{mod 2099}#) + (if (memv #{type 2094}# '(define-form)) (begin - (let ((#{id 2094}# - (#{wrap 405}# - #{value 2080}# - #{w 2082}# - #{mod 2084}#)) - (#{label 2095}# - (#{gen-label 352}#))) + (let ((#{id 2109}# + (#{wrap 409}# + #{value 2095}# + #{w 2097}# + #{mod 2099}#)) + (#{label 2110}# + (#{gen-label 356}#))) (begin - (let ((#{var 2097}# - (#{gen-var 447}# - #{id 2094}#))) + (let ((#{var 2112}# + (#{gen-var 451}# + #{id 2109}#))) (begin - (#{extend-ribcage! 381}# - #{ribcage 2049}# - #{id 2094}# - #{label 2095}#) - (#{parse 2064}# - (cdr #{body 2065}#) - (cons #{id 2094}# - #{ids 2066}#) - (cons #{label 2095}# - #{labels 2067}#) - (cons #{id 2094}# - #{var-ids 2068}#) - (cons #{var 2097}# - #{vars 2069}#) - (cons (cons #{er 2077}# - (#{wrap 405}# - #{e 2081}# - #{w 2082}# - #{mod 2084}#)) - #{vals 2070}#) + (#{extend-ribcage! 385}# + #{ribcage 2064}# + #{id 2109}# + #{label 2110}#) + (#{parse 2079}# + (cdr #{body 2080}#) + (cons #{id 2109}# + #{ids 2081}#) + (cons #{label 2110}# + #{labels 2082}#) + (cons #{id 2109}# + #{var-ids 2083}#) + (cons #{var 2112}# + #{vars 2084}#) + (cons (cons #{er 2092}# + (#{wrap 409}# + #{e 2096}# + #{w 2097}# + #{mod 2099}#)) + #{vals 2085}#) (cons (cons 'lexical - #{var 2097}#) - #{bindings 2071}#))))))) - (if (eqv? #{type 2079}# - 'define-syntax-form) + #{var 2112}#) + #{bindings 2086}#))))))) + (if (memv #{type 2094}# + '(define-syntax-form)) (begin - (let ((#{id 2102}# - (#{wrap 405}# - #{value 2080}# - #{w 2082}# - #{mod 2084}#)) - (#{label 2103}# - (#{gen-label 352}#))) + (let ((#{id 2117}# + (#{wrap 409}# + #{value 2095}# + #{w 2097}# + #{mod 2099}#)) + (#{label 2118}# + (#{gen-label 356}#))) (begin - (#{extend-ribcage! 381}# - #{ribcage 2049}# - #{id 2102}# - #{label 2103}#) - (#{parse 2064}# - (cdr #{body 2065}#) - (cons #{id 2102}# #{ids 2066}#) - (cons #{label 2103}# - #{labels 2067}#) - #{var-ids 2068}# - #{vars 2069}# - #{vals 2070}# + (#{extend-ribcage! 385}# + #{ribcage 2064}# + #{id 2117}# + #{label 2118}#) + (#{parse 2079}# + (cdr #{body 2080}#) + (cons #{id 2117}# #{ids 2081}#) + (cons #{label 2118}# + #{labels 2082}#) + #{var-ids 2083}# + #{vars 2084}# + #{vals 2085}# (cons (cons 'macro - (cons #{er 2077}# - (#{wrap 405}# - #{e 2081}# - #{w 2082}# - #{mod 2084}#))) - #{bindings 2071}#))))) - (if (eqv? #{type 2079}# 'begin-form) - (let ((#{tmp 2106}# #{e 2081}#)) - (let ((#{tmp 2107}# + (cons #{er 2092}# + (#{wrap 409}# + #{e 2096}# + #{w 2097}# + #{mod 2099}#))) + #{bindings 2086}#))))) + (if (memv #{type 2094}# '(begin-form)) + (let ((#{tmp 2121}# #{e 2096}#)) + (let ((#{tmp 2122}# ($sc-dispatch - #{tmp 2106}# + #{tmp 2121}# '(_ . each-any)))) - (if #{tmp 2107}# + (if #{tmp 2122}# (@apply - (lambda (#{e1 2109}#) - (#{parse 2064}# + (lambda (#{e1 2124}#) + (#{parse 2079}# (letrec* - ((#{f 2112}# - (lambda (#{forms 2113}#) - (if (null? #{forms 2113}#) - (cdr #{body 2065}#) - (cons (cons #{er 2077}# - (#{wrap 405}# - (car #{forms 2113}#) - #{w 2082}# - #{mod 2084}#)) - (#{f 2112}# - (cdr #{forms 2113}#))))))) + ((#{f 2127}# + (lambda (#{forms 2128}#) + (if (null? #{forms 2128}#) + (cdr #{body 2080}#) + (cons (cons #{er 2092}# + (#{wrap 409}# + (car #{forms 2128}#) + #{w 2097}# + #{mod 2099}#)) + (#{f 2127}# + (cdr #{forms 2128}#))))))) (begin - (#{f 2112}# - #{e1 2109}#))) - #{ids 2066}# - #{labels 2067}# - #{var-ids 2068}# - #{vars 2069}# - #{vals 2070}# - #{bindings 2071}#)) - #{tmp 2107}#) + (#{f 2127}# + #{e1 2124}#))) + #{ids 2081}# + #{labels 2082}# + #{var-ids 2083}# + #{vars 2084}# + #{vals 2085}# + #{bindings 2086}#)) + #{tmp 2122}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 2106}#)))) - (if (eqv? #{type 2079}# - 'local-syntax-form) - (#{chi-local-syntax 429}# - #{value 2080}# - #{e 2081}# - #{er 2077}# - #{w 2082}# - #{s 2083}# - #{mod 2084}# - (lambda (#{forms 2116}# - #{er 2117}# - #{w 2118}# - #{s 2119}# - #{mod 2120}#) - (#{parse 2064}# + #{tmp 2121}#)))) + (if (memv #{type 2094}# + '(local-syntax-form)) + (#{chi-local-syntax 433}# + #{value 2095}# + #{e 2096}# + #{er 2092}# + #{w 2097}# + #{s 2098}# + #{mod 2099}# + (lambda (#{forms 2131}# + #{er 2132}# + #{w 2133}# + #{s 2134}# + #{mod 2135}#) + (#{parse 2079}# (letrec* - ((#{f 2128}# - (lambda (#{forms 2129}#) - (if (null? #{forms 2129}#) - (cdr #{body 2065}#) - (cons (cons #{er 2117}# - (#{wrap 405}# - (car #{forms 2129}#) - #{w 2118}# - #{mod 2120}#)) - (#{f 2128}# - (cdr #{forms 2129}#))))))) + ((#{f 2143}# + (lambda (#{forms 2144}#) + (if (null? #{forms 2144}#) + (cdr #{body 2080}#) + (cons (cons #{er 2132}# + (#{wrap 409}# + (car #{forms 2144}#) + #{w 2133}# + #{mod 2135}#)) + (#{f 2143}# + (cdr #{forms 2144}#))))))) (begin - (#{f 2128}# - #{forms 2116}#))) - #{ids 2066}# - #{labels 2067}# - #{var-ids 2068}# - #{vars 2069}# - #{vals 2070}# - #{bindings 2071}#))) - (if (null? #{ids 2066}#) - (#{build-sequence 293}# + (#{f 2143}# + #{forms 2131}#))) + #{ids 2081}# + #{labels 2082}# + #{var-ids 2083}# + #{vars 2084}# + #{vals 2085}# + #{bindings 2086}#))) + (if (null? #{ids 2081}#) + (#{build-sequence 297}# #f - (map (lambda (#{x 2132}#) - (#{chi 419}# - (cdr #{x 2132}#) - (car #{x 2132}#) + (map (lambda (#{x 2147}#) + (#{chi 423}# + (cdr #{x 2147}#) + (car #{x 2147}#) '(()) - #{mod 2084}#)) - (cons (cons #{er 2077}# - (#{source-wrap 407}# - #{e 2081}# - #{w 2082}# - #{s 2083}# - #{mod 2084}#)) - (cdr #{body 2065}#)))) + #{mod 2099}#)) + (cons (cons #{er 2092}# + (#{source-wrap 411}# + #{e 2096}# + #{w 2097}# + #{s 2098}# + #{mod 2099}#)) + (cdr #{body 2080}#)))) (begin - (if (not (#{valid-bound-ids? 399}# - #{ids 2066}#)) + (if (not (#{valid-bound-ids? 403}# + #{ids 2081}#)) (syntax-violation #f "invalid or duplicate identifier in definition" - #{outer-form 2036}#)) + #{outer-form 2051}#)) (letrec* - ((#{loop 2139}# - (lambda (#{bs 2140}# - #{er-cache 2141}# - #{r-cache 2142}#) - (if (not (null? #{bs 2140}#)) + ((#{loop 2154}# + (lambda (#{bs 2155}# + #{er-cache 2156}# + #{r-cache 2157}#) + (if (not (null? #{bs 2155}#)) (begin - (let ((#{b 2145}# - (car #{bs 2140}#))) - (if (eq? (car #{b 2145}#) + (let ((#{b 2160}# + (car #{bs 2155}#))) + (if (eq? (car #{b 2160}#) 'macro) (begin - (let ((#{er 2148}# - (car (cdr #{b 2145}#)))) + (let ((#{er 2163}# + (car (cdr #{b 2160}#)))) (begin - (let ((#{r-cache 2150}# - (if (eq? #{er 2148}# - #{er-cache 2141}#) - #{r-cache 2142}# - (#{macros-only-env 331}# - #{er 2148}#)))) + (let ((#{r-cache 2165}# + (if (eq? #{er 2163}# + #{er-cache 2156}#) + #{r-cache 2157}# + (#{macros-only-env 335}# + #{er 2163}#)))) (begin (set-cdr! - #{b 2145}# - (#{eval-local-transformer 431}# - (#{chi 419}# - (cdr (cdr #{b 2145}#)) - #{r-cache 2150}# + #{b 2160}# + (#{eval-local-transformer 435}# + (#{chi 423}# + (cdr (cdr #{b 2160}#)) + #{r-cache 2165}# '(()) - #{mod 2084}#) - #{mod 2084}#)) - (#{loop 2139}# - (cdr #{bs 2140}#) - #{er 2148}# - #{r-cache 2150}#)))))) - (#{loop 2139}# - (cdr #{bs 2140}#) - #{er-cache 2141}# - #{r-cache 2142}#)))))))) + #{mod 2099}#) + #{mod 2099}#)) + (#{loop 2154}# + (cdr #{bs 2155}#) + #{er 2163}# + #{r-cache 2165}#)))))) + (#{loop 2154}# + (cdr #{bs 2155}#) + #{er-cache 2156}# + #{r-cache 2157}#)))))))) (begin - (#{loop 2139}# - #{bindings 2071}# + (#{loop 2154}# + #{bindings 2086}# #f #f))) (set-cdr! - #{r 2047}# - (#{extend-env 327}# - #{labels 2067}# - #{bindings 2071}# - (cdr #{r 2047}#))) - (#{build-letrec 299}# + #{r 2062}# + (#{extend-env 331}# + #{labels 2082}# + #{bindings 2086}# + (cdr #{r 2062}#))) + (#{build-letrec 303}# #f #t (reverse (map syntax->datum - #{var-ids 2068}#)) - (reverse #{vars 2069}#) - (map (lambda (#{x 2153}#) - (#{chi 419}# - (cdr #{x 2153}#) - (car #{x 2153}#) + #{var-ids 2083}#)) + (reverse #{vars 2084}#) + (map (lambda (#{x 2168}#) + (#{chi 423}# + (cdr #{x 2168}#) + (car #{x 2168}#) '(()) - #{mod 2084}#)) - (reverse #{vals 2070}#)) - (#{build-sequence 293}# + #{mod 2099}#)) + (reverse #{vals 2085}#)) + (#{build-sequence 297}# #f - (map (lambda (#{x 2157}#) - (#{chi 419}# - (cdr #{x 2157}#) - (car #{x 2157}#) + (map (lambda (#{x 2172}#) + (#{chi 423}# + (cdr #{x 2172}#) + (car #{x 2172}#) '(()) - #{mod 2084}#)) - (cons (cons #{er 2077}# - (#{source-wrap 407}# - #{e 2081}# - #{w 2082}# - #{s 2083}# - #{mod 2084}#)) - (cdr #{body 2065}#))))))))))))))))))) + #{mod 2099}#)) + (cons (cons #{er 2092}# + (#{source-wrap 411}# + #{e 2096}# + #{w 2097}# + #{s 2098}# + #{mod 2099}#)) + (cdr #{body 2080}#))))))))))))))))))) (begin - (#{parse 2064}# - (map (lambda (#{x 2072}#) - (cons #{r 2047}# - (#{wrap 405}# - #{x 2072}# - #{w 2052}# - #{mod 2039}#))) - #{body 2035}#) + (#{parse 2079}# + (map (lambda (#{x 2087}#) + (cons #{r 2062}# + (#{wrap 409}# + #{x 2087}# + #{w 2067}# + #{mod 2054}#))) + #{body 2050}#) '() '() '() '() '() '()))))))))))) - (#{chi-local-syntax 429}# - (lambda (#{rec? 2160}# - #{e 2161}# - #{r 2162}# - #{w 2163}# - #{s 2164}# - #{mod 2165}# - #{k 2166}#) - (let ((#{tmp 2174}# #{e 2161}#)) - (let ((#{tmp 2175}# + (#{chi-local-syntax 433}# + (lambda (#{rec? 2175}# + #{e 2176}# + #{r 2177}# + #{w 2178}# + #{s 2179}# + #{mod 2180}# + #{k 2181}#) + (let ((#{tmp 2189}# #{e 2176}#)) + (let ((#{tmp 2190}# ($sc-dispatch - #{tmp 2174}# + #{tmp 2189}# '(_ #(each (any any)) any . each-any)))) - (if #{tmp 2175}# + (if #{tmp 2190}# (@apply - (lambda (#{id 2180}# - #{val 2181}# - #{e1 2182}# - #{e2 2183}#) + (lambda (#{id 2195}# + #{val 2196}# + #{e1 2197}# + #{e2 2198}#) (begin - (let ((#{ids 2185}# #{id 2180}#)) - (if (not (#{valid-bound-ids? 399}# #{ids 2185}#)) + (let ((#{ids 2200}# #{id 2195}#)) + (if (not (#{valid-bound-ids? 403}# #{ids 2200}#)) (syntax-violation #f "duplicate bound keyword" - #{e 2161}#) + #{e 2176}#) (begin - (let ((#{labels 2188}# - (#{gen-labels 354}# #{ids 2185}#))) + (let ((#{labels 2203}# + (#{gen-labels 358}# #{ids 2200}#))) (begin - (let ((#{new-w 2190}# - (#{make-binding-wrap 383}# - #{ids 2185}# - #{labels 2188}# - #{w 2163}#))) - (#{k 2166}# - (cons #{e1 2182}# #{e2 2183}#) - (#{extend-env 327}# - #{labels 2188}# + (let ((#{new-w 2205}# + (#{make-binding-wrap 387}# + #{ids 2200}# + #{labels 2203}# + #{w 2178}#))) + (#{k 2181}# + (cons #{e1 2197}# #{e2 2198}#) + (#{extend-env 331}# + #{labels 2203}# (begin - (let ((#{w 2194}# - (if #{rec? 2160}# - #{new-w 2190}# - #{w 2163}#)) - (#{trans-r 2195}# - (#{macros-only-env 331}# - #{r 2162}#))) - (map (lambda (#{x 2196}#) + (let ((#{w 2209}# + (if #{rec? 2175}# + #{new-w 2205}# + #{w 2178}#)) + (#{trans-r 2210}# + (#{macros-only-env 335}# + #{r 2177}#))) + (map (lambda (#{x 2211}#) (cons 'macro - (#{eval-local-transformer 431}# - (#{chi 419}# - #{x 2196}# - #{trans-r 2195}# - #{w 2194}# - #{mod 2165}#) - #{mod 2165}#))) - #{val 2181}#))) - #{r 2162}#) - #{new-w 2190}# - #{s 2164}# - #{mod 2165}#))))))))) - #{tmp 2175}#) - (let ((#{_ 2201}# #{tmp 2174}#)) + (#{eval-local-transformer 435}# + (#{chi 423}# + #{x 2211}# + #{trans-r 2210}# + #{w 2209}# + #{mod 2180}#) + #{mod 2180}#))) + #{val 2196}#))) + #{r 2177}#) + #{new-w 2205}# + #{s 2179}# + #{mod 2180}#))))))))) + #{tmp 2190}#) + (let ((#{_ 2216}# #{tmp 2189}#)) (syntax-violation #f "bad local syntax definition" - (#{source-wrap 407}# - #{e 2161}# - #{w 2163}# - #{s 2164}# - #{mod 2165}#)))))))) - (#{eval-local-transformer 431}# - (lambda (#{expanded 2202}# #{mod 2203}#) + (#{source-wrap 411}# + #{e 2176}# + #{w 2178}# + #{s 2179}# + #{mod 2180}#)))))))) + (#{eval-local-transformer 435}# + (lambda (#{expanded 2217}# #{mod 2218}#) (begin - (let ((#{p 2207}# - (#{local-eval-hook 252}# - #{expanded 2202}# - #{mod 2203}#))) - (if (procedure? #{p 2207}#) - #{p 2207}# + (let ((#{p 2222}# + (#{local-eval-hook 254}# + #{expanded 2217}# + #{mod 2218}#))) + (if (procedure? #{p 2222}#) + #{p 2222}# (syntax-violation #f "nonprocedure transformer" - #{p 2207}#)))))) - (#{chi-void 433}# - (lambda () (#{build-void 263}# #f))) - (#{ellipsis? 435}# - (lambda (#{x 2209}#) - (if (#{nonsymbol-id? 337}# #{x 2209}#) - (#{free-id=? 395}# - #{x 2209}# + #{p 2222}#)))))) + (#{chi-void 437}# + (lambda () (#{build-void 265}# #f))) + (#{ellipsis? 439}# + (lambda (#{x 2224}#) + (if (#{nonsymbol-id? 341}# #{x 2224}#) + (#{free-id=? 399}# + #{x 2224}# '#(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i2210")) + #(ribcage #(x) #((top)) #("i2225")) #(ribcage (lambda-var-list gen-var @@ -6332,7 +6382,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -6410,6 +6460,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -6421,7 +6472,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -6443,7 +6494,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -6590,8 +6642,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -6624,14 +6680,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -6639,33 +6695,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -6698,17 +6754,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -6735,249 +6791,249 @@ ("i40" "i39" "i38"))) (hygiene guile))) #f))) - (#{lambda-formals 437}# - (lambda (#{orig-args 2213}#) + (#{lambda-formals 441}# + (lambda (#{orig-args 2228}#) (letrec* - ((#{req 2216}# - (lambda (#{args 2219}# #{rreq 2220}#) - (let ((#{tmp 2223}# #{args 2219}#)) - (let ((#{tmp 2224}# ($sc-dispatch #{tmp 2223}# '()))) - (if #{tmp 2224}# + ((#{req 2231}# + (lambda (#{args 2234}# #{rreq 2235}#) + (let ((#{tmp 2238}# #{args 2234}#)) + (let ((#{tmp 2239}# ($sc-dispatch #{tmp 2238}# '()))) + (if #{tmp 2239}# (@apply (lambda () - (#{check 2218}# (reverse #{rreq 2220}#) #f)) - #{tmp 2224}#) - (let ((#{tmp 2225}# - ($sc-dispatch #{tmp 2223}# '(any . any)))) - (if (if #{tmp 2225}# + (#{check 2233}# (reverse #{rreq 2235}#) #f)) + #{tmp 2239}#) + (let ((#{tmp 2240}# + ($sc-dispatch #{tmp 2238}# '(any . any)))) + (if (if #{tmp 2240}# (@apply - (lambda (#{a 2228}# #{b 2229}#) - (#{id? 339}# #{a 2228}#)) - #{tmp 2225}#) + (lambda (#{a 2243}# #{b 2244}#) + (#{id? 343}# #{a 2243}#)) + #{tmp 2240}#) #f) (@apply - (lambda (#{a 2232}# #{b 2233}#) - (#{req 2216}# - #{b 2233}# - (cons #{a 2232}# #{rreq 2220}#))) - #{tmp 2225}#) - (let ((#{tmp 2234}# (list #{tmp 2223}#))) - (if (if #{tmp 2234}# + (lambda (#{a 2247}# #{b 2248}#) + (#{req 2231}# + #{b 2248}# + (cons #{a 2247}# #{rreq 2235}#))) + #{tmp 2240}#) + (let ((#{tmp 2249}# (list #{tmp 2238}#))) + (if (if #{tmp 2249}# (@apply - (lambda (#{r 2236}#) - (#{id? 339}# #{r 2236}#)) - #{tmp 2234}#) + (lambda (#{r 2251}#) + (#{id? 343}# #{r 2251}#)) + #{tmp 2249}#) #f) (@apply - (lambda (#{r 2238}#) - (#{check 2218}# - (reverse #{rreq 2220}#) - #{r 2238}#)) - #{tmp 2234}#) - (let ((#{else 2240}# #{tmp 2223}#)) + (lambda (#{r 2253}#) + (#{check 2233}# + (reverse #{rreq 2235}#) + #{r 2253}#)) + #{tmp 2249}#) + (let ((#{else 2255}# #{tmp 2238}#)) (syntax-violation 'lambda "invalid argument list" - #{orig-args 2213}# - #{args 2219}#))))))))))) - (#{check 2218}# - (lambda (#{req 2241}# #{rest 2242}#) - (if (#{distinct-bound-ids? 401}# - (if #{rest 2242}# - (cons #{rest 2242}# #{req 2241}#) - #{req 2241}#)) - (values #{req 2241}# #f #{rest 2242}# #f) + #{orig-args 2228}# + #{args 2234}#))))))))))) + (#{check 2233}# + (lambda (#{req 2256}# #{rest 2257}#) + (if (#{distinct-bound-ids? 405}# + (if #{rest 2257}# + (cons #{rest 2257}# #{req 2256}#) + #{req 2256}#)) + (values #{req 2256}# #f #{rest 2257}# #f) (syntax-violation 'lambda "duplicate identifier in argument list" - #{orig-args 2213}#))))) - (begin (#{req 2216}# #{orig-args 2213}# '()))))) - (#{chi-simple-lambda 439}# - (lambda (#{e 2248}# - #{r 2249}# - #{w 2250}# - #{s 2251}# - #{mod 2252}# - #{req 2253}# - #{rest 2254}# - #{meta 2255}# - #{body 2256}#) + #{orig-args 2228}#))))) + (begin (#{req 2231}# #{orig-args 2228}# '()))))) + (#{chi-simple-lambda 443}# + (lambda (#{e 2263}# + #{r 2264}# + #{w 2265}# + #{s 2266}# + #{mod 2267}# + #{req 2268}# + #{rest 2269}# + #{meta 2270}# + #{body 2271}#) (begin - (let ((#{ids 2268}# - (if #{rest 2254}# - (append #{req 2253}# (list #{rest 2254}#)) - #{req 2253}#))) + (let ((#{ids 2283}# + (if #{rest 2269}# + (append #{req 2268}# (list #{rest 2269}#)) + #{req 2268}#))) (begin - (let ((#{vars 2270}# - (map #{gen-var 447}# #{ids 2268}#))) + (let ((#{vars 2285}# + (map #{gen-var 451}# #{ids 2283}#))) (begin - (let ((#{labels 2272}# - (#{gen-labels 354}# #{ids 2268}#))) - (#{build-simple-lambda 283}# - #{s 2251}# - (map syntax->datum #{req 2253}#) - (if #{rest 2254}# - (syntax->datum #{rest 2254}#) + (let ((#{labels 2287}# + (#{gen-labels 358}# #{ids 2283}#))) + (#{build-simple-lambda 285}# + #{s 2266}# + (map syntax->datum #{req 2268}#) + (if #{rest 2269}# + (syntax->datum #{rest 2269}#) #f) - #{vars 2270}# - #{meta 2255}# - (#{chi-body 427}# - #{body 2256}# - (#{source-wrap 407}# - #{e 2248}# - #{w 2250}# - #{s 2251}# - #{mod 2252}#) - (#{extend-var-env 329}# - #{labels 2272}# - #{vars 2270}# - #{r 2249}#) - (#{make-binding-wrap 383}# - #{ids 2268}# - #{labels 2272}# - #{w 2250}#) - #{mod 2252}#)))))))))) - (#{lambda*-formals 441}# - (lambda (#{orig-args 2275}#) + #{vars 2285}# + #{meta 2270}# + (#{chi-body 431}# + #{body 2271}# + (#{source-wrap 411}# + #{e 2263}# + #{w 2265}# + #{s 2266}# + #{mod 2267}#) + (#{extend-var-env 333}# + #{labels 2287}# + #{vars 2285}# + #{r 2264}#) + (#{make-binding-wrap 387}# + #{ids 2283}# + #{labels 2287}# + #{w 2265}#) + #{mod 2267}#)))))))))) + (#{lambda*-formals 445}# + (lambda (#{orig-args 2290}#) (letrec* - ((#{req 2278}# - (lambda (#{args 2287}# #{rreq 2288}#) - (let ((#{tmp 2291}# #{args 2287}#)) - (let ((#{tmp 2292}# ($sc-dispatch #{tmp 2291}# '()))) - (if #{tmp 2292}# + ((#{req 2293}# + (lambda (#{args 2302}# #{rreq 2303}#) + (let ((#{tmp 2306}# #{args 2302}#)) + (let ((#{tmp 2307}# ($sc-dispatch #{tmp 2306}# '()))) + (if #{tmp 2307}# (@apply (lambda () - (#{check 2286}# - (reverse #{rreq 2288}#) + (#{check 2301}# + (reverse #{rreq 2303}#) '() #f '())) - #{tmp 2292}#) - (let ((#{tmp 2293}# - ($sc-dispatch #{tmp 2291}# '(any . any)))) - (if (if #{tmp 2293}# + #{tmp 2307}#) + (let ((#{tmp 2308}# + ($sc-dispatch #{tmp 2306}# '(any . any)))) + (if (if #{tmp 2308}# (@apply - (lambda (#{a 2296}# #{b 2297}#) - (#{id? 339}# #{a 2296}#)) - #{tmp 2293}#) + (lambda (#{a 2311}# #{b 2312}#) + (#{id? 343}# #{a 2311}#)) + #{tmp 2308}#) #f) (@apply - (lambda (#{a 2300}# #{b 2301}#) - (#{req 2278}# - #{b 2301}# - (cons #{a 2300}# #{rreq 2288}#))) - #{tmp 2293}#) - (let ((#{tmp 2302}# - ($sc-dispatch #{tmp 2291}# '(any . any)))) - (if (if #{tmp 2302}# + (lambda (#{a 2315}# #{b 2316}#) + (#{req 2293}# + #{b 2316}# + (cons #{a 2315}# #{rreq 2303}#))) + #{tmp 2308}#) + (let ((#{tmp 2317}# + ($sc-dispatch #{tmp 2306}# '(any . any)))) + (if (if #{tmp 2317}# (@apply - (lambda (#{a 2305}# #{b 2306}#) - (eq? (syntax->datum #{a 2305}#) + (lambda (#{a 2320}# #{b 2321}#) + (eq? (syntax->datum #{a 2320}#) #:optional)) - #{tmp 2302}#) + #{tmp 2317}#) #f) (@apply - (lambda (#{a 2309}# #{b 2310}#) - (#{opt 2280}# - #{b 2310}# - (reverse #{rreq 2288}#) + (lambda (#{a 2324}# #{b 2325}#) + (#{opt 2295}# + #{b 2325}# + (reverse #{rreq 2303}#) '())) - #{tmp 2302}#) - (let ((#{tmp 2311}# - ($sc-dispatch #{tmp 2291}# '(any . any)))) - (if (if #{tmp 2311}# + #{tmp 2317}#) + (let ((#{tmp 2326}# + ($sc-dispatch #{tmp 2306}# '(any . any)))) + (if (if #{tmp 2326}# (@apply - (lambda (#{a 2314}# #{b 2315}#) - (eq? (syntax->datum #{a 2314}#) #:key)) - #{tmp 2311}#) + (lambda (#{a 2329}# #{b 2330}#) + (eq? (syntax->datum #{a 2329}#) #:key)) + #{tmp 2326}#) #f) (@apply - (lambda (#{a 2318}# #{b 2319}#) - (#{key 2282}# - #{b 2319}# - (reverse #{rreq 2288}#) + (lambda (#{a 2333}# #{b 2334}#) + (#{key 2297}# + #{b 2334}# + (reverse #{rreq 2303}#) '() '())) - #{tmp 2311}#) - (let ((#{tmp 2320}# + #{tmp 2326}#) + (let ((#{tmp 2335}# ($sc-dispatch - #{tmp 2291}# + #{tmp 2306}# '(any any)))) - (if (if #{tmp 2320}# + (if (if #{tmp 2335}# (@apply - (lambda (#{a 2323}# #{b 2324}#) - (eq? (syntax->datum #{a 2323}#) + (lambda (#{a 2338}# #{b 2339}#) + (eq? (syntax->datum #{a 2338}#) #:rest)) - #{tmp 2320}#) + #{tmp 2335}#) #f) (@apply - (lambda (#{a 2327}# #{b 2328}#) - (#{rest 2284}# - #{b 2328}# - (reverse #{rreq 2288}#) + (lambda (#{a 2342}# #{b 2343}#) + (#{rest 2299}# + #{b 2343}# + (reverse #{rreq 2303}#) '() '())) - #{tmp 2320}#) - (let ((#{tmp 2329}# (list #{tmp 2291}#))) - (if (if #{tmp 2329}# + #{tmp 2335}#) + (let ((#{tmp 2344}# (list #{tmp 2306}#))) + (if (if #{tmp 2344}# (@apply - (lambda (#{r 2331}#) - (#{id? 339}# #{r 2331}#)) - #{tmp 2329}#) + (lambda (#{r 2346}#) + (#{id? 343}# #{r 2346}#)) + #{tmp 2344}#) #f) (@apply - (lambda (#{r 2333}#) - (#{rest 2284}# - #{r 2333}# - (reverse #{rreq 2288}#) + (lambda (#{r 2348}#) + (#{rest 2299}# + #{r 2348}# + (reverse #{rreq 2303}#) '() '())) - #{tmp 2329}#) - (let ((#{else 2335}# #{tmp 2291}#)) + #{tmp 2344}#) + (let ((#{else 2350}# #{tmp 2306}#)) (syntax-violation 'lambda* "invalid argument list" - #{orig-args 2275}# - #{args 2287}#))))))))))))))))) - (#{opt 2280}# - (lambda (#{args 2336}# #{req 2337}# #{ropt 2338}#) - (let ((#{tmp 2342}# #{args 2336}#)) - (let ((#{tmp 2343}# ($sc-dispatch #{tmp 2342}# '()))) - (if #{tmp 2343}# + #{orig-args 2290}# + #{args 2302}#))))))))))))))))) + (#{opt 2295}# + (lambda (#{args 2351}# #{req 2352}# #{ropt 2353}#) + (let ((#{tmp 2357}# #{args 2351}#)) + (let ((#{tmp 2358}# ($sc-dispatch #{tmp 2357}# '()))) + (if #{tmp 2358}# (@apply (lambda () - (#{check 2286}# - #{req 2337}# - (reverse #{ropt 2338}#) + (#{check 2301}# + #{req 2352}# + (reverse #{ropt 2353}#) #f '())) - #{tmp 2343}#) - (let ((#{tmp 2344}# - ($sc-dispatch #{tmp 2342}# '(any . any)))) - (if (if #{tmp 2344}# + #{tmp 2358}#) + (let ((#{tmp 2359}# + ($sc-dispatch #{tmp 2357}# '(any . any)))) + (if (if #{tmp 2359}# (@apply - (lambda (#{a 2347}# #{b 2348}#) - (#{id? 339}# #{a 2347}#)) - #{tmp 2344}#) + (lambda (#{a 2362}# #{b 2363}#) + (#{id? 343}# #{a 2362}#)) + #{tmp 2359}#) #f) (@apply - (lambda (#{a 2351}# #{b 2352}#) - (#{opt 2280}# - #{b 2352}# - #{req 2337}# - (cons (cons #{a 2351}# + (lambda (#{a 2366}# #{b 2367}#) + (#{opt 2295}# + #{b 2367}# + #{req 2352}# + (cons (cons #{a 2366}# '(#(syntax-object #f ((top) #(ribcage #(a b) #((top) (top)) - #("i2349" "i2350")) + #("i2364" "i2365")) #(ribcage () () ()) #(ribcage #(args req ropt) #((top) (top) (top)) - #("i2339" "i2340" "i2341")) + #("i2354" "i2355" "i2356")) #(ribcage (check rest key opt req) ((top) @@ -6985,15 +7041,15 @@ (top) (top) (top)) - ("i2285" - "i2283" - "i2281" - "i2279" - "i2277")) + ("i2300" + "i2298" + "i2296" + "i2294" + "i2292")) #(ribcage #(orig-args) #((top)) - #("i2276")) + #("i2291")) #(ribcage (lambda-var-list gen-var @@ -7008,7 +7064,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -7086,6 +7142,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -7097,7 +7154,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -7119,7 +7176,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -7266,8 +7324,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -7300,14 +7362,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -7315,33 +7377,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -7374,17 +7436,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -7410,118 +7472,118 @@ ((top) (top) (top)) ("i40" "i39" "i38"))) (hygiene guile)))) - #{ropt 2338}#))) - #{tmp 2344}#) - (let ((#{tmp 2353}# + #{ropt 2353}#))) + #{tmp 2359}#) + (let ((#{tmp 2368}# ($sc-dispatch - #{tmp 2342}# + #{tmp 2357}# '((any any) . any)))) - (if (if #{tmp 2353}# + (if (if #{tmp 2368}# (@apply - (lambda (#{a 2357}# #{init 2358}# #{b 2359}#) - (#{id? 339}# #{a 2357}#)) - #{tmp 2353}#) + (lambda (#{a 2372}# #{init 2373}# #{b 2374}#) + (#{id? 343}# #{a 2372}#)) + #{tmp 2368}#) #f) (@apply - (lambda (#{a 2363}# #{init 2364}# #{b 2365}#) - (#{opt 2280}# - #{b 2365}# - #{req 2337}# - (cons (list #{a 2363}# #{init 2364}#) - #{ropt 2338}#))) - #{tmp 2353}#) - (let ((#{tmp 2366}# - ($sc-dispatch #{tmp 2342}# '(any . any)))) - (if (if #{tmp 2366}# + (lambda (#{a 2378}# #{init 2379}# #{b 2380}#) + (#{opt 2295}# + #{b 2380}# + #{req 2352}# + (cons (list #{a 2378}# #{init 2379}#) + #{ropt 2353}#))) + #{tmp 2368}#) + (let ((#{tmp 2381}# + ($sc-dispatch #{tmp 2357}# '(any . any)))) + (if (if #{tmp 2381}# (@apply - (lambda (#{a 2369}# #{b 2370}#) - (eq? (syntax->datum #{a 2369}#) #:key)) - #{tmp 2366}#) + (lambda (#{a 2384}# #{b 2385}#) + (eq? (syntax->datum #{a 2384}#) #:key)) + #{tmp 2381}#) #f) (@apply - (lambda (#{a 2373}# #{b 2374}#) - (#{key 2282}# - #{b 2374}# - #{req 2337}# - (reverse #{ropt 2338}#) + (lambda (#{a 2388}# #{b 2389}#) + (#{key 2297}# + #{b 2389}# + #{req 2352}# + (reverse #{ropt 2353}#) '())) - #{tmp 2366}#) - (let ((#{tmp 2375}# + #{tmp 2381}#) + (let ((#{tmp 2390}# ($sc-dispatch - #{tmp 2342}# + #{tmp 2357}# '(any any)))) - (if (if #{tmp 2375}# + (if (if #{tmp 2390}# (@apply - (lambda (#{a 2378}# #{b 2379}#) - (eq? (syntax->datum #{a 2378}#) + (lambda (#{a 2393}# #{b 2394}#) + (eq? (syntax->datum #{a 2393}#) #:rest)) - #{tmp 2375}#) + #{tmp 2390}#) #f) (@apply - (lambda (#{a 2382}# #{b 2383}#) - (#{rest 2284}# - #{b 2383}# - #{req 2337}# - (reverse #{ropt 2338}#) + (lambda (#{a 2397}# #{b 2398}#) + (#{rest 2299}# + #{b 2398}# + #{req 2352}# + (reverse #{ropt 2353}#) '())) - #{tmp 2375}#) - (let ((#{tmp 2384}# (list #{tmp 2342}#))) - (if (if #{tmp 2384}# + #{tmp 2390}#) + (let ((#{tmp 2399}# (list #{tmp 2357}#))) + (if (if #{tmp 2399}# (@apply - (lambda (#{r 2386}#) - (#{id? 339}# #{r 2386}#)) - #{tmp 2384}#) + (lambda (#{r 2401}#) + (#{id? 343}# #{r 2401}#)) + #{tmp 2399}#) #f) (@apply - (lambda (#{r 2388}#) - (#{rest 2284}# - #{r 2388}# - #{req 2337}# - (reverse #{ropt 2338}#) + (lambda (#{r 2403}#) + (#{rest 2299}# + #{r 2403}# + #{req 2352}# + (reverse #{ropt 2353}#) '())) - #{tmp 2384}#) - (let ((#{else 2390}# #{tmp 2342}#)) + #{tmp 2399}#) + (let ((#{else 2405}# #{tmp 2357}#)) (syntax-violation 'lambda* "invalid optional argument list" - #{orig-args 2275}# - #{args 2336}#))))))))))))))))) - (#{key 2282}# - (lambda (#{args 2391}# - #{req 2392}# - #{opt 2393}# - #{rkey 2394}#) - (let ((#{tmp 2399}# #{args 2391}#)) - (let ((#{tmp 2400}# ($sc-dispatch #{tmp 2399}# '()))) - (if #{tmp 2400}# + #{orig-args 2290}# + #{args 2351}#))))))))))))))))) + (#{key 2297}# + (lambda (#{args 2406}# + #{req 2407}# + #{opt 2408}# + #{rkey 2409}#) + (let ((#{tmp 2414}# #{args 2406}#)) + (let ((#{tmp 2415}# ($sc-dispatch #{tmp 2414}# '()))) + (if #{tmp 2415}# (@apply (lambda () - (#{check 2286}# - #{req 2392}# - #{opt 2393}# + (#{check 2301}# + #{req 2407}# + #{opt 2408}# #f - (cons #f (reverse #{rkey 2394}#)))) - #{tmp 2400}#) - (let ((#{tmp 2401}# - ($sc-dispatch #{tmp 2399}# '(any . any)))) - (if (if #{tmp 2401}# + (cons #f (reverse #{rkey 2409}#)))) + #{tmp 2415}#) + (let ((#{tmp 2416}# + ($sc-dispatch #{tmp 2414}# '(any . any)))) + (if (if #{tmp 2416}# (@apply - (lambda (#{a 2404}# #{b 2405}#) - (#{id? 339}# #{a 2404}#)) - #{tmp 2401}#) + (lambda (#{a 2419}# #{b 2420}#) + (#{id? 343}# #{a 2419}#)) + #{tmp 2416}#) #f) (@apply - (lambda (#{a 2408}# #{b 2409}#) - (let ((#{tmp 2411}# + (lambda (#{a 2423}# #{b 2424}#) + (let ((#{tmp 2426}# (symbol->keyword - (syntax->datum #{a 2408}#)))) - (let ((#{k 2413}# #{tmp 2411}#)) - (#{key 2282}# - #{b 2409}# - #{req 2392}# - #{opt 2393}# - (cons (cons #{k 2413}# - (cons #{a 2408}# + (syntax->datum #{a 2423}#)))) + (let ((#{k 2428}# #{tmp 2426}#)) + (#{key 2297}# + #{b 2424}# + #{req 2407}# + #{opt 2408}# + (cons (cons #{k 2428}# + (cons #{a 2423}# '(#(syntax-object #f ((top) @@ -7529,11 +7591,11 @@ #(ribcage #(k) #((top)) - #("i2412")) + #("i2427")) #(ribcage #(a b) #((top) (top)) - #("i2406" "i2407")) + #("i2421" "i2422")) #(ribcage () () ()) #(ribcage #(args req opt rkey) @@ -7541,10 +7603,10 @@ (top) (top) (top)) - #("i2395" - "i2396" - "i2397" - "i2398")) + #("i2410" + "i2411" + "i2412" + "i2413")) #(ribcage (check rest key @@ -7555,15 +7617,15 @@ (top) (top) (top)) - ("i2285" - "i2283" - "i2281" - "i2279" - "i2277")) + ("i2300" + "i2298" + "i2296" + "i2294" + "i2292")) #(ribcage #(orig-args) #((top)) - #("i2276")) + #("i2291")) #(ribcage (lambda-var-list gen-var @@ -7578,7 +7640,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -7656,6 +7718,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -7667,7 +7730,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -7689,7 +7752,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -7836,8 +7900,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -7870,14 +7938,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -7885,33 +7953,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -7944,17 +8012,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -7982,1935 +8050,1930 @@ "i39" "i38"))) (hygiene guile))))) - #{rkey 2394}#))))) - #{tmp 2401}#) - (let ((#{tmp 2414}# + #{rkey 2409}#))))) + #{tmp 2416}#) + (let ((#{tmp 2429}# ($sc-dispatch - #{tmp 2399}# + #{tmp 2414}# '((any any) . any)))) - (if (if #{tmp 2414}# + (if (if #{tmp 2429}# (@apply - (lambda (#{a 2418}# #{init 2419}# #{b 2420}#) - (#{id? 339}# #{a 2418}#)) - #{tmp 2414}#) + (lambda (#{a 2433}# #{init 2434}# #{b 2435}#) + (#{id? 343}# #{a 2433}#)) + #{tmp 2429}#) #f) (@apply - (lambda (#{a 2424}# #{init 2425}# #{b 2426}#) - (let ((#{tmp 2428}# + (lambda (#{a 2439}# #{init 2440}# #{b 2441}#) + (let ((#{tmp 2443}# (symbol->keyword - (syntax->datum #{a 2424}#)))) - (let ((#{k 2430}# #{tmp 2428}#)) - (#{key 2282}# - #{b 2426}# - #{req 2392}# - #{opt 2393}# - (cons (list #{k 2430}# - #{a 2424}# - #{init 2425}#) - #{rkey 2394}#))))) - #{tmp 2414}#) - (let ((#{tmp 2431}# + (syntax->datum #{a 2439}#)))) + (let ((#{k 2445}# #{tmp 2443}#)) + (#{key 2297}# + #{b 2441}# + #{req 2407}# + #{opt 2408}# + (cons (list #{k 2445}# + #{a 2439}# + #{init 2440}#) + #{rkey 2409}#))))) + #{tmp 2429}#) + (let ((#{tmp 2446}# ($sc-dispatch - #{tmp 2399}# + #{tmp 2414}# '((any any any) . any)))) - (if (if #{tmp 2431}# + (if (if #{tmp 2446}# (@apply - (lambda (#{a 2436}# - #{init 2437}# - #{k 2438}# - #{b 2439}#) - (if (#{id? 339}# #{a 2436}#) - (keyword? (syntax->datum #{k 2438}#)) + (lambda (#{a 2451}# + #{init 2452}# + #{k 2453}# + #{b 2454}#) + (if (#{id? 343}# #{a 2451}#) + (keyword? (syntax->datum #{k 2453}#)) #f)) - #{tmp 2431}#) + #{tmp 2446}#) #f) (@apply - (lambda (#{a 2446}# - #{init 2447}# - #{k 2448}# - #{b 2449}#) - (#{key 2282}# - #{b 2449}# - #{req 2392}# - #{opt 2393}# - (cons (list #{k 2448}# - #{a 2446}# - #{init 2447}#) - #{rkey 2394}#))) - #{tmp 2431}#) - (let ((#{tmp 2450}# - ($sc-dispatch #{tmp 2399}# '(any)))) - (if (if #{tmp 2450}# + (lambda (#{a 2461}# + #{init 2462}# + #{k 2463}# + #{b 2464}#) + (#{key 2297}# + #{b 2464}# + #{req 2407}# + #{opt 2408}# + (cons (list #{k 2463}# + #{a 2461}# + #{init 2462}#) + #{rkey 2409}#))) + #{tmp 2446}#) + (let ((#{tmp 2465}# + ($sc-dispatch #{tmp 2414}# '(any)))) + (if (if #{tmp 2465}# (@apply - (lambda (#{aok 2452}#) - (eq? (syntax->datum #{aok 2452}#) + (lambda (#{aok 2467}#) + (eq? (syntax->datum #{aok 2467}#) #:allow-other-keys)) - #{tmp 2450}#) + #{tmp 2465}#) #f) (@apply - (lambda (#{aok 2454}#) - (#{check 2286}# - #{req 2392}# - #{opt 2393}# + (lambda (#{aok 2469}#) + (#{check 2301}# + #{req 2407}# + #{opt 2408}# #f - (cons #t (reverse #{rkey 2394}#)))) - #{tmp 2450}#) - (let ((#{tmp 2455}# + (cons #t (reverse #{rkey 2409}#)))) + #{tmp 2465}#) + (let ((#{tmp 2470}# ($sc-dispatch - #{tmp 2399}# + #{tmp 2414}# '(any any any)))) - (if (if #{tmp 2455}# + (if (if #{tmp 2470}# (@apply - (lambda (#{aok 2459}# - #{a 2460}# - #{b 2461}#) + (lambda (#{aok 2474}# + #{a 2475}# + #{b 2476}#) (if (eq? (syntax->datum - #{aok 2459}#) + #{aok 2474}#) #:allow-other-keys) (eq? (syntax->datum - #{a 2460}#) + #{a 2475}#) #:rest) #f)) - #{tmp 2455}#) + #{tmp 2470}#) #f) (@apply - (lambda (#{aok 2467}# - #{a 2468}# - #{b 2469}#) - (#{rest 2284}# - #{b 2469}# - #{req 2392}# - #{opt 2393}# + (lambda (#{aok 2482}# + #{a 2483}# + #{b 2484}#) + (#{rest 2299}# + #{b 2484}# + #{req 2407}# + #{opt 2408}# (cons #t - (reverse #{rkey 2394}#)))) - #{tmp 2455}#) - (let ((#{tmp 2470}# + (reverse #{rkey 2409}#)))) + #{tmp 2470}#) + (let ((#{tmp 2485}# ($sc-dispatch - #{tmp 2399}# + #{tmp 2414}# '(any . any)))) - (if (if #{tmp 2470}# + (if (if #{tmp 2485}# (@apply - (lambda (#{aok 2473}# - #{r 2474}#) + (lambda (#{aok 2488}# + #{r 2489}#) (if (eq? (syntax->datum - #{aok 2473}#) + #{aok 2488}#) #:allow-other-keys) - (#{id? 339}# #{r 2474}#) + (#{id? 343}# #{r 2489}#) #f)) - #{tmp 2470}#) + #{tmp 2485}#) #f) (@apply - (lambda (#{aok 2479}# #{r 2480}#) - (#{rest 2284}# - #{r 2480}# - #{req 2392}# - #{opt 2393}# + (lambda (#{aok 2494}# #{r 2495}#) + (#{rest 2299}# + #{r 2495}# + #{req 2407}# + #{opt 2408}# (cons #t (reverse - #{rkey 2394}#)))) - #{tmp 2470}#) - (let ((#{tmp 2481}# + #{rkey 2409}#)))) + #{tmp 2485}#) + (let ((#{tmp 2496}# ($sc-dispatch - #{tmp 2399}# + #{tmp 2414}# '(any any)))) - (if (if #{tmp 2481}# + (if (if #{tmp 2496}# (@apply - (lambda (#{a 2484}# - #{b 2485}#) + (lambda (#{a 2499}# + #{b 2500}#) (eq? (syntax->datum - #{a 2484}#) + #{a 2499}#) #:rest)) - #{tmp 2481}#) + #{tmp 2496}#) #f) (@apply - (lambda (#{a 2488}# - #{b 2489}#) - (#{rest 2284}# - #{b 2489}# - #{req 2392}# - #{opt 2393}# + (lambda (#{a 2503}# + #{b 2504}#) + (#{rest 2299}# + #{b 2504}# + #{req 2407}# + #{opt 2408}# (cons #f (reverse - #{rkey 2394}#)))) - #{tmp 2481}#) - (let ((#{tmp 2490}# - (list #{tmp 2399}#))) - (if (if #{tmp 2490}# + #{rkey 2409}#)))) + #{tmp 2496}#) + (let ((#{tmp 2505}# + (list #{tmp 2414}#))) + (if (if #{tmp 2505}# (@apply - (lambda (#{r 2492}#) - (#{id? 339}# - #{r 2492}#)) - #{tmp 2490}#) + (lambda (#{r 2507}#) + (#{id? 343}# + #{r 2507}#)) + #{tmp 2505}#) #f) (@apply - (lambda (#{r 2494}#) - (#{rest 2284}# - #{r 2494}# - #{req 2392}# - #{opt 2393}# + (lambda (#{r 2509}#) + (#{rest 2299}# + #{r 2509}# + #{req 2407}# + #{opt 2408}# (cons #f (reverse - #{rkey 2394}#)))) - #{tmp 2490}#) - (let ((#{else 2496}# - #{tmp 2399}#)) + #{rkey 2409}#)))) + #{tmp 2505}#) + (let ((#{else 2511}# + #{tmp 2414}#)) (syntax-violation 'lambda* "invalid keyword argument list" - #{orig-args 2275}# - #{args 2391}#))))))))))))))))))))))) - (#{rest 2284}# - (lambda (#{args 2497}# - #{req 2498}# - #{opt 2499}# - #{kw 2500}#) - (let ((#{tmp 2505}# #{args 2497}#)) - (let ((#{tmp 2506}# (list #{tmp 2505}#))) - (if (if #{tmp 2506}# + #{orig-args 2290}# + #{args 2406}#))))))))))))))))))))))) + (#{rest 2299}# + (lambda (#{args 2512}# + #{req 2513}# + #{opt 2514}# + #{kw 2515}#) + (let ((#{tmp 2520}# #{args 2512}#)) + (let ((#{tmp 2521}# (list #{tmp 2520}#))) + (if (if #{tmp 2521}# (@apply - (lambda (#{r 2508}#) (#{id? 339}# #{r 2508}#)) - #{tmp 2506}#) + (lambda (#{r 2523}#) (#{id? 343}# #{r 2523}#)) + #{tmp 2521}#) #f) (@apply - (lambda (#{r 2510}#) - (#{check 2286}# - #{req 2498}# - #{opt 2499}# - #{r 2510}# - #{kw 2500}#)) - #{tmp 2506}#) - (let ((#{else 2512}# #{tmp 2505}#)) + (lambda (#{r 2525}#) + (#{check 2301}# + #{req 2513}# + #{opt 2514}# + #{r 2525}# + #{kw 2515}#)) + #{tmp 2521}#) + (let ((#{else 2527}# #{tmp 2520}#)) (syntax-violation 'lambda* "invalid rest argument" - #{orig-args 2275}# - #{args 2497}#))))))) - (#{check 2286}# - (lambda (#{req 2513}# - #{opt 2514}# - #{rest 2515}# - #{kw 2516}#) - (if (#{distinct-bound-ids? 401}# + #{orig-args 2290}# + #{args 2512}#))))))) + (#{check 2301}# + (lambda (#{req 2528}# + #{opt 2529}# + #{rest 2530}# + #{kw 2531}#) + (if (#{distinct-bound-ids? 405}# (append - #{req 2513}# - (map car #{opt 2514}#) - (if #{rest 2515}# (list #{rest 2515}#) '()) - (if (pair? #{kw 2516}#) - (map cadr (cdr #{kw 2516}#)) + #{req 2528}# + (map car #{opt 2529}#) + (if #{rest 2530}# (list #{rest 2530}#) '()) + (if (pair? #{kw 2531}#) + (map cadr (cdr #{kw 2531}#)) '()))) (values - #{req 2513}# - #{opt 2514}# - #{rest 2515}# - #{kw 2516}#) + #{req 2528}# + #{opt 2529}# + #{rest 2530}# + #{kw 2531}#) (syntax-violation 'lambda* "duplicate identifier in argument list" - #{orig-args 2275}#))))) - (begin (#{req 2278}# #{orig-args 2275}# '()))))) - (#{chi-lambda-case 443}# - (lambda (#{e 2524}# - #{r 2525}# - #{w 2526}# - #{s 2527}# - #{mod 2528}# - #{get-formals 2529}# - #{clauses 2530}#) + #{orig-args 2290}#))))) + (begin (#{req 2293}# #{orig-args 2290}# '()))))) + (#{chi-lambda-case 447}# + (lambda (#{e 2539}# + #{r 2540}# + #{w 2541}# + #{s 2542}# + #{mod 2543}# + #{get-formals 2544}# + #{clauses 2545}#) (letrec* - ((#{expand-req 2539}# - (lambda (#{req 2546}# - #{opt 2547}# - #{rest 2548}# - #{kw 2549}# - #{body 2550}#) + ((#{expand-req 2554}# + (lambda (#{req 2561}# + #{opt 2562}# + #{rest 2563}# + #{kw 2564}# + #{body 2565}#) (begin - (let ((#{vars 2558}# - (map #{gen-var 447}# #{req 2546}#)) - (#{labels 2559}# - (#{gen-labels 354}# #{req 2546}#))) + (let ((#{vars 2573}# + (map #{gen-var 451}# #{req 2561}#)) + (#{labels 2574}# + (#{gen-labels 358}# #{req 2561}#))) (begin - (let ((#{r* 2562}# - (#{extend-var-env 329}# - #{labels 2559}# - #{vars 2558}# - #{r 2525}#)) - (#{w* 2563}# - (#{make-binding-wrap 383}# - #{req 2546}# - #{labels 2559}# - #{w 2526}#))) - (#{expand-opt 2541}# - (map syntax->datum #{req 2546}#) - #{opt 2547}# - #{rest 2548}# - #{kw 2549}# - #{body 2550}# - (reverse #{vars 2558}#) - #{r* 2562}# - #{w* 2563}# + (let ((#{r* 2577}# + (#{extend-var-env 333}# + #{labels 2574}# + #{vars 2573}# + #{r 2540}#)) + (#{w* 2578}# + (#{make-binding-wrap 387}# + #{req 2561}# + #{labels 2574}# + #{w 2541}#))) + (#{expand-opt 2556}# + (map syntax->datum #{req 2561}#) + #{opt 2562}# + #{rest 2563}# + #{kw 2564}# + #{body 2565}# + (reverse #{vars 2573}#) + #{r* 2577}# + #{w* 2578}# '() '()))))))) - (#{expand-opt 2541}# - (lambda (#{req 2564}# - #{opt 2565}# - #{rest 2566}# - #{kw 2567}# - #{body 2568}# - #{vars 2569}# - #{r* 2570}# - #{w* 2571}# - #{out 2572}# - #{inits 2573}#) - (if (pair? #{opt 2565}#) - (let ((#{tmp 2586}# (car #{opt 2565}#))) - (let ((#{tmp 2587}# - ($sc-dispatch #{tmp 2586}# '(any any)))) - (if #{tmp 2587}# + (#{expand-opt 2556}# + (lambda (#{req 2579}# + #{opt 2580}# + #{rest 2581}# + #{kw 2582}# + #{body 2583}# + #{vars 2584}# + #{r* 2585}# + #{w* 2586}# + #{out 2587}# + #{inits 2588}#) + (if (pair? #{opt 2580}#) + (let ((#{tmp 2601}# (car #{opt 2580}#))) + (let ((#{tmp 2602}# + ($sc-dispatch #{tmp 2601}# '(any any)))) + (if #{tmp 2602}# (@apply - (lambda (#{id 2590}# #{i 2591}#) + (lambda (#{id 2605}# #{i 2606}#) (begin - (let ((#{v 2594}# (#{gen-var 447}# #{id 2590}#))) + (let ((#{v 2609}# (#{gen-var 451}# #{id 2605}#))) (begin - (let ((#{l 2596}# - (#{gen-labels 354}# - (list #{v 2594}#)))) + (let ((#{l 2611}# + (#{gen-labels 358}# + (list #{v 2609}#)))) (begin - (let ((#{r** 2598}# - (#{extend-var-env 329}# - #{l 2596}# - (list #{v 2594}#) - #{r* 2570}#))) + (let ((#{r** 2613}# + (#{extend-var-env 333}# + #{l 2611}# + (list #{v 2609}#) + #{r* 2585}#))) (begin - (let ((#{w** 2600}# - (#{make-binding-wrap 383}# - (list #{id 2590}#) - #{l 2596}# - #{w* 2571}#))) - (#{expand-opt 2541}# - #{req 2564}# - (cdr #{opt 2565}#) - #{rest 2566}# - #{kw 2567}# - #{body 2568}# - (cons #{v 2594}# #{vars 2569}#) - #{r** 2598}# - #{w** 2600}# - (cons (syntax->datum #{id 2590}#) - #{out 2572}#) - (cons (#{chi 419}# - #{i 2591}# - #{r* 2570}# - #{w* 2571}# - #{mod 2528}#) - #{inits 2573}#))))))))))) - #{tmp 2587}#) + (let ((#{w** 2615}# + (#{make-binding-wrap 387}# + (list #{id 2605}#) + #{l 2611}# + #{w* 2586}#))) + (#{expand-opt 2556}# + #{req 2579}# + (cdr #{opt 2580}#) + #{rest 2581}# + #{kw 2582}# + #{body 2583}# + (cons #{v 2609}# #{vars 2584}#) + #{r** 2613}# + #{w** 2615}# + (cons (syntax->datum #{id 2605}#) + #{out 2587}#) + (cons (#{chi 423}# + #{i 2606}# + #{r* 2585}# + #{w* 2586}# + #{mod 2543}#) + #{inits 2588}#))))))))))) + #{tmp 2602}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 2586}#)))) - (if #{rest 2566}# + #{tmp 2601}#)))) + (if #{rest 2581}# (begin - (let ((#{v 2605}# (#{gen-var 447}# #{rest 2566}#))) + (let ((#{v 2620}# (#{gen-var 451}# #{rest 2581}#))) (begin - (let ((#{l 2607}# - (#{gen-labels 354}# (list #{v 2605}#)))) + (let ((#{l 2622}# + (#{gen-labels 358}# (list #{v 2620}#)))) (begin - (let ((#{r* 2609}# - (#{extend-var-env 329}# - #{l 2607}# - (list #{v 2605}#) - #{r* 2570}#))) + (let ((#{r* 2624}# + (#{extend-var-env 333}# + #{l 2622}# + (list #{v 2620}#) + #{r* 2585}#))) (begin - (let ((#{w* 2611}# - (#{make-binding-wrap 383}# - (list #{rest 2566}#) - #{l 2607}# - #{w* 2571}#))) - (#{expand-kw 2543}# - #{req 2564}# - (if (pair? #{out 2572}#) - (reverse #{out 2572}#) + (let ((#{w* 2626}# + (#{make-binding-wrap 387}# + (list #{rest 2581}#) + #{l 2622}# + #{w* 2586}#))) + (#{expand-kw 2558}# + #{req 2579}# + (if (pair? #{out 2587}#) + (reverse #{out 2587}#) #f) - (syntax->datum #{rest 2566}#) - (if (pair? #{kw 2567}#) - (cdr #{kw 2567}#) - #{kw 2567}#) - #{body 2568}# - (cons #{v 2605}# #{vars 2569}#) - #{r* 2609}# - #{w* 2611}# - (if (pair? #{kw 2567}#) - (car #{kw 2567}#) + (syntax->datum #{rest 2581}#) + (if (pair? #{kw 2582}#) + (cdr #{kw 2582}#) + #{kw 2582}#) + #{body 2583}# + (cons #{v 2620}# #{vars 2584}#) + #{r* 2624}# + #{w* 2626}# + (if (pair? #{kw 2582}#) + (car #{kw 2582}#) #f) '() - #{inits 2573}#))))))))) - (#{expand-kw 2543}# - #{req 2564}# - (if (pair? #{out 2572}#) - (reverse #{out 2572}#) + #{inits 2588}#))))))))) + (#{expand-kw 2558}# + #{req 2579}# + (if (pair? #{out 2587}#) + (reverse #{out 2587}#) #f) #f - (if (pair? #{kw 2567}#) - (cdr #{kw 2567}#) - #{kw 2567}#) - #{body 2568}# - #{vars 2569}# - #{r* 2570}# - #{w* 2571}# - (if (pair? #{kw 2567}#) (car #{kw 2567}#) #f) + (if (pair? #{kw 2582}#) + (cdr #{kw 2582}#) + #{kw 2582}#) + #{body 2583}# + #{vars 2584}# + #{r* 2585}# + #{w* 2586}# + (if (pair? #{kw 2582}#) (car #{kw 2582}#) #f) '() - #{inits 2573}#))))) - (#{expand-kw 2543}# - (lambda (#{req 2613}# - #{opt 2614}# - #{rest 2615}# - #{kw 2616}# - #{body 2617}# - #{vars 2618}# - #{r* 2619}# - #{w* 2620}# - #{aok 2621}# - #{out 2622}# - #{inits 2623}#) - (if (pair? #{kw 2616}#) - (let ((#{tmp 2637}# (car #{kw 2616}#))) - (let ((#{tmp 2638}# - ($sc-dispatch #{tmp 2637}# '(any any any)))) - (if #{tmp 2638}# + #{inits 2588}#))))) + (#{expand-kw 2558}# + (lambda (#{req 2628}# + #{opt 2629}# + #{rest 2630}# + #{kw 2631}# + #{body 2632}# + #{vars 2633}# + #{r* 2634}# + #{w* 2635}# + #{aok 2636}# + #{out 2637}# + #{inits 2638}#) + (if (pair? #{kw 2631}#) + (let ((#{tmp 2652}# (car #{kw 2631}#))) + (let ((#{tmp 2653}# + ($sc-dispatch #{tmp 2652}# '(any any any)))) + (if #{tmp 2653}# (@apply - (lambda (#{k 2642}# #{id 2643}# #{i 2644}#) + (lambda (#{k 2657}# #{id 2658}# #{i 2659}#) (begin - (let ((#{v 2647}# (#{gen-var 447}# #{id 2643}#))) + (let ((#{v 2662}# (#{gen-var 451}# #{id 2658}#))) (begin - (let ((#{l 2649}# - (#{gen-labels 354}# - (list #{v 2647}#)))) + (let ((#{l 2664}# + (#{gen-labels 358}# + (list #{v 2662}#)))) (begin - (let ((#{r** 2651}# - (#{extend-var-env 329}# - #{l 2649}# - (list #{v 2647}#) - #{r* 2619}#))) + (let ((#{r** 2666}# + (#{extend-var-env 333}# + #{l 2664}# + (list #{v 2662}#) + #{r* 2634}#))) (begin - (let ((#{w** 2653}# - (#{make-binding-wrap 383}# - (list #{id 2643}#) - #{l 2649}# - #{w* 2620}#))) - (#{expand-kw 2543}# - #{req 2613}# - #{opt 2614}# - #{rest 2615}# - (cdr #{kw 2616}#) - #{body 2617}# - (cons #{v 2647}# #{vars 2618}#) - #{r** 2651}# - #{w** 2653}# - #{aok 2621}# + (let ((#{w** 2668}# + (#{make-binding-wrap 387}# + (list #{id 2658}#) + #{l 2664}# + #{w* 2635}#))) + (#{expand-kw 2558}# + #{req 2628}# + #{opt 2629}# + #{rest 2630}# + (cdr #{kw 2631}#) + #{body 2632}# + (cons #{v 2662}# #{vars 2633}#) + #{r** 2666}# + #{w** 2668}# + #{aok 2636}# (cons (list (syntax->datum - #{k 2642}#) + #{k 2657}#) (syntax->datum - #{id 2643}#) - #{v 2647}#) - #{out 2622}#) - (cons (#{chi 419}# - #{i 2644}# - #{r* 2619}# - #{w* 2620}# - #{mod 2528}#) - #{inits 2623}#))))))))))) - #{tmp 2638}#) + #{id 2658}#) + #{v 2662}#) + #{out 2637}#) + (cons (#{chi 423}# + #{i 2659}# + #{r* 2634}# + #{w* 2635}# + #{mod 2543}#) + #{inits 2638}#))))))))))) + #{tmp 2653}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 2637}#)))) - (#{expand-body 2545}# - #{req 2613}# - #{opt 2614}# - #{rest 2615}# + #{tmp 2652}#)))) + (#{expand-body 2560}# + #{req 2628}# + #{opt 2629}# + #{rest 2630}# (if (begin - (let ((#{t 2657}# #{aok 2621}#)) - (if #{t 2657}# #{t 2657}# (pair? #{out 2622}#)))) - (cons #{aok 2621}# (reverse #{out 2622}#)) + (let ((#{t 2672}# #{aok 2636}#)) + (if #{t 2672}# #{t 2672}# (pair? #{out 2637}#)))) + (cons #{aok 2636}# (reverse #{out 2637}#)) #f) - #{body 2617}# - (reverse #{vars 2618}#) - #{r* 2619}# - #{w* 2620}# - (reverse #{inits 2623}#) + #{body 2632}# + (reverse #{vars 2633}#) + #{r* 2634}# + #{w* 2635}# + (reverse #{inits 2638}#) '())))) - (#{expand-body 2545}# - (lambda (#{req 2659}# - #{opt 2660}# - #{rest 2661}# - #{kw 2662}# - #{body 2663}# - #{vars 2664}# - #{r* 2665}# - #{w* 2666}# - #{inits 2667}# - #{meta 2668}#) - (let ((#{tmp 2679}# #{body 2663}#)) - (let ((#{tmp 2680}# - ($sc-dispatch #{tmp 2679}# '(any any . each-any)))) - (if (if #{tmp 2680}# + (#{expand-body 2560}# + (lambda (#{req 2674}# + #{opt 2675}# + #{rest 2676}# + #{kw 2677}# + #{body 2678}# + #{vars 2679}# + #{r* 2680}# + #{w* 2681}# + #{inits 2682}# + #{meta 2683}#) + (let ((#{tmp 2694}# #{body 2678}#)) + (let ((#{tmp 2695}# + ($sc-dispatch #{tmp 2694}# '(any any . each-any)))) + (if (if #{tmp 2695}# (@apply - (lambda (#{docstring 2684}# #{e1 2685}# #{e2 2686}#) - (string? (syntax->datum #{docstring 2684}#))) - #{tmp 2680}#) + (lambda (#{docstring 2699}# #{e1 2700}# #{e2 2701}#) + (string? (syntax->datum #{docstring 2699}#))) + #{tmp 2695}#) #f) (@apply - (lambda (#{docstring 2690}# #{e1 2691}# #{e2 2692}#) - (#{expand-body 2545}# - #{req 2659}# - #{opt 2660}# - #{rest 2661}# - #{kw 2662}# - (cons #{e1 2691}# #{e2 2692}#) - #{vars 2664}# - #{r* 2665}# - #{w* 2666}# - #{inits 2667}# + (lambda (#{docstring 2705}# #{e1 2706}# #{e2 2707}#) + (#{expand-body 2560}# + #{req 2674}# + #{opt 2675}# + #{rest 2676}# + #{kw 2677}# + (cons #{e1 2706}# #{e2 2707}#) + #{vars 2679}# + #{r* 2680}# + #{w* 2681}# + #{inits 2682}# (append - #{meta 2668}# + #{meta 2683}# (list (cons 'documentation - (syntax->datum #{docstring 2690}#)))))) - #{tmp 2680}#) - (let ((#{tmp 2695}# + (syntax->datum #{docstring 2705}#)))))) + #{tmp 2695}#) + (let ((#{tmp 2710}# ($sc-dispatch - #{tmp 2679}# + #{tmp 2694}# '(#(vector #(each (any . any))) any . each-any)))) - (if #{tmp 2695}# + (if #{tmp 2710}# (@apply - (lambda (#{k 2700}# - #{v 2701}# - #{e1 2702}# - #{e2 2703}#) - (#{expand-body 2545}# - #{req 2659}# - #{opt 2660}# - #{rest 2661}# - #{kw 2662}# - (cons #{e1 2702}# #{e2 2703}#) - #{vars 2664}# - #{r* 2665}# - #{w* 2666}# - #{inits 2667}# + (lambda (#{k 2715}# + #{v 2716}# + #{e1 2717}# + #{e2 2718}#) + (#{expand-body 2560}# + #{req 2674}# + #{opt 2675}# + #{rest 2676}# + #{kw 2677}# + (cons #{e1 2717}# #{e2 2718}#) + #{vars 2679}# + #{r* 2680}# + #{w* 2681}# + #{inits 2682}# (append - #{meta 2668}# + #{meta 2683}# (syntax->datum - (map cons #{k 2700}# #{v 2701}#))))) - #{tmp 2695}#) - (let ((#{tmp 2707}# - ($sc-dispatch #{tmp 2679}# '(any . each-any)))) - (if #{tmp 2707}# + (map cons #{k 2715}# #{v 2716}#))))) + #{tmp 2710}#) + (let ((#{tmp 2722}# + ($sc-dispatch #{tmp 2694}# '(any . each-any)))) + (if #{tmp 2722}# (@apply - (lambda (#{e1 2710}# #{e2 2711}#) + (lambda (#{e1 2725}# #{e2 2726}#) (values - #{meta 2668}# - #{req 2659}# - #{opt 2660}# - #{rest 2661}# - #{kw 2662}# - #{inits 2667}# - #{vars 2664}# - (#{chi-body 427}# - (cons #{e1 2710}# #{e2 2711}#) - (#{source-wrap 407}# - #{e 2524}# - #{w 2526}# - #{s 2527}# - #{mod 2528}#) - #{r* 2665}# - #{w* 2666}# - #{mod 2528}#))) - #{tmp 2707}#) + #{meta 2683}# + #{req 2674}# + #{opt 2675}# + #{rest 2676}# + #{kw 2677}# + #{inits 2682}# + #{vars 2679}# + (#{chi-body 431}# + (cons #{e1 2725}# #{e2 2726}#) + (#{source-wrap 411}# + #{e 2539}# + #{w 2541}# + #{s 2542}# + #{mod 2543}#) + #{r* 2680}# + #{w* 2681}# + #{mod 2543}#))) + #{tmp 2722}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 2679}#))))))))))) + #{tmp 2694}#))))))))))) (begin - (let ((#{tmp 2713}# #{clauses 2530}#)) - (let ((#{tmp 2714}# ($sc-dispatch #{tmp 2713}# '()))) - (if #{tmp 2714}# - (@apply (lambda () (values '() #f)) #{tmp 2714}#) - (let ((#{tmp 2715}# + (let ((#{tmp 2728}# #{clauses 2545}#)) + (let ((#{tmp 2729}# ($sc-dispatch #{tmp 2728}# '()))) + (if #{tmp 2729}# + (@apply (lambda () (values '() #f)) #{tmp 2729}#) + (let ((#{tmp 2730}# ($sc-dispatch - #{tmp 2713}# + #{tmp 2728}# '((any any . each-any) . #(each (any any . each-any)))))) - (if #{tmp 2715}# + (if #{tmp 2730}# (@apply - (lambda (#{args 2722}# - #{e1 2723}# - #{e2 2724}# - #{args* 2725}# - #{e1* 2726}# - #{e2* 2727}#) + (lambda (#{args 2737}# + #{e1 2738}# + #{e2 2739}# + #{args* 2740}# + #{e1* 2741}# + #{e2* 2742}#) (call-with-values - (lambda () (#{get-formals 2529}# #{args 2722}#)) - (lambda (#{req 2728}# - #{opt 2729}# - #{rest 2730}# - #{kw 2731}#) + (lambda () (#{get-formals 2544}# #{args 2737}#)) + (lambda (#{req 2743}# + #{opt 2744}# + #{rest 2745}# + #{kw 2746}#) (call-with-values (lambda () - (#{expand-req 2539}# - #{req 2728}# - #{opt 2729}# - #{rest 2730}# - #{kw 2731}# - (cons #{e1 2723}# #{e2 2724}#))) - (lambda (#{meta 2737}# - #{req 2738}# - #{opt 2739}# - #{rest 2740}# - #{kw 2741}# - #{inits 2742}# - #{vars 2743}# - #{body 2744}#) + (#{expand-req 2554}# + #{req 2743}# + #{opt 2744}# + #{rest 2745}# + #{kw 2746}# + (cons #{e1 2738}# #{e2 2739}#))) + (lambda (#{meta 2752}# + #{req 2753}# + #{opt 2754}# + #{rest 2755}# + #{kw 2756}# + #{inits 2757}# + #{vars 2758}# + #{body 2759}#) (call-with-values (lambda () - (#{chi-lambda-case 443}# - #{e 2524}# - #{r 2525}# - #{w 2526}# - #{s 2527}# - #{mod 2528}# - #{get-formals 2529}# - (map (lambda (#{tmp 2755}# - #{tmp 2754}# - #{tmp 2753}#) - (cons #{tmp 2753}# - (cons #{tmp 2754}# - #{tmp 2755}#))) - #{e2* 2727}# - #{e1* 2726}# - #{args* 2725}#))) - (lambda (#{meta* 2757}# #{else* 2758}#) + (#{chi-lambda-case 447}# + #{e 2539}# + #{r 2540}# + #{w 2541}# + #{s 2542}# + #{mod 2543}# + #{get-formals 2544}# + (map (lambda (#{tmp 2770}# + #{tmp 2769}# + #{tmp 2768}#) + (cons #{tmp 2768}# + (cons #{tmp 2769}# + #{tmp 2770}#))) + #{e2* 2742}# + #{e1* 2741}# + #{args* 2740}#))) + (lambda (#{meta* 2772}# #{else* 2773}#) (values - (append #{meta 2737}# #{meta* 2757}#) - (#{build-lambda-case 287}# - #{s 2527}# - #{req 2738}# - #{opt 2739}# - #{rest 2740}# - #{kw 2741}# - #{inits 2742}# - #{vars 2743}# - #{body 2744}# - #{else* 2758}#))))))))) - #{tmp 2715}#) + (append #{meta 2752}# #{meta* 2772}#) + (#{build-lambda-case 289}# + #{s 2542}# + #{req 2753}# + #{opt 2754}# + #{rest 2755}# + #{kw 2756}# + #{inits 2757}# + #{vars 2758}# + #{body 2759}# + #{else* 2773}#))))))))) + #{tmp 2730}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 2713}#)))))))))) - (#{strip 445}# - (lambda (#{x 2761}# #{w 2762}#) - (if (memq 'top (car #{w 2762}#)) - #{x 2761}# + #{tmp 2728}#)))))))))) + (#{strip 449}# + (lambda (#{x 2776}# #{w 2777}#) + (if (memq 'top (car #{w 2777}#)) + #{x 2776}# (letrec* - ((#{f 2769}# - (lambda (#{x 2770}#) - (if (#{syntax-object? 305}# #{x 2770}#) - (#{strip 445}# - (#{syntax-object-expression 307}# #{x 2770}#) - (#{syntax-object-wrap 309}# #{x 2770}#)) - (if (pair? #{x 2770}#) + ((#{f 2784}# + (lambda (#{x 2785}#) + (if (#{syntax-object? 309}# #{x 2785}#) + (#{strip 449}# + (#{syntax-object-expression 311}# #{x 2785}#) + (#{syntax-object-wrap 313}# #{x 2785}#)) + (if (pair? #{x 2785}#) (begin - (let ((#{a 2777}# (#{f 2769}# (car #{x 2770}#))) - (#{d 2778}# (#{f 2769}# (cdr #{x 2770}#)))) - (if (if (eq? #{a 2777}# (car #{x 2770}#)) - (eq? #{d 2778}# (cdr #{x 2770}#)) + (let ((#{a 2792}# (#{f 2784}# (car #{x 2785}#))) + (#{d 2793}# (#{f 2784}# (cdr #{x 2785}#)))) + (if (if (eq? #{a 2792}# (car #{x 2785}#)) + (eq? #{d 2793}# (cdr #{x 2785}#)) #f) - #{x 2770}# - (cons #{a 2777}# #{d 2778}#)))) - (if (vector? #{x 2770}#) + #{x 2785}# + (cons #{a 2792}# #{d 2793}#)))) + (if (vector? #{x 2785}#) (begin - (let ((#{old 2784}# (vector->list #{x 2770}#))) + (let ((#{old 2799}# (vector->list #{x 2785}#))) (begin - (let ((#{new 2786}# (map #{f 2769}# #{old 2784}#))) + (let ((#{new 2801}# (map #{f 2784}# #{old 2799}#))) (letrec* - ((#{lp 2790}# - (lambda (#{l1 2791}# #{l2 2792}#) - (if (null? #{l1 2791}#) - #{x 2770}# - (if (eq? (car #{l1 2791}#) - (car #{l2 2792}#)) - (#{lp 2790}# - (cdr #{l1 2791}#) - (cdr #{l2 2792}#)) - (list->vector #{new 2786}#)))))) + ((#{lp 2805}# + (lambda (#{l1 2806}# #{l2 2807}#) + (if (null? #{l1 2806}#) + #{x 2785}# + (if (eq? (car #{l1 2806}#) + (car #{l2 2807}#)) + (#{lp 2805}# + (cdr #{l1 2806}#) + (cdr #{l2 2807}#)) + (list->vector #{new 2801}#)))))) (begin - (#{lp 2790}# #{old 2784}# #{new 2786}#))))))) - #{x 2770}#)))))) - (begin (#{f 2769}# #{x 2761}#)))))) - (#{gen-var 447}# - (lambda (#{id 2794}#) + (#{lp 2805}# #{old 2799}# #{new 2801}#))))))) + #{x 2785}#)))))) + (begin (#{f 2784}# #{x 2776}#)))))) + (#{gen-var 451}# + (lambda (#{id 2809}#) (begin - (let ((#{id 2797}# - (if (#{syntax-object? 305}# #{id 2794}#) - (#{syntax-object-expression 307}# #{id 2794}#) - #{id 2794}#))) + (let ((#{id 2812}# + (if (#{syntax-object? 309}# #{id 2809}#) + (#{syntax-object-expression 311}# #{id 2809}#) + #{id 2809}#))) (gensym - (string-append (symbol->string #{id 2797}#) " ")))))) - (#{lambda-var-list 449}# - (lambda (#{vars 2799}#) + (string-append (symbol->string #{id 2812}#) " ")))))) + (#{lambda-var-list 453}# + (lambda (#{vars 2814}#) (letrec* - ((#{lvl 2805}# - (lambda (#{vars 2806}# #{ls 2807}# #{w 2808}#) - (if (pair? #{vars 2806}#) - (#{lvl 2805}# - (cdr #{vars 2806}#) - (cons (#{wrap 405}# (car #{vars 2806}#) #{w 2808}# #f) - #{ls 2807}#) - #{w 2808}#) - (if (#{id? 339}# #{vars 2806}#) - (cons (#{wrap 405}# #{vars 2806}# #{w 2808}# #f) - #{ls 2807}#) - (if (null? #{vars 2806}#) - #{ls 2807}# - (if (#{syntax-object? 305}# #{vars 2806}#) - (#{lvl 2805}# - (#{syntax-object-expression 307}# #{vars 2806}#) - #{ls 2807}# - (#{join-wraps 387}# - #{w 2808}# - (#{syntax-object-wrap 309}# #{vars 2806}#))) - (cons #{vars 2806}# #{ls 2807}#)))))))) - (begin (#{lvl 2805}# #{vars 2799}# '() '(()))))))) + ((#{lvl 2820}# + (lambda (#{vars 2821}# #{ls 2822}# #{w 2823}#) + (if (pair? #{vars 2821}#) + (#{lvl 2820}# + (cdr #{vars 2821}#) + (cons (#{wrap 409}# (car #{vars 2821}#) #{w 2823}# #f) + #{ls 2822}#) + #{w 2823}#) + (if (#{id? 343}# #{vars 2821}#) + (cons (#{wrap 409}# #{vars 2821}# #{w 2823}# #f) + #{ls 2822}#) + (if (null? #{vars 2821}#) + #{ls 2822}# + (if (#{syntax-object? 309}# #{vars 2821}#) + (#{lvl 2820}# + (#{syntax-object-expression 311}# #{vars 2821}#) + #{ls 2822}# + (#{join-wraps 391}# + #{w 2823}# + (#{syntax-object-wrap 313}# #{vars 2821}#))) + (cons #{vars 2821}# #{ls 2822}#)))))))) + (begin (#{lvl 2820}# #{vars 2814}# '() '(()))))))) (begin - (lambda (#{src 767}# #{name 768}#) - (make-struct/no-tail - (vector-ref %expanded-vtables 2) - #{src 767}# - #{name 768}#)) - (lambda (#{x 1145}# #{update 1146}#) - (vector-set! #{x 1145}# 1 #{update 1146}#)) - (lambda (#{x 1149}# #{update 1150}#) - (vector-set! #{x 1149}# 2 #{update 1150}#)) - (lambda (#{x 1153}# #{update 1154}#) - (vector-set! #{x 1153}# 3 #{update 1154}#)) - (lambda (#{x 1234}#) - (if (vector? #{x 1234}#) - (if (= (vector-length #{x 1234}#) 4) - (eq? (vector-ref #{x 1234}# 0) 'ribcage) + (lambda (#{x 1161}# #{update 1162}#) + (vector-set! #{x 1161}# 1 #{update 1162}#)) + (lambda (#{x 1165}# #{update 1166}#) + (vector-set! #{x 1165}# 2 #{update 1166}#)) + (lambda (#{x 1169}# #{update 1170}#) + (vector-set! #{x 1169}# 3 #{update 1170}#)) + (lambda (#{x 1250}#) + (if (vector? #{x 1250}#) + (if (= (vector-length #{x 1250}#) 4) + (eq? (vector-ref #{x 1250}# 0) 'ribcage) #f) #f)) (begin - (#{global-extend 335}# + (#{global-extend 339}# 'local-syntax 'letrec-syntax #t) - (#{global-extend 335}# + (#{global-extend 339}# 'local-syntax 'let-syntax #f) - (#{global-extend 335}# + (#{global-extend 339}# 'core 'fluid-let-syntax - (lambda (#{e 2819}# - #{r 2820}# - #{w 2821}# - #{s 2822}# - #{mod 2823}#) - (let ((#{tmp 2829}# #{e 2819}#)) - (let ((#{tmp 2830}# + (lambda (#{e 2834}# + #{r 2835}# + #{w 2836}# + #{s 2837}# + #{mod 2838}#) + (let ((#{tmp 2844}# #{e 2834}#)) + (let ((#{tmp 2845}# ($sc-dispatch - #{tmp 2829}# + #{tmp 2844}# '(_ #(each (any any)) any . each-any)))) - (if (if #{tmp 2830}# + (if (if #{tmp 2845}# (@apply - (lambda (#{var 2835}# - #{val 2836}# - #{e1 2837}# - #{e2 2838}#) - (#{valid-bound-ids? 399}# #{var 2835}#)) - #{tmp 2830}#) + (lambda (#{var 2850}# + #{val 2851}# + #{e1 2852}# + #{e2 2853}#) + (#{valid-bound-ids? 403}# #{var 2850}#)) + #{tmp 2845}#) #f) (@apply - (lambda (#{var 2844}# - #{val 2845}# - #{e1 2846}# - #{e2 2847}#) + (lambda (#{var 2859}# + #{val 2860}# + #{e1 2861}# + #{e2 2862}#) (begin - (let ((#{names 2849}# - (map (lambda (#{x 2850}#) - (#{id-var-name 393}# - #{x 2850}# - #{w 2821}#)) - #{var 2844}#))) + (let ((#{names 2864}# + (map (lambda (#{x 2865}#) + (#{id-var-name 397}# + #{x 2865}# + #{w 2836}#)) + #{var 2859}#))) (begin (for-each - (lambda (#{id 2853}# #{n 2854}#) + (lambda (#{id 2868}# #{n 2869}#) (begin - (let ((#{atom-key 2859}# - (car (#{lookup 333}# - #{n 2854}# - #{r 2820}# - #{mod 2823}#)))) - (if (eqv? #{atom-key 2859}# - 'displaced-lexical) + (let ((#{atom-key 2874}# + (car (#{lookup 337}# + #{n 2869}# + #{r 2835}# + #{mod 2838}#)))) + (if (memv #{atom-key 2874}# + '(displaced-lexical)) (syntax-violation 'fluid-let-syntax "identifier out of context" - #{e 2819}# - (#{source-wrap 407}# - #{id 2853}# - #{w 2821}# - #{s 2822}# - #{mod 2823}#)))))) - #{var 2844}# - #{names 2849}#) - (#{chi-body 427}# - (cons #{e1 2846}# #{e2 2847}#) - (#{source-wrap 407}# - #{e 2819}# - #{w 2821}# - #{s 2822}# - #{mod 2823}#) - (#{extend-env 327}# - #{names 2849}# + #{e 2834}# + (#{source-wrap 411}# + #{id 2868}# + #{w 2836}# + #{s 2837}# + #{mod 2838}#)))))) + #{var 2859}# + #{names 2864}#) + (#{chi-body 431}# + (cons #{e1 2861}# #{e2 2862}#) + (#{source-wrap 411}# + #{e 2834}# + #{w 2836}# + #{s 2837}# + #{mod 2838}#) + (#{extend-env 331}# + #{names 2864}# (begin - (let ((#{trans-r 2865}# - (#{macros-only-env 331}# #{r 2820}#))) - (map (lambda (#{x 2866}#) + (let ((#{trans-r 2880}# + (#{macros-only-env 335}# #{r 2835}#))) + (map (lambda (#{x 2881}#) (cons 'macro - (#{eval-local-transformer 431}# - (#{chi 419}# - #{x 2866}# - #{trans-r 2865}# - #{w 2821}# - #{mod 2823}#) - #{mod 2823}#))) - #{val 2845}#))) - #{r 2820}#) - #{w 2821}# - #{mod 2823}#))))) - #{tmp 2830}#) - (let ((#{_ 2871}# #{tmp 2829}#)) + (#{eval-local-transformer 435}# + (#{chi 423}# + #{x 2881}# + #{trans-r 2880}# + #{w 2836}# + #{mod 2838}#) + #{mod 2838}#))) + #{val 2860}#))) + #{r 2835}#) + #{w 2836}# + #{mod 2838}#))))) + #{tmp 2845}#) + (let ((#{_ 2886}# #{tmp 2844}#)) (syntax-violation 'fluid-let-syntax "bad syntax" - (#{source-wrap 407}# - #{e 2819}# - #{w 2821}# - #{s 2822}# - #{mod 2823}#)))))))) - (#{global-extend 335}# + (#{source-wrap 411}# + #{e 2834}# + #{w 2836}# + #{s 2837}# + #{mod 2838}#)))))))) + (#{global-extend 339}# 'core 'quote - (lambda (#{e 2872}# - #{r 2873}# - #{w 2874}# - #{s 2875}# - #{mod 2876}#) - (let ((#{tmp 2882}# #{e 2872}#)) - (let ((#{tmp 2883}# - ($sc-dispatch #{tmp 2882}# '(_ any)))) - (if #{tmp 2883}# + (lambda (#{e 2887}# + #{r 2888}# + #{w 2889}# + #{s 2890}# + #{mod 2891}#) + (let ((#{tmp 2897}# #{e 2887}#)) + (let ((#{tmp 2898}# + ($sc-dispatch #{tmp 2897}# '(_ any)))) + (if #{tmp 2898}# (@apply - (lambda (#{e 2885}#) - (#{build-data 291}# - #{s 2875}# - (#{strip 445}# #{e 2885}# #{w 2874}#))) - #{tmp 2883}#) - (let ((#{_ 2887}# #{tmp 2882}#)) + (lambda (#{e 2900}#) + (#{build-data 295}# + #{s 2890}# + (#{strip 449}# #{e 2900}# #{w 2889}#))) + #{tmp 2898}#) + (let ((#{_ 2902}# #{tmp 2897}#)) (syntax-violation 'quote "bad syntax" - (#{source-wrap 407}# - #{e 2872}# - #{w 2874}# - #{s 2875}# - #{mod 2876}#)))))))) - (#{global-extend 335}# + (#{source-wrap 411}# + #{e 2887}# + #{w 2889}# + #{s 2890}# + #{mod 2891}#)))))))) + (#{global-extend 339}# 'core 'syntax (letrec* - ((#{gen-syntax 2889}# - (lambda (#{src 2904}# - #{e 2905}# - #{r 2906}# - #{maps 2907}# - #{ellipsis? 2908}# - #{mod 2909}#) - (if (#{id? 339}# #{e 2905}#) + ((#{gen-syntax 2904}# + (lambda (#{src 2919}# + #{e 2920}# + #{r 2921}# + #{maps 2922}# + #{ellipsis? 2923}# + #{mod 2924}#) + (if (#{id? 343}# #{e 2920}#) (begin - (let ((#{label 2917}# - (#{id-var-name 393}# #{e 2905}# '(())))) + (let ((#{label 2932}# + (#{id-var-name 397}# #{e 2920}# '(())))) (begin - (let ((#{b 2920}# - (#{lookup 333}# - #{label 2917}# - #{r 2906}# - #{mod 2909}#))) - (if (eq? (car #{b 2920}#) 'syntax) + (let ((#{b 2935}# + (#{lookup 337}# + #{label 2932}# + #{r 2921}# + #{mod 2924}#))) + (if (eq? (car #{b 2935}#) 'syntax) (call-with-values (lambda () (begin - (let ((#{var.lev 2923}# (cdr #{b 2920}#))) - (#{gen-ref 2891}# - #{src 2904}# - (car #{var.lev 2923}#) - (cdr #{var.lev 2923}#) - #{maps 2907}#)))) - (lambda (#{var 2925}# #{maps 2926}#) + (let ((#{var.lev 2938}# (cdr #{b 2935}#))) + (#{gen-ref 2906}# + #{src 2919}# + (car #{var.lev 2938}#) + (cdr #{var.lev 2938}#) + #{maps 2922}#)))) + (lambda (#{var 2940}# #{maps 2941}#) (values - (list 'ref #{var 2925}#) - #{maps 2926}#))) - (if (#{ellipsis? 2908}# #{e 2905}#) + (list 'ref #{var 2940}#) + #{maps 2941}#))) + (if (#{ellipsis? 2923}# #{e 2920}#) (syntax-violation 'syntax "misplaced ellipsis" - #{src 2904}#) + #{src 2919}#) (values - (list 'quote #{e 2905}#) - #{maps 2907}#))))))) - (let ((#{tmp 2931}# #{e 2905}#)) - (let ((#{tmp 2932}# - ($sc-dispatch #{tmp 2931}# '(any any)))) - (if (if #{tmp 2932}# + (list 'quote #{e 2920}#) + #{maps 2922}#))))))) + (let ((#{tmp 2946}# #{e 2920}#)) + (let ((#{tmp 2947}# + ($sc-dispatch #{tmp 2946}# '(any any)))) + (if (if #{tmp 2947}# (@apply - (lambda (#{dots 2935}# #{e 2936}#) - (#{ellipsis? 2908}# #{dots 2935}#)) - #{tmp 2932}#) + (lambda (#{dots 2950}# #{e 2951}#) + (#{ellipsis? 2923}# #{dots 2950}#)) + #{tmp 2947}#) #f) (@apply - (lambda (#{dots 2939}# #{e 2940}#) - (#{gen-syntax 2889}# - #{src 2904}# - #{e 2940}# - #{r 2906}# - #{maps 2907}# - (lambda (#{x 2941}#) #f) - #{mod 2909}#)) - #{tmp 2932}#) - (let ((#{tmp 2943}# - ($sc-dispatch #{tmp 2931}# '(any any . any)))) - (if (if #{tmp 2943}# + (lambda (#{dots 2954}# #{e 2955}#) + (#{gen-syntax 2904}# + #{src 2919}# + #{e 2955}# + #{r 2921}# + #{maps 2922}# + (lambda (#{x 2956}#) #f) + #{mod 2924}#)) + #{tmp 2947}#) + (let ((#{tmp 2958}# + ($sc-dispatch #{tmp 2946}# '(any any . any)))) + (if (if #{tmp 2958}# (@apply - (lambda (#{x 2947}# #{dots 2948}# #{y 2949}#) - (#{ellipsis? 2908}# #{dots 2948}#)) - #{tmp 2943}#) + (lambda (#{x 2962}# #{dots 2963}# #{y 2964}#) + (#{ellipsis? 2923}# #{dots 2963}#)) + #{tmp 2958}#) #f) (@apply - (lambda (#{x 2953}# #{dots 2954}# #{y 2955}#) + (lambda (#{x 2968}# #{dots 2969}# #{y 2970}#) (letrec* - ((#{f 2959}# - (lambda (#{y 2960}# #{k 2961}#) - (let ((#{tmp 2968}# #{y 2960}#)) - (let ((#{tmp 2969}# + ((#{f 2974}# + (lambda (#{y 2975}# #{k 2976}#) + (let ((#{tmp 2983}# #{y 2975}#)) + (let ((#{tmp 2984}# ($sc-dispatch - #{tmp 2968}# + #{tmp 2983}# '(any . any)))) - (if (if #{tmp 2969}# + (if (if #{tmp 2984}# (@apply - (lambda (#{dots 2972}# - #{y 2973}#) - (#{ellipsis? 2908}# - #{dots 2972}#)) - #{tmp 2969}#) + (lambda (#{dots 2987}# + #{y 2988}#) + (#{ellipsis? 2923}# + #{dots 2987}#)) + #{tmp 2984}#) #f) (@apply - (lambda (#{dots 2976}# - #{y 2977}#) - (#{f 2959}# - #{y 2977}# - (lambda (#{maps 2978}#) + (lambda (#{dots 2991}# + #{y 2992}#) + (#{f 2974}# + #{y 2992}# + (lambda (#{maps 2993}#) (call-with-values (lambda () - (#{k 2961}# + (#{k 2976}# (cons '() - #{maps 2978}#))) - (lambda (#{x 2980}# - #{maps 2981}#) - (if (null? (car #{maps 2981}#)) + #{maps 2993}#))) + (lambda (#{x 2995}# + #{maps 2996}#) + (if (null? (car #{maps 2996}#)) (syntax-violation 'syntax "extra ellipsis" - #{src 2904}#) + #{src 2919}#) (values - (#{gen-mappend 2893}# - #{x 2980}# - (car #{maps 2981}#)) - (cdr #{maps 2981}#)))))))) - #{tmp 2969}#) - (let ((#{_ 2985}# #{tmp 2968}#)) + (#{gen-mappend 2908}# + #{x 2995}# + (car #{maps 2996}#)) + (cdr #{maps 2996}#)))))))) + #{tmp 2984}#) + (let ((#{_ 3000}# #{tmp 2983}#)) (call-with-values (lambda () - (#{gen-syntax 2889}# - #{src 2904}# - #{y 2960}# - #{r 2906}# - #{maps 2907}# - #{ellipsis? 2908}# - #{mod 2909}#)) - (lambda (#{y 2986}# - #{maps 2987}#) + (#{gen-syntax 2904}# + #{src 2919}# + #{y 2975}# + #{r 2921}# + #{maps 2922}# + #{ellipsis? 2923}# + #{mod 2924}#)) + (lambda (#{y 3001}# + #{maps 3002}#) (call-with-values (lambda () - (#{k 2961}# - #{maps 2987}#)) - (lambda (#{x 2990}# - #{maps 2991}#) + (#{k 2976}# + #{maps 3002}#)) + (lambda (#{x 3005}# + #{maps 3006}#) (values - (#{gen-append 2899}# - #{x 2990}# - #{y 2986}#) - #{maps 2991}#)))))))))))) + (#{gen-append 2914}# + #{x 3005}# + #{y 3001}#) + #{maps 3006}#)))))))))))) (begin - (#{f 2959}# - #{y 2955}# - (lambda (#{maps 2962}#) + (#{f 2974}# + #{y 2970}# + (lambda (#{maps 2977}#) (call-with-values (lambda () - (#{gen-syntax 2889}# - #{src 2904}# - #{x 2953}# - #{r 2906}# - (cons '() #{maps 2962}#) - #{ellipsis? 2908}# - #{mod 2909}#)) - (lambda (#{x 2964}# #{maps 2965}#) - (if (null? (car #{maps 2965}#)) + (#{gen-syntax 2904}# + #{src 2919}# + #{x 2968}# + #{r 2921}# + (cons '() #{maps 2977}#) + #{ellipsis? 2923}# + #{mod 2924}#)) + (lambda (#{x 2979}# #{maps 2980}#) + (if (null? (car #{maps 2980}#)) (syntax-violation 'syntax "extra ellipsis" - #{src 2904}#) + #{src 2919}#) (values - (#{gen-map 2895}# - #{x 2964}# - (car #{maps 2965}#)) - (cdr #{maps 2965}#)))))))))) - #{tmp 2943}#) - (let ((#{tmp 2994}# - ($sc-dispatch #{tmp 2931}# '(any . any)))) - (if #{tmp 2994}# + (#{gen-map 2910}# + #{x 2979}# + (car #{maps 2980}#)) + (cdr #{maps 2980}#)))))))))) + #{tmp 2958}#) + (let ((#{tmp 3009}# + ($sc-dispatch #{tmp 2946}# '(any . any)))) + (if #{tmp 3009}# (@apply - (lambda (#{x 2997}# #{y 2998}#) + (lambda (#{x 3012}# #{y 3013}#) (call-with-values (lambda () - (#{gen-syntax 2889}# - #{src 2904}# - #{x 2997}# - #{r 2906}# - #{maps 2907}# - #{ellipsis? 2908}# - #{mod 2909}#)) - (lambda (#{x 2999}# #{maps 3000}#) + (#{gen-syntax 2904}# + #{src 2919}# + #{x 3012}# + #{r 2921}# + #{maps 2922}# + #{ellipsis? 2923}# + #{mod 2924}#)) + (lambda (#{x 3014}# #{maps 3015}#) (call-with-values (lambda () - (#{gen-syntax 2889}# - #{src 2904}# - #{y 2998}# - #{r 2906}# - #{maps 3000}# - #{ellipsis? 2908}# - #{mod 2909}#)) - (lambda (#{y 3003}# #{maps 3004}#) + (#{gen-syntax 2904}# + #{src 2919}# + #{y 3013}# + #{r 2921}# + #{maps 3015}# + #{ellipsis? 2923}# + #{mod 2924}#)) + (lambda (#{y 3018}# #{maps 3019}#) (values - (#{gen-cons 2897}# - #{x 2999}# - #{y 3003}#) - #{maps 3004}#)))))) - #{tmp 2994}#) - (let ((#{tmp 3007}# + (#{gen-cons 2912}# + #{x 3014}# + #{y 3018}#) + #{maps 3019}#)))))) + #{tmp 3009}#) + (let ((#{tmp 3022}# ($sc-dispatch - #{tmp 2931}# + #{tmp 2946}# '#(vector (any . each-any))))) - (if #{tmp 3007}# + (if #{tmp 3022}# (@apply - (lambda (#{e1 3010}# #{e2 3011}#) + (lambda (#{e1 3025}# #{e2 3026}#) (call-with-values (lambda () - (#{gen-syntax 2889}# - #{src 2904}# - (cons #{e1 3010}# #{e2 3011}#) - #{r 2906}# - #{maps 2907}# - #{ellipsis? 2908}# - #{mod 2909}#)) - (lambda (#{e 3013}# #{maps 3014}#) + (#{gen-syntax 2904}# + #{src 2919}# + (cons #{e1 3025}# #{e2 3026}#) + #{r 2921}# + #{maps 2922}# + #{ellipsis? 2923}# + #{mod 2924}#)) + (lambda (#{e 3028}# #{maps 3029}#) (values - (#{gen-vector 2901}# #{e 3013}#) - #{maps 3014}#)))) - #{tmp 3007}#) - (let ((#{_ 3018}# #{tmp 2931}#)) + (#{gen-vector 2916}# #{e 3028}#) + #{maps 3029}#)))) + #{tmp 3022}#) + (let ((#{_ 3033}# #{tmp 2946}#)) (values - (list 'quote #{e 2905}#) - #{maps 2907}#)))))))))))))) - (#{gen-ref 2891}# - (lambda (#{src 3020}# - #{var 3021}# - #{level 3022}# - #{maps 3023}#) - (if (= #{level 3022}# 0) - (values #{var 3021}# #{maps 3023}#) - (if (null? #{maps 3023}#) + (list 'quote #{e 2920}#) + #{maps 2922}#)))))))))))))) + (#{gen-ref 2906}# + (lambda (#{src 3035}# + #{var 3036}# + #{level 3037}# + #{maps 3038}#) + (if (= #{level 3037}# 0) + (values #{var 3036}# #{maps 3038}#) + (if (null? #{maps 3038}#) (syntax-violation 'syntax "missing ellipsis" - #{src 3020}#) + #{src 3035}#) (call-with-values (lambda () - (#{gen-ref 2891}# - #{src 3020}# - #{var 3021}# - (#{1-}# #{level 3022}#) - (cdr #{maps 3023}#))) - (lambda (#{outer-var 3030}# #{outer-maps 3031}#) + (#{gen-ref 2906}# + #{src 3035}# + #{var 3036}# + (#{1-}# #{level 3037}#) + (cdr #{maps 3038}#))) + (lambda (#{outer-var 3045}# #{outer-maps 3046}#) (begin - (let ((#{b 3035}# - (assq #{outer-var 3030}# - (car #{maps 3023}#)))) - (if #{b 3035}# - (values (cdr #{b 3035}#) #{maps 3023}#) + (let ((#{b 3050}# + (assq #{outer-var 3045}# + (car #{maps 3038}#)))) + (if #{b 3050}# + (values (cdr #{b 3050}#) #{maps 3038}#) (begin - (let ((#{inner-var 3037}# - (#{gen-var 447}# 'tmp))) + (let ((#{inner-var 3052}# + (#{gen-var 451}# 'tmp))) (values - #{inner-var 3037}# - (cons (cons (cons #{outer-var 3030}# - #{inner-var 3037}#) - (car #{maps 3023}#)) - #{outer-maps 3031}#))))))))))))) - (#{gen-mappend 2893}# - (lambda (#{e 3038}# #{map-env 3039}#) + #{inner-var 3052}# + (cons (cons (cons #{outer-var 3045}# + #{inner-var 3052}#) + (car #{maps 3038}#)) + #{outer-maps 3046}#))))))))))))) + (#{gen-mappend 2908}# + (lambda (#{e 3053}# #{map-env 3054}#) (list 'apply '(primitive append) - (#{gen-map 2895}# #{e 3038}# #{map-env 3039}#)))) - (#{gen-map 2895}# - (lambda (#{e 3043}# #{map-env 3044}#) + (#{gen-map 2910}# #{e 3053}# #{map-env 3054}#)))) + (#{gen-map 2910}# + (lambda (#{e 3058}# #{map-env 3059}#) (begin - (let ((#{formals 3049}# (map cdr #{map-env 3044}#)) - (#{actuals 3050}# - (map (lambda (#{x 3051}#) - (list 'ref (car #{x 3051}#))) - #{map-env 3044}#))) - (if (eq? (car #{e 3043}#) 'ref) - (car #{actuals 3050}#) + (let ((#{formals 3064}# (map cdr #{map-env 3059}#)) + (#{actuals 3065}# + (map (lambda (#{x 3066}#) + (list 'ref (car #{x 3066}#))) + #{map-env 3059}#))) + (if (eq? (car #{e 3058}#) 'ref) + (car #{actuals 3065}#) (if (and-map - (lambda (#{x 3058}#) - (if (eq? (car #{x 3058}#) 'ref) - (memq (car (cdr #{x 3058}#)) #{formals 3049}#) + (lambda (#{x 3073}#) + (if (eq? (car #{x 3073}#) 'ref) + (memq (car (cdr #{x 3073}#)) #{formals 3064}#) #f)) - (cdr #{e 3043}#)) + (cdr #{e 3058}#)) (cons 'map - (cons (list 'primitive (car #{e 3043}#)) + (cons (list 'primitive (car #{e 3058}#)) (map (begin - (let ((#{r 3064}# + (let ((#{r 3079}# (map cons - #{formals 3049}# - #{actuals 3050}#))) - (lambda (#{x 3065}#) - (cdr (assq (car (cdr #{x 3065}#)) - #{r 3064}#))))) - (cdr #{e 3043}#)))) + #{formals 3064}# + #{actuals 3065}#))) + (lambda (#{x 3080}#) + (cdr (assq (car (cdr #{x 3080}#)) + #{r 3079}#))))) + (cdr #{e 3058}#)))) (cons 'map - (cons (list 'lambda #{formals 3049}# #{e 3043}#) - #{actuals 3050}#)))))))) - (#{gen-cons 2897}# - (lambda (#{x 3069}# #{y 3070}#) + (cons (list 'lambda #{formals 3064}# #{e 3058}#) + #{actuals 3065}#)))))))) + (#{gen-cons 2912}# + (lambda (#{x 3084}# #{y 3085}#) (begin - (let ((#{atom-key 3075}# (car #{y 3070}#))) - (if (eqv? #{atom-key 3075}# 'quote) - (if (eq? (car #{x 3069}#) 'quote) + (let ((#{atom-key 3090}# (car #{y 3085}#))) + (if (memv #{atom-key 3090}# '(quote)) + (if (eq? (car #{x 3084}#) 'quote) (list 'quote - (cons (car (cdr #{x 3069}#)) - (car (cdr #{y 3070}#)))) - (if (eq? (car (cdr #{y 3070}#)) '()) - (list 'list #{x 3069}#) - (list 'cons #{x 3069}# #{y 3070}#))) - (if (eqv? #{atom-key 3075}# 'list) - (cons 'list (cons #{x 3069}# (cdr #{y 3070}#))) - (list 'cons #{x 3069}# #{y 3070}#))))))) - (#{gen-append 2899}# - (lambda (#{x 3084}# #{y 3085}#) - (if (equal? #{y 3085}# ''()) - #{x 3084}# - (list 'append #{x 3084}# #{y 3085}#)))) - (#{gen-vector 2901}# - (lambda (#{x 3089}#) - (if (eq? (car #{x 3089}#) 'list) - (cons 'vector (cdr #{x 3089}#)) - (if (eq? (car #{x 3089}#) 'quote) + (cons (car (cdr #{x 3084}#)) + (car (cdr #{y 3085}#)))) + (if (eq? (car (cdr #{y 3085}#)) '()) + (list 'list #{x 3084}#) + (list 'cons #{x 3084}# #{y 3085}#))) + (if (memv #{atom-key 3090}# '(list)) + (cons 'list (cons #{x 3084}# (cdr #{y 3085}#))) + (list 'cons #{x 3084}# #{y 3085}#))))))) + (#{gen-append 2914}# + (lambda (#{x 3099}# #{y 3100}#) + (if (equal? #{y 3100}# ''()) + #{x 3099}# + (list 'append #{x 3099}# #{y 3100}#)))) + (#{gen-vector 2916}# + (lambda (#{x 3104}#) + (if (eq? (car #{x 3104}#) 'list) + (cons 'vector (cdr #{x 3104}#)) + (if (eq? (car #{x 3104}#) 'quote) (list 'quote - (list->vector (car (cdr #{x 3089}#)))) - (list 'list->vector #{x 3089}#))))) - (#{regen 2903}# - (lambda (#{x 3099}#) + (list->vector (car (cdr #{x 3104}#)))) + (list 'list->vector #{x 3104}#))))) + (#{regen 2918}# + (lambda (#{x 3114}#) (begin - (let ((#{atom-key 3103}# (car #{x 3099}#))) - (if (eqv? #{atom-key 3103}# 'ref) - (#{build-lexical-reference 271}# + (let ((#{atom-key 3118}# (car #{x 3114}#))) + (if (memv #{atom-key 3118}# '(ref)) + (#{build-lexical-reference 273}# 'value #f - (car (cdr #{x 3099}#)) - (car (cdr #{x 3099}#))) - (if (eqv? #{atom-key 3103}# 'primitive) - (#{build-primref 289}# #f (car (cdr #{x 3099}#))) - (if (eqv? #{atom-key 3103}# 'quote) - (#{build-data 291}# #f (car (cdr #{x 3099}#))) - (if (eqv? #{atom-key 3103}# 'lambda) - (if (list? (car (cdr #{x 3099}#))) - (#{build-simple-lambda 283}# + (car (cdr #{x 3114}#)) + (car (cdr #{x 3114}#))) + (if (memv #{atom-key 3118}# '(primitive)) + (#{build-primref 293}# #f (car (cdr #{x 3114}#))) + (if (memv #{atom-key 3118}# '(quote)) + (#{build-data 295}# #f (car (cdr #{x 3114}#))) + (if (memv #{atom-key 3118}# '(lambda)) + (if (list? (car (cdr #{x 3114}#))) + (#{build-simple-lambda 285}# #f - (car (cdr #{x 3099}#)) + (car (cdr #{x 3114}#)) #f - (car (cdr #{x 3099}#)) + (car (cdr #{x 3114}#)) '() - (#{regen 2903}# (car (cdr (cdr #{x 3099}#))))) - (error "how did we get here" #{x 3099}#)) - (#{build-application 265}# + (#{regen 2918}# (car (cdr (cdr #{x 3114}#))))) + (error "how did we get here" #{x 3114}#)) + (#{build-primcall 291}# #f - (#{build-primref 289}# #f (car #{x 3099}#)) - (map #{regen 2903}# (cdr #{x 3099}#)))))))))))) + (car #{x 3114}#) + (map #{regen 2918}# (cdr #{x 3114}#)))))))))))) (begin - (lambda (#{e 3115}# - #{r 3116}# - #{w 3117}# - #{s 3118}# - #{mod 3119}#) + (lambda (#{e 3129}# + #{r 3130}# + #{w 3131}# + #{s 3132}# + #{mod 3133}#) (begin - (let ((#{e 3126}# - (#{source-wrap 407}# - #{e 3115}# - #{w 3117}# - #{s 3118}# - #{mod 3119}#))) - (let ((#{tmp 3127}# #{e 3126}#)) - (let ((#{tmp 3128}# - ($sc-dispatch #{tmp 3127}# '(_ any)))) - (if #{tmp 3128}# + (let ((#{e 3140}# + (#{source-wrap 411}# + #{e 3129}# + #{w 3131}# + #{s 3132}# + #{mod 3133}#))) + (let ((#{tmp 3141}# #{e 3140}#)) + (let ((#{tmp 3142}# + ($sc-dispatch #{tmp 3141}# '(_ any)))) + (if #{tmp 3142}# (@apply - (lambda (#{x 3130}#) + (lambda (#{x 3144}#) (call-with-values (lambda () - (#{gen-syntax 2889}# - #{e 3126}# - #{x 3130}# - #{r 3116}# + (#{gen-syntax 2904}# + #{e 3140}# + #{x 3144}# + #{r 3130}# '() - #{ellipsis? 435}# - #{mod 3119}#)) - (lambda (#{e 3131}# #{maps 3132}#) - (#{regen 2903}# #{e 3131}#)))) - #{tmp 3128}#) - (let ((#{_ 3136}# #{tmp 3127}#)) + #{ellipsis? 439}# + #{mod 3133}#)) + (lambda (#{e 3145}# #{maps 3146}#) + (#{regen 2918}# #{e 3145}#)))) + #{tmp 3142}#) + (let ((#{_ 3150}# #{tmp 3141}#)) (syntax-violation 'syntax "bad `syntax' form" - #{e 3126}#))))))))))) - (#{global-extend 335}# + #{e 3140}#))))))))))) + (#{global-extend 339}# 'core 'lambda - (lambda (#{e 3137}# - #{r 3138}# - #{w 3139}# - #{s 3140}# - #{mod 3141}#) - (let ((#{tmp 3147}# #{e 3137}#)) - (let ((#{tmp 3148}# + (lambda (#{e 3151}# + #{r 3152}# + #{w 3153}# + #{s 3154}# + #{mod 3155}#) + (let ((#{tmp 3161}# #{e 3151}#)) + (let ((#{tmp 3162}# ($sc-dispatch - #{tmp 3147}# + #{tmp 3161}# '(_ any any . each-any)))) - (if #{tmp 3148}# + (if #{tmp 3162}# (@apply - (lambda (#{args 3152}# #{e1 3153}# #{e2 3154}#) + (lambda (#{args 3166}# #{e1 3167}# #{e2 3168}#) (call-with-values (lambda () - (#{lambda-formals 437}# #{args 3152}#)) - (lambda (#{req 3155}# - #{opt 3156}# - #{rest 3157}# - #{kw 3158}#) + (#{lambda-formals 441}# #{args 3166}#)) + (lambda (#{req 3169}# + #{opt 3170}# + #{rest 3171}# + #{kw 3172}#) (letrec* - ((#{lp 3166}# - (lambda (#{body 3167}# #{meta 3168}#) - (let ((#{tmp 3170}# #{body 3167}#)) - (let ((#{tmp 3171}# + ((#{lp 3180}# + (lambda (#{body 3181}# #{meta 3182}#) + (let ((#{tmp 3184}# #{body 3181}#)) + (let ((#{tmp 3185}# ($sc-dispatch - #{tmp 3170}# + #{tmp 3184}# '(any any . each-any)))) - (if (if #{tmp 3171}# + (if (if #{tmp 3185}# (@apply - (lambda (#{docstring 3175}# - #{e1 3176}# - #{e2 3177}#) + (lambda (#{docstring 3189}# + #{e1 3190}# + #{e2 3191}#) (string? (syntax->datum - #{docstring 3175}#))) - #{tmp 3171}#) + #{docstring 3189}#))) + #{tmp 3185}#) #f) (@apply - (lambda (#{docstring 3181}# - #{e1 3182}# - #{e2 3183}#) - (#{lp 3166}# - (cons #{e1 3182}# #{e2 3183}#) + (lambda (#{docstring 3195}# + #{e1 3196}# + #{e2 3197}#) + (#{lp 3180}# + (cons #{e1 3196}# #{e2 3197}#) (append - #{meta 3168}# + #{meta 3182}# (list (cons 'documentation (syntax->datum - #{docstring 3181}#)))))) - #{tmp 3171}#) - (let ((#{tmp 3186}# + #{docstring 3195}#)))))) + #{tmp 3185}#) + (let ((#{tmp 3200}# ($sc-dispatch - #{tmp 3170}# + #{tmp 3184}# '(#(vector #(each (any . any))) any . each-any)))) - (if #{tmp 3186}# + (if #{tmp 3200}# (@apply - (lambda (#{k 3191}# - #{v 3192}# - #{e1 3193}# - #{e2 3194}#) - (#{lp 3166}# - (cons #{e1 3193}# #{e2 3194}#) + (lambda (#{k 3205}# + #{v 3206}# + #{e1 3207}# + #{e2 3208}#) + (#{lp 3180}# + (cons #{e1 3207}# #{e2 3208}#) (append - #{meta 3168}# + #{meta 3182}# (syntax->datum (map cons - #{k 3191}# - #{v 3192}#))))) - #{tmp 3186}#) - (let ((#{_ 3199}# #{tmp 3170}#)) - (#{chi-simple-lambda 439}# - #{e 3137}# - #{r 3138}# - #{w 3139}# - #{s 3140}# - #{mod 3141}# - #{req 3155}# - #{rest 3157}# - #{meta 3168}# - #{body 3167}#)))))))))) + #{k 3205}# + #{v 3206}#))))) + #{tmp 3200}#) + (let ((#{_ 3213}# #{tmp 3184}#)) + (#{chi-simple-lambda 443}# + #{e 3151}# + #{r 3152}# + #{w 3153}# + #{s 3154}# + #{mod 3155}# + #{req 3169}# + #{rest 3171}# + #{meta 3182}# + #{body 3181}#)))))))))) (begin - (#{lp 3166}# - (cons #{e1 3153}# #{e2 3154}#) + (#{lp 3180}# + (cons #{e1 3167}# #{e2 3168}#) '())))))) - #{tmp 3148}#) - (let ((#{_ 3201}# #{tmp 3147}#)) + #{tmp 3162}#) + (let ((#{_ 3215}# #{tmp 3161}#)) (syntax-violation 'lambda "bad lambda" - #{e 3137}#))))))) - (#{global-extend 335}# + #{e 3151}#))))))) + (#{global-extend 339}# 'core 'lambda* - (lambda (#{e 3202}# - #{r 3203}# - #{w 3204}# - #{s 3205}# - #{mod 3206}#) - (let ((#{tmp 3212}# #{e 3202}#)) - (let ((#{tmp 3213}# + (lambda (#{e 3216}# + #{r 3217}# + #{w 3218}# + #{s 3219}# + #{mod 3220}#) + (let ((#{tmp 3226}# #{e 3216}#)) + (let ((#{tmp 3227}# ($sc-dispatch - #{tmp 3212}# + #{tmp 3226}# '(_ any any . each-any)))) - (if #{tmp 3213}# + (if #{tmp 3227}# (@apply - (lambda (#{args 3217}# #{e1 3218}# #{e2 3219}#) + (lambda (#{args 3231}# #{e1 3232}# #{e2 3233}#) (call-with-values (lambda () - (#{chi-lambda-case 443}# - #{e 3202}# - #{r 3203}# - #{w 3204}# - #{s 3205}# - #{mod 3206}# - #{lambda*-formals 441}# - (list (cons #{args 3217}# - (cons #{e1 3218}# #{e2 3219}#))))) - (lambda (#{meta 3221}# #{lcase 3222}#) - (#{build-case-lambda 285}# - #{s 3205}# - #{meta 3221}# - #{lcase 3222}#)))) - #{tmp 3213}#) - (let ((#{_ 3226}# #{tmp 3212}#)) + (#{chi-lambda-case 447}# + #{e 3216}# + #{r 3217}# + #{w 3218}# + #{s 3219}# + #{mod 3220}# + #{lambda*-formals 445}# + (list (cons #{args 3231}# + (cons #{e1 3232}# #{e2 3233}#))))) + (lambda (#{meta 3235}# #{lcase 3236}#) + (#{build-case-lambda 287}# + #{s 3219}# + #{meta 3235}# + #{lcase 3236}#)))) + #{tmp 3227}#) + (let ((#{_ 3240}# #{tmp 3226}#)) (syntax-violation 'lambda "bad lambda*" - #{e 3202}#))))))) - (#{global-extend 335}# + #{e 3216}#))))))) + (#{global-extend 339}# 'core 'case-lambda - (lambda (#{e 3227}# - #{r 3228}# - #{w 3229}# - #{s 3230}# - #{mod 3231}#) - (let ((#{tmp 3237}# #{e 3227}#)) - (let ((#{tmp 3238}# + (lambda (#{e 3241}# + #{r 3242}# + #{w 3243}# + #{s 3244}# + #{mod 3245}#) + (let ((#{tmp 3251}# #{e 3241}#)) + (let ((#{tmp 3252}# ($sc-dispatch - #{tmp 3237}# + #{tmp 3251}# '(_ (any any . each-any) . #(each (any any . each-any)))))) - (if #{tmp 3238}# + (if #{tmp 3252}# (@apply - (lambda (#{args 3245}# - #{e1 3246}# - #{e2 3247}# - #{args* 3248}# - #{e1* 3249}# - #{e2* 3250}#) + (lambda (#{args 3259}# + #{e1 3260}# + #{e2 3261}# + #{args* 3262}# + #{e1* 3263}# + #{e2* 3264}#) (call-with-values (lambda () - (#{chi-lambda-case 443}# - #{e 3227}# - #{r 3228}# - #{w 3229}# - #{s 3230}# - #{mod 3231}# - #{lambda-formals 437}# - (cons (cons #{args 3245}# - (cons #{e1 3246}# #{e2 3247}#)) - (map (lambda (#{tmp 3254}# - #{tmp 3253}# - #{tmp 3252}#) - (cons #{tmp 3252}# - (cons #{tmp 3253}# #{tmp 3254}#))) - #{e2* 3250}# - #{e1* 3249}# - #{args* 3248}#)))) - (lambda (#{meta 3256}# #{lcase 3257}#) - (#{build-case-lambda 285}# - #{s 3230}# - #{meta 3256}# - #{lcase 3257}#)))) - #{tmp 3238}#) - (let ((#{_ 3261}# #{tmp 3237}#)) + (#{chi-lambda-case 447}# + #{e 3241}# + #{r 3242}# + #{w 3243}# + #{s 3244}# + #{mod 3245}# + #{lambda-formals 441}# + (cons (cons #{args 3259}# + (cons #{e1 3260}# #{e2 3261}#)) + (map (lambda (#{tmp 3268}# + #{tmp 3267}# + #{tmp 3266}#) + (cons #{tmp 3266}# + (cons #{tmp 3267}# #{tmp 3268}#))) + #{e2* 3264}# + #{e1* 3263}# + #{args* 3262}#)))) + (lambda (#{meta 3270}# #{lcase 3271}#) + (#{build-case-lambda 287}# + #{s 3244}# + #{meta 3270}# + #{lcase 3271}#)))) + #{tmp 3252}#) + (let ((#{_ 3275}# #{tmp 3251}#)) (syntax-violation 'case-lambda "bad case-lambda" - #{e 3227}#))))))) - (#{global-extend 335}# + #{e 3241}#))))))) + (#{global-extend 339}# 'core 'case-lambda* - (lambda (#{e 3262}# - #{r 3263}# - #{w 3264}# - #{s 3265}# - #{mod 3266}#) - (let ((#{tmp 3272}# #{e 3262}#)) - (let ((#{tmp 3273}# + (lambda (#{e 3276}# + #{r 3277}# + #{w 3278}# + #{s 3279}# + #{mod 3280}#) + (let ((#{tmp 3286}# #{e 3276}#)) + (let ((#{tmp 3287}# ($sc-dispatch - #{tmp 3272}# + #{tmp 3286}# '(_ (any any . each-any) . #(each (any any . each-any)))))) - (if #{tmp 3273}# + (if #{tmp 3287}# (@apply - (lambda (#{args 3280}# - #{e1 3281}# - #{e2 3282}# - #{args* 3283}# - #{e1* 3284}# - #{e2* 3285}#) + (lambda (#{args 3294}# + #{e1 3295}# + #{e2 3296}# + #{args* 3297}# + #{e1* 3298}# + #{e2* 3299}#) (call-with-values (lambda () - (#{chi-lambda-case 443}# - #{e 3262}# - #{r 3263}# - #{w 3264}# - #{s 3265}# - #{mod 3266}# - #{lambda*-formals 441}# - (cons (cons #{args 3280}# - (cons #{e1 3281}# #{e2 3282}#)) - (map (lambda (#{tmp 3289}# - #{tmp 3288}# - #{tmp 3287}#) - (cons #{tmp 3287}# - (cons #{tmp 3288}# #{tmp 3289}#))) - #{e2* 3285}# - #{e1* 3284}# - #{args* 3283}#)))) - (lambda (#{meta 3291}# #{lcase 3292}#) - (#{build-case-lambda 285}# - #{s 3265}# - #{meta 3291}# - #{lcase 3292}#)))) - #{tmp 3273}#) - (let ((#{_ 3296}# #{tmp 3272}#)) + (#{chi-lambda-case 447}# + #{e 3276}# + #{r 3277}# + #{w 3278}# + #{s 3279}# + #{mod 3280}# + #{lambda*-formals 445}# + (cons (cons #{args 3294}# + (cons #{e1 3295}# #{e2 3296}#)) + (map (lambda (#{tmp 3303}# + #{tmp 3302}# + #{tmp 3301}#) + (cons #{tmp 3301}# + (cons #{tmp 3302}# #{tmp 3303}#))) + #{e2* 3299}# + #{e1* 3298}# + #{args* 3297}#)))) + (lambda (#{meta 3305}# #{lcase 3306}#) + (#{build-case-lambda 287}# + #{s 3279}# + #{meta 3305}# + #{lcase 3306}#)))) + #{tmp 3287}#) + (let ((#{_ 3310}# #{tmp 3286}#)) (syntax-violation 'case-lambda "bad case-lambda*" - #{e 3262}#))))))) - (#{global-extend 335}# + #{e 3276}#))))))) + (#{global-extend 339}# 'core 'let (letrec* - ((#{chi-let 3298}# - (lambda (#{e 3299}# - #{r 3300}# - #{w 3301}# - #{s 3302}# - #{mod 3303}# - #{constructor 3304}# - #{ids 3305}# - #{vals 3306}# - #{exps 3307}#) - (if (not (#{valid-bound-ids? 399}# #{ids 3305}#)) + ((#{chi-let 3312}# + (lambda (#{e 3313}# + #{r 3314}# + #{w 3315}# + #{s 3316}# + #{mod 3317}# + #{constructor 3318}# + #{ids 3319}# + #{vals 3320}# + #{exps 3321}#) + (if (not (#{valid-bound-ids? 403}# #{ids 3319}#)) (syntax-violation 'let "duplicate bound variable" - #{e 3299}#) + #{e 3313}#) (begin - (let ((#{labels 3319}# - (#{gen-labels 354}# #{ids 3305}#)) - (#{new-vars 3320}# - (map #{gen-var 447}# #{ids 3305}#))) + (let ((#{labels 3333}# + (#{gen-labels 358}# #{ids 3319}#)) + (#{new-vars 3334}# + (map #{gen-var 451}# #{ids 3319}#))) (begin - (let ((#{nw 3323}# - (#{make-binding-wrap 383}# - #{ids 3305}# - #{labels 3319}# - #{w 3301}#)) - (#{nr 3324}# - (#{extend-var-env 329}# - #{labels 3319}# - #{new-vars 3320}# - #{r 3300}#))) - (#{constructor 3304}# - #{s 3302}# - (map syntax->datum #{ids 3305}#) - #{new-vars 3320}# - (map (lambda (#{x 3325}#) - (#{chi 419}# - #{x 3325}# - #{r 3300}# - #{w 3301}# - #{mod 3303}#)) - #{vals 3306}#) - (#{chi-body 427}# - #{exps 3307}# - (#{source-wrap 407}# - #{e 3299}# - #{nw 3323}# - #{s 3302}# - #{mod 3303}#) - #{nr 3324}# - #{nw 3323}# - #{mod 3303}#)))))))))) + (let ((#{nw 3337}# + (#{make-binding-wrap 387}# + #{ids 3319}# + #{labels 3333}# + #{w 3315}#)) + (#{nr 3338}# + (#{extend-var-env 333}# + #{labels 3333}# + #{new-vars 3334}# + #{r 3314}#))) + (#{constructor 3318}# + #{s 3316}# + (map syntax->datum #{ids 3319}#) + #{new-vars 3334}# + (map (lambda (#{x 3339}#) + (#{chi 423}# + #{x 3339}# + #{r 3314}# + #{w 3315}# + #{mod 3317}#)) + #{vals 3320}#) + (#{chi-body 431}# + #{exps 3321}# + (#{source-wrap 411}# + #{e 3313}# + #{nw 3337}# + #{s 3316}# + #{mod 3317}#) + #{nr 3338}# + #{nw 3337}# + #{mod 3317}#)))))))))) (begin - (lambda (#{e 3327}# - #{r 3328}# - #{w 3329}# - #{s 3330}# - #{mod 3331}#) - (let ((#{tmp 3337}# #{e 3327}#)) - (let ((#{tmp 3338}# + (lambda (#{e 3341}# + #{r 3342}# + #{w 3343}# + #{s 3344}# + #{mod 3345}#) + (let ((#{tmp 3351}# #{e 3341}#)) + (let ((#{tmp 3352}# ($sc-dispatch - #{tmp 3337}# + #{tmp 3351}# '(_ #(each (any any)) any . each-any)))) - (if (if #{tmp 3338}# + (if (if #{tmp 3352}# (@apply - (lambda (#{id 3343}# - #{val 3344}# - #{e1 3345}# - #{e2 3346}#) - (and-map #{id? 339}# #{id 3343}#)) - #{tmp 3338}#) + (lambda (#{id 3357}# + #{val 3358}# + #{e1 3359}# + #{e2 3360}#) + (and-map #{id? 343}# #{id 3357}#)) + #{tmp 3352}#) #f) (@apply - (lambda (#{id 3352}# - #{val 3353}# - #{e1 3354}# - #{e2 3355}#) - (#{chi-let 3298}# - #{e 3327}# - #{r 3328}# - #{w 3329}# - #{s 3330}# - #{mod 3331}# - #{build-let 295}# - #{id 3352}# - #{val 3353}# - (cons #{e1 3354}# #{e2 3355}#))) - #{tmp 3338}#) - (let ((#{tmp 3359}# + (lambda (#{id 3366}# + #{val 3367}# + #{e1 3368}# + #{e2 3369}#) + (#{chi-let 3312}# + #{e 3341}# + #{r 3342}# + #{w 3343}# + #{s 3344}# + #{mod 3345}# + #{build-let 299}# + #{id 3366}# + #{val 3367}# + (cons #{e1 3368}# #{e2 3369}#))) + #{tmp 3352}#) + (let ((#{tmp 3373}# ($sc-dispatch - #{tmp 3337}# + #{tmp 3351}# '(_ any #(each (any any)) any . each-any)))) - (if (if #{tmp 3359}# + (if (if #{tmp 3373}# (@apply - (lambda (#{f 3365}# - #{id 3366}# - #{val 3367}# - #{e1 3368}# - #{e2 3369}#) - (if (#{id? 339}# #{f 3365}#) - (and-map #{id? 339}# #{id 3366}#) + (lambda (#{f 3379}# + #{id 3380}# + #{val 3381}# + #{e1 3382}# + #{e2 3383}#) + (if (#{id? 343}# #{f 3379}#) + (and-map #{id? 343}# #{id 3380}#) #f)) - #{tmp 3359}#) + #{tmp 3373}#) #f) (@apply - (lambda (#{f 3378}# - #{id 3379}# - #{val 3380}# - #{e1 3381}# - #{e2 3382}#) - (#{chi-let 3298}# - #{e 3327}# - #{r 3328}# - #{w 3329}# - #{s 3330}# - #{mod 3331}# - #{build-named-let 297}# - (cons #{f 3378}# #{id 3379}#) - #{val 3380}# - (cons #{e1 3381}# #{e2 3382}#))) - #{tmp 3359}#) - (let ((#{_ 3387}# #{tmp 3337}#)) + (lambda (#{f 3392}# + #{id 3393}# + #{val 3394}# + #{e1 3395}# + #{e2 3396}#) + (#{chi-let 3312}# + #{e 3341}# + #{r 3342}# + #{w 3343}# + #{s 3344}# + #{mod 3345}# + #{build-named-let 301}# + (cons #{f 3392}# #{id 3393}#) + #{val 3394}# + (cons #{e1 3395}# #{e2 3396}#))) + #{tmp 3373}#) + (let ((#{_ 3401}# #{tmp 3351}#)) (syntax-violation 'let "bad let" - (#{source-wrap 407}# - #{e 3327}# - #{w 3329}# - #{s 3330}# - #{mod 3331}#)))))))))))) - (#{global-extend 335}# + (#{source-wrap 411}# + #{e 3341}# + #{w 3343}# + #{s 3344}# + #{mod 3345}#)))))))))))) + (#{global-extend 339}# 'core 'letrec - (lambda (#{e 3388}# - #{r 3389}# - #{w 3390}# - #{s 3391}# - #{mod 3392}#) - (let ((#{tmp 3398}# #{e 3388}#)) - (let ((#{tmp 3399}# + (lambda (#{e 3402}# + #{r 3403}# + #{w 3404}# + #{s 3405}# + #{mod 3406}#) + (let ((#{tmp 3412}# #{e 3402}#)) + (let ((#{tmp 3413}# ($sc-dispatch - #{tmp 3398}# + #{tmp 3412}# '(_ #(each (any any)) any . each-any)))) - (if (if #{tmp 3399}# + (if (if #{tmp 3413}# (@apply - (lambda (#{id 3404}# - #{val 3405}# - #{e1 3406}# - #{e2 3407}#) - (and-map #{id? 339}# #{id 3404}#)) - #{tmp 3399}#) + (lambda (#{id 3418}# + #{val 3419}# + #{e1 3420}# + #{e2 3421}#) + (and-map #{id? 343}# #{id 3418}#)) + #{tmp 3413}#) #f) (@apply - (lambda (#{id 3413}# - #{val 3414}# - #{e1 3415}# - #{e2 3416}#) + (lambda (#{id 3427}# + #{val 3428}# + #{e1 3429}# + #{e2 3430}#) (begin - (let ((#{ids 3418}# #{id 3413}#)) - (if (not (#{valid-bound-ids? 399}# #{ids 3418}#)) + (let ((#{ids 3432}# #{id 3427}#)) + (if (not (#{valid-bound-ids? 403}# #{ids 3432}#)) (syntax-violation 'letrec "duplicate bound variable" - #{e 3388}#) + #{e 3402}#) (begin - (let ((#{labels 3422}# - (#{gen-labels 354}# #{ids 3418}#)) - (#{new-vars 3423}# - (map #{gen-var 447}# #{ids 3418}#))) + (let ((#{labels 3436}# + (#{gen-labels 358}# #{ids 3432}#)) + (#{new-vars 3437}# + (map #{gen-var 451}# #{ids 3432}#))) (begin - (let ((#{w 3426}# - (#{make-binding-wrap 383}# - #{ids 3418}# - #{labels 3422}# - #{w 3390}#)) - (#{r 3427}# - (#{extend-var-env 329}# - #{labels 3422}# - #{new-vars 3423}# - #{r 3389}#))) - (#{build-letrec 299}# - #{s 3391}# + (let ((#{w 3440}# + (#{make-binding-wrap 387}# + #{ids 3432}# + #{labels 3436}# + #{w 3404}#)) + (#{r 3441}# + (#{extend-var-env 333}# + #{labels 3436}# + #{new-vars 3437}# + #{r 3403}#))) + (#{build-letrec 303}# + #{s 3405}# #f - (map syntax->datum #{ids 3418}#) - #{new-vars 3423}# - (map (lambda (#{x 3428}#) - (#{chi 419}# - #{x 3428}# - #{r 3427}# - #{w 3426}# - #{mod 3392}#)) - #{val 3414}#) - (#{chi-body 427}# - (cons #{e1 3415}# #{e2 3416}#) - (#{source-wrap 407}# - #{e 3388}# - #{w 3426}# - #{s 3391}# - #{mod 3392}#) - #{r 3427}# - #{w 3426}# - #{mod 3392}#)))))))))) - #{tmp 3399}#) - (let ((#{_ 3433}# #{tmp 3398}#)) + (map syntax->datum #{ids 3432}#) + #{new-vars 3437}# + (map (lambda (#{x 3442}#) + (#{chi 423}# + #{x 3442}# + #{r 3441}# + #{w 3440}# + #{mod 3406}#)) + #{val 3428}#) + (#{chi-body 431}# + (cons #{e1 3429}# #{e2 3430}#) + (#{source-wrap 411}# + #{e 3402}# + #{w 3440}# + #{s 3405}# + #{mod 3406}#) + #{r 3441}# + #{w 3440}# + #{mod 3406}#)))))))))) + #{tmp 3413}#) + (let ((#{_ 3447}# #{tmp 3412}#)) (syntax-violation 'letrec "bad letrec" - (#{source-wrap 407}# - #{e 3388}# - #{w 3390}# - #{s 3391}# - #{mod 3392}#)))))))) - (#{global-extend 335}# + (#{source-wrap 411}# + #{e 3402}# + #{w 3404}# + #{s 3405}# + #{mod 3406}#)))))))) + (#{global-extend 339}# 'core 'letrec* - (lambda (#{e 3434}# - #{r 3435}# - #{w 3436}# - #{s 3437}# - #{mod 3438}#) - (let ((#{tmp 3444}# #{e 3434}#)) - (let ((#{tmp 3445}# + (lambda (#{e 3448}# + #{r 3449}# + #{w 3450}# + #{s 3451}# + #{mod 3452}#) + (let ((#{tmp 3458}# #{e 3448}#)) + (let ((#{tmp 3459}# ($sc-dispatch - #{tmp 3444}# + #{tmp 3458}# '(_ #(each (any any)) any . each-any)))) - (if (if #{tmp 3445}# + (if (if #{tmp 3459}# (@apply - (lambda (#{id 3450}# - #{val 3451}# - #{e1 3452}# - #{e2 3453}#) - (and-map #{id? 339}# #{id 3450}#)) - #{tmp 3445}#) + (lambda (#{id 3464}# + #{val 3465}# + #{e1 3466}# + #{e2 3467}#) + (and-map #{id? 343}# #{id 3464}#)) + #{tmp 3459}#) #f) (@apply - (lambda (#{id 3459}# - #{val 3460}# - #{e1 3461}# - #{e2 3462}#) + (lambda (#{id 3473}# + #{val 3474}# + #{e1 3475}# + #{e2 3476}#) (begin - (let ((#{ids 3464}# #{id 3459}#)) - (if (not (#{valid-bound-ids? 399}# #{ids 3464}#)) + (let ((#{ids 3478}# #{id 3473}#)) + (if (not (#{valid-bound-ids? 403}# #{ids 3478}#)) (syntax-violation 'letrec* "duplicate bound variable" - #{e 3434}#) + #{e 3448}#) (begin - (let ((#{labels 3468}# - (#{gen-labels 354}# #{ids 3464}#)) - (#{new-vars 3469}# - (map #{gen-var 447}# #{ids 3464}#))) + (let ((#{labels 3482}# + (#{gen-labels 358}# #{ids 3478}#)) + (#{new-vars 3483}# + (map #{gen-var 451}# #{ids 3478}#))) (begin - (let ((#{w 3472}# - (#{make-binding-wrap 383}# - #{ids 3464}# - #{labels 3468}# - #{w 3436}#)) - (#{r 3473}# - (#{extend-var-env 329}# - #{labels 3468}# - #{new-vars 3469}# - #{r 3435}#))) - (#{build-letrec 299}# - #{s 3437}# + (let ((#{w 3486}# + (#{make-binding-wrap 387}# + #{ids 3478}# + #{labels 3482}# + #{w 3450}#)) + (#{r 3487}# + (#{extend-var-env 333}# + #{labels 3482}# + #{new-vars 3483}# + #{r 3449}#))) + (#{build-letrec 303}# + #{s 3451}# #t - (map syntax->datum #{ids 3464}#) - #{new-vars 3469}# - (map (lambda (#{x 3474}#) - (#{chi 419}# - #{x 3474}# - #{r 3473}# - #{w 3472}# - #{mod 3438}#)) - #{val 3460}#) - (#{chi-body 427}# - (cons #{e1 3461}# #{e2 3462}#) - (#{source-wrap 407}# - #{e 3434}# - #{w 3472}# - #{s 3437}# - #{mod 3438}#) - #{r 3473}# - #{w 3472}# - #{mod 3438}#)))))))))) - #{tmp 3445}#) - (let ((#{_ 3479}# #{tmp 3444}#)) + (map syntax->datum #{ids 3478}#) + #{new-vars 3483}# + (map (lambda (#{x 3488}#) + (#{chi 423}# + #{x 3488}# + #{r 3487}# + #{w 3486}# + #{mod 3452}#)) + #{val 3474}#) + (#{chi-body 431}# + (cons #{e1 3475}# #{e2 3476}#) + (#{source-wrap 411}# + #{e 3448}# + #{w 3486}# + #{s 3451}# + #{mod 3452}#) + #{r 3487}# + #{w 3486}# + #{mod 3452}#)))))))))) + #{tmp 3459}#) + (let ((#{_ 3493}# #{tmp 3458}#)) (syntax-violation 'letrec* "bad letrec*" - (#{source-wrap 407}# - #{e 3434}# - #{w 3436}# - #{s 3437}# - #{mod 3438}#)))))))) - (#{global-extend 335}# + (#{source-wrap 411}# + #{e 3448}# + #{w 3450}# + #{s 3451}# + #{mod 3452}#)))))))) + (#{global-extend 339}# 'core 'set! - (lambda (#{e 3480}# - #{r 3481}# - #{w 3482}# - #{s 3483}# - #{mod 3484}#) - (let ((#{tmp 3490}# #{e 3480}#)) - (let ((#{tmp 3491}# - ($sc-dispatch #{tmp 3490}# '(_ any any)))) - (if (if #{tmp 3491}# + (lambda (#{e 3494}# + #{r 3495}# + #{w 3496}# + #{s 3497}# + #{mod 3498}#) + (let ((#{tmp 3504}# #{e 3494}#)) + (let ((#{tmp 3505}# + ($sc-dispatch #{tmp 3504}# '(_ any any)))) + (if (if #{tmp 3505}# (@apply - (lambda (#{id 3494}# #{val 3495}#) - (#{id? 339}# #{id 3494}#)) - #{tmp 3491}#) + (lambda (#{id 3508}# #{val 3509}#) + (#{id? 343}# #{id 3508}#)) + #{tmp 3505}#) #f) (@apply - (lambda (#{id 3498}# #{val 3499}#) + (lambda (#{id 3512}# #{val 3513}#) (begin - (let ((#{n 3502}# - (#{id-var-name 393}# #{id 3498}# #{w 3482}#)) - (#{id-mod 3503}# - (if (#{syntax-object? 305}# #{id 3498}#) - (#{syntax-object-module 311}# #{id 3498}#) - #{mod 3484}#))) + (let ((#{n 3516}# + (#{id-var-name 397}# #{id 3512}# #{w 3496}#)) + (#{id-mod 3517}# + (if (#{syntax-object? 309}# #{id 3512}#) + (#{syntax-object-module 315}# #{id 3512}#) + #{mod 3498}#))) (begin - (let ((#{b 3505}# - (#{lookup 333}# - #{n 3502}# - #{r 3481}# - #{id-mod 3503}#))) + (let ((#{b 3519}# + (#{lookup 337}# + #{n 3516}# + #{r 3495}# + #{id-mod 3517}#))) (begin - (let ((#{atom-key 3508}# (car #{b 3505}#))) - (if (eqv? #{atom-key 3508}# 'lexical) - (#{build-lexical-assignment 273}# - #{s 3483}# - (syntax->datum #{id 3498}#) - (cdr #{b 3505}#) - (#{chi 419}# - #{val 3499}# - #{r 3481}# - #{w 3482}# - #{mod 3484}#)) - (if (eqv? #{atom-key 3508}# 'global) - (#{build-global-assignment 279}# - #{s 3483}# - #{n 3502}# - (#{chi 419}# - #{val 3499}# - #{r 3481}# - #{w 3482}# - #{mod 3484}#) - #{id-mod 3503}#) - (if (eqv? #{atom-key 3508}# 'macro) + (let ((#{atom-key 3522}# (car #{b 3519}#))) + (if (memv #{atom-key 3522}# '(lexical)) + (#{build-lexical-assignment 275}# + #{s 3497}# + (syntax->datum #{id 3512}#) + (cdr #{b 3519}#) + (#{chi 423}# + #{val 3513}# + #{r 3495}# + #{w 3496}# + #{mod 3498}#)) + (if (memv #{atom-key 3522}# '(global)) + (#{build-global-assignment 281}# + #{s 3497}# + #{n 3516}# + (#{chi 423}# + #{val 3513}# + #{r 3495}# + #{w 3496}# + #{mod 3498}#) + #{id-mod 3517}#) + (if (memv #{atom-key 3522}# '(macro)) (begin - (let ((#{p 3515}# (cdr #{b 3505}#))) + (let ((#{p 3529}# (cdr #{b 3519}#))) (if (procedure-property - #{p 3515}# + #{p 3529}# 'variable-transformer) - (#{chi 419}# - (#{chi-macro 425}# - #{p 3515}# - #{e 3480}# - #{r 3481}# - #{w 3482}# - #{s 3483}# + (#{chi 423}# + (#{chi-macro 429}# + #{p 3529}# + #{e 3494}# + #{r 3495}# + #{w 3496}# + #{s 3497}# #f - #{mod 3484}#) - #{r 3481}# + #{mod 3498}#) + #{r 3495}# '(()) - #{mod 3484}#) + #{mod 3498}#) (syntax-violation 'set! "not a variable transformer" - (#{wrap 405}# - #{e 3480}# - #{w 3482}# - #{mod 3484}#) - (#{wrap 405}# - #{id 3498}# - #{w 3482}# - #{id-mod 3503}#))))) - (if (eqv? #{atom-key 3508}# - 'displaced-lexical) + (#{wrap 409}# + #{e 3494}# + #{w 3496}# + #{mod 3498}#) + (#{wrap 409}# + #{id 3512}# + #{w 3496}# + #{id-mod 3517}#))))) + (if (memv #{atom-key 3522}# + '(displaced-lexical)) (syntax-violation 'set! "identifier out of context" - (#{wrap 405}# - #{id 3498}# - #{w 3482}# - #{mod 3484}#)) + (#{wrap 409}# + #{id 3512}# + #{w 3496}# + #{mod 3498}#)) (syntax-violation 'set! "bad set!" - (#{source-wrap 407}# - #{e 3480}# - #{w 3482}# - #{s 3483}# - #{mod 3484}#))))))))))))) - #{tmp 3491}#) - (let ((#{tmp 3520}# + (#{source-wrap 411}# + #{e 3494}# + #{w 3496}# + #{s 3497}# + #{mod 3498}#))))))))))))) + #{tmp 3505}#) + (let ((#{tmp 3534}# ($sc-dispatch - #{tmp 3490}# + #{tmp 3504}# '(_ (any . each-any) any)))) - (if #{tmp 3520}# + (if #{tmp 3534}# (@apply - (lambda (#{head 3524}# #{tail 3525}# #{val 3526}#) + (lambda (#{head 3538}# #{tail 3539}# #{val 3540}#) (call-with-values (lambda () - (#{syntax-type 417}# - #{head 3524}# - #{r 3481}# + (#{syntax-type 421}# + #{head 3538}# + #{r 3495}# '(()) #f #f - #{mod 3484}# + #{mod 3498}# #t)) - (lambda (#{type 3529}# - #{value 3530}# - #{ee 3531}# - #{ww 3532}# - #{ss 3533}# - #{modmod 3534}#) - (if (eqv? #{type 3529}# 'module-ref) + (lambda (#{type 3543}# + #{value 3544}# + #{ee 3545}# + #{ww 3546}# + #{ss 3547}# + #{modmod 3548}#) + (if (memv #{type 3543}# '(module-ref)) (begin - (let ((#{val 3543}# - (#{chi 419}# - #{val 3526}# - #{r 3481}# - #{w 3482}# - #{mod 3484}#))) + (let ((#{val 3557}# + (#{chi 423}# + #{val 3540}# + #{r 3495}# + #{w 3496}# + #{mod 3498}#))) (call-with-values (lambda () - (#{value 3530}# - (cons #{head 3524}# #{tail 3525}#) - #{r 3481}# - #{w 3482}#)) - (lambda (#{e 3545}# - #{r 3546}# - #{w 3547}# - #{s* 3548}# - #{mod 3549}#) - (let ((#{tmp 3555}# #{e 3545}#)) - (let ((#{tmp 3556}# - (list #{tmp 3555}#))) - (if (if #{tmp 3556}# + (#{value 3544}# + (cons #{head 3538}# #{tail 3539}#) + #{r 3495}# + #{w 3496}#)) + (lambda (#{e 3559}# + #{r 3560}# + #{w 3561}# + #{s* 3562}# + #{mod 3563}#) + (let ((#{tmp 3569}# #{e 3559}#)) + (let ((#{tmp 3570}# + (list #{tmp 3569}#))) + (if (if #{tmp 3570}# (@apply - (lambda (#{e 3558}#) - (#{id? 339}# #{e 3558}#)) - #{tmp 3556}#) + (lambda (#{e 3572}#) + (#{id? 343}# #{e 3572}#)) + #{tmp 3570}#) #f) (@apply - (lambda (#{e 3560}#) - (#{build-global-assignment 279}# - #{s 3483}# - (syntax->datum #{e 3560}#) - #{val 3543}# - #{mod 3549}#)) - #{tmp 3556}#) + (lambda (#{e 3574}#) + (#{build-global-assignment 281}# + #{s 3497}# + (syntax->datum #{e 3574}#) + #{val 3557}# + #{mod 3563}#)) + #{tmp 3570}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 3555}#)))))))) - (#{build-application 265}# - #{s 3483}# - (#{chi 419}# + #{tmp 3569}#)))))))) + (#{build-call 267}# + #{s 3497}# + (#{chi 423}# (list '#(syntax-object setter ((top) @@ -9924,25 +9987,25 @@ (top) (top) (top)) - #("i3535" - "i3536" - "i3537" - "i3538" - "i3539" - "i3540")) + #("i3549" + "i3550" + "i3551" + "i3552" + "i3553" + "i3554")) #(ribcage #(head tail val) #((top) (top) (top)) - #("i3521" "i3522" "i3523")) + #("i3535" "i3536" "i3537")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) - #("i3485" - "i3486" - "i3487" - "i3488" - "i3489")) + #("i3499" + "i3500" + "i3501" + "i3502" + "i3503")) #(ribcage (lambda-var-list gen-var @@ -9957,7 +10020,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -10035,6 +10098,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -10046,7 +10110,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -10068,7 +10132,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -10215,8 +10280,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -10249,14 +10318,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -10264,33 +10333,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -10323,17 +10392,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -10359,50 +10428,50 @@ ((top) (top) (top)) ("i40" "i39" "i38"))) (hygiene guile)) - #{head 3524}#) - #{r 3481}# - #{w 3482}# - #{mod 3484}#) - (map (lambda (#{e 3562}#) - (#{chi 419}# - #{e 3562}# - #{r 3481}# - #{w 3482}# - #{mod 3484}#)) + #{head 3538}#) + #{r 3495}# + #{w 3496}# + #{mod 3498}#) + (map (lambda (#{e 3576}#) + (#{chi 423}# + #{e 3576}# + #{r 3495}# + #{w 3496}# + #{mod 3498}#)) (append - #{tail 3525}# - (list #{val 3526}#)))))))) - #{tmp 3520}#) - (let ((#{_ 3566}# #{tmp 3490}#)) + #{tail 3539}# + (list #{val 3540}#)))))))) + #{tmp 3534}#) + (let ((#{_ 3580}# #{tmp 3504}#)) (syntax-violation 'set! "bad set!" - (#{source-wrap 407}# - #{e 3480}# - #{w 3482}# - #{s 3483}# - #{mod 3484}#)))))))))) - (#{global-extend 335}# + (#{source-wrap 411}# + #{e 3494}# + #{w 3496}# + #{s 3497}# + #{mod 3498}#)))))))))) + (#{global-extend 339}# 'module-ref '@ - (lambda (#{e 3567}# #{r 3568}# #{w 3569}#) - (let ((#{tmp 3573}# #{e 3567}#)) - (let ((#{tmp 3574}# - ($sc-dispatch #{tmp 3573}# '(_ each-any any)))) - (if (if #{tmp 3574}# + (lambda (#{e 3581}# #{r 3582}# #{w 3583}#) + (let ((#{tmp 3587}# #{e 3581}#)) + (let ((#{tmp 3588}# + ($sc-dispatch #{tmp 3587}# '(_ each-any any)))) + (if (if #{tmp 3588}# (@apply - (lambda (#{mod 3577}# #{id 3578}#) - (if (and-map #{id? 339}# #{mod 3577}#) - (#{id? 339}# #{id 3578}#) + (lambda (#{mod 3591}# #{id 3592}#) + (if (and-map #{id? 343}# #{mod 3591}#) + (#{id? 343}# #{id 3592}#) #f)) - #{tmp 3574}#) + #{tmp 3588}#) #f) (@apply - (lambda (#{mod 3584}# #{id 3585}#) + (lambda (#{mod 3598}# #{id 3599}#) (values - (syntax->datum #{id 3585}#) - #{r 3568}# - #{w 3569}# + (syntax->datum #{id 3599}#) + #{r 3582}# + #{w 3583}# #f (syntax->datum (cons '#(syntax-object @@ -10411,12 +10480,12 @@ #(ribcage #(mod id) #((top) (top)) - #("i3582" "i3583")) + #("i3596" "i3597")) #(ribcage () () ()) #(ribcage #(e r w) #((top) (top) (top)) - #("i3570" "i3571" "i3572")) + #("i3584" "i3585" "i3586")) #(ribcage (lambda-var-list gen-var @@ -10431,7 +10500,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -10509,6 +10578,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -10520,7 +10590,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -10542,7 +10612,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -10689,8 +10760,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -10723,14 +10798,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -10738,33 +10813,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -10797,17 +10872,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -10833,70 +10908,70 @@ ((top) (top) (top)) ("i40" "i39" "i38"))) (hygiene guile)) - #{mod 3584}#)))) - #{tmp 3574}#) + #{mod 3598}#)))) + #{tmp 3588}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 3573}#)))))) - (#{global-extend 335}# + #{tmp 3587}#)))))) + (#{global-extend 339}# 'module-ref '@@ - (lambda (#{e 3587}# #{r 3588}# #{w 3589}#) + (lambda (#{e 3601}# #{r 3602}# #{w 3603}#) (letrec* - ((#{remodulate 3594}# - (lambda (#{x 3595}# #{mod 3596}#) - (if (pair? #{x 3595}#) - (cons (#{remodulate 3594}# - (car #{x 3595}#) - #{mod 3596}#) - (#{remodulate 3594}# - (cdr #{x 3595}#) - #{mod 3596}#)) - (if (#{syntax-object? 305}# #{x 3595}#) - (#{make-syntax-object 303}# - (#{remodulate 3594}# - (#{syntax-object-expression 307}# #{x 3595}#) - #{mod 3596}#) - (#{syntax-object-wrap 309}# #{x 3595}#) - #{mod 3596}#) - (if (vector? #{x 3595}#) + ((#{remodulate 3608}# + (lambda (#{x 3609}# #{mod 3610}#) + (if (pair? #{x 3609}#) + (cons (#{remodulate 3608}# + (car #{x 3609}#) + #{mod 3610}#) + (#{remodulate 3608}# + (cdr #{x 3609}#) + #{mod 3610}#)) + (if (#{syntax-object? 309}# #{x 3609}#) + (#{make-syntax-object 307}# + (#{remodulate 3608}# + (#{syntax-object-expression 311}# #{x 3609}#) + #{mod 3610}#) + (#{syntax-object-wrap 313}# #{x 3609}#) + #{mod 3610}#) + (if (vector? #{x 3609}#) (begin - (let ((#{n 3607}# (vector-length #{x 3595}#))) + (let ((#{n 3621}# (vector-length #{x 3609}#))) (begin - (let ((#{v 3609}# (make-vector #{n 3607}#))) + (let ((#{v 3623}# (make-vector #{n 3621}#))) (letrec* - ((#{loop 3612}# - (lambda (#{i 3613}#) - (if (= #{i 3613}# #{n 3607}#) - (begin (if #f #f) #{v 3609}#) + ((#{loop 3626}# + (lambda (#{i 3627}#) + (if (= #{i 3627}# #{n 3621}#) + (begin (if #f #f) #{v 3623}#) (begin (vector-set! - #{v 3609}# - #{i 3613}# - (#{remodulate 3594}# + #{v 3623}# + #{i 3627}# + (#{remodulate 3608}# (vector-ref - #{x 3595}# - #{i 3613}#) - #{mod 3596}#)) - (#{loop 3612}# - (#{1+}# #{i 3613}#))))))) - (begin (#{loop 3612}# 0))))))) - #{x 3595}#)))))) + #{x 3609}# + #{i 3627}#) + #{mod 3610}#)) + (#{loop 3626}# + (#{1+}# #{i 3627}#))))))) + (begin (#{loop 3626}# 0))))))) + #{x 3609}#)))))) (begin - (let ((#{tmp 3619}# #{e 3587}#)) - (let ((#{tmp 3620}# - ($sc-dispatch #{tmp 3619}# '(_ each-any any)))) - (if (if #{tmp 3620}# + (let ((#{tmp 3633}# #{e 3601}#)) + (let ((#{tmp 3634}# + ($sc-dispatch #{tmp 3633}# '(_ each-any any)))) + (if (if #{tmp 3634}# (@apply - (lambda (#{mod 3623}# #{exp 3624}#) - (and-map #{id? 339}# #{mod 3623}#)) - #{tmp 3620}#) + (lambda (#{mod 3637}# #{exp 3638}#) + (and-map #{id? 343}# #{mod 3637}#)) + #{tmp 3634}#) #f) (@apply - (lambda (#{mod 3628}# #{exp 3629}#) + (lambda (#{mod 3642}# #{exp 3643}#) (begin - (let ((#{mod 3631}# + (let ((#{mod 3645}# (syntax->datum (cons '#(syntax-object private @@ -10904,15 +10979,15 @@ #(ribcage #(mod exp) #((top) (top)) - #("i3626" "i3627")) + #("i3640" "i3641")) #(ribcage (remodulate) ((top)) - ("i3593")) + ("i3607")) #(ribcage #(e r w) #((top) (top) (top)) - #("i3590" "i3591" "i3592")) + #("i3604" "i3605" "i3606")) #(ribcage (lambda-var-list gen-var @@ -10927,7 +11002,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -11005,6 +11080,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -11016,7 +11092,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -11038,7 +11114,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -11185,8 +11262,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -11219,14 +11300,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -11234,33 +11315,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -11293,17 +11374,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -11329,169 +11410,169 @@ ((top) (top) (top)) ("i40" "i39" "i38"))) (hygiene guile)) - #{mod 3628}#)))) + #{mod 3642}#)))) (values - (#{remodulate 3594}# #{exp 3629}# #{mod 3631}#) - #{r 3588}# - #{w 3589}# - (#{source-annotation 320}# #{exp 3629}#) - #{mod 3631}#)))) - #{tmp 3620}#) + (#{remodulate 3608}# #{exp 3643}# #{mod 3645}#) + #{r 3602}# + #{w 3603}# + (#{source-annotation 324}# #{exp 3643}#) + #{mod 3645}#)))) + #{tmp 3634}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 3619}#)))))))) - (#{global-extend 335}# + #{tmp 3633}#)))))))) + (#{global-extend 339}# 'core 'if - (lambda (#{e 3633}# - #{r 3634}# - #{w 3635}# - #{s 3636}# - #{mod 3637}#) - (let ((#{tmp 3643}# #{e 3633}#)) - (let ((#{tmp 3644}# - ($sc-dispatch #{tmp 3643}# '(_ any any)))) - (if #{tmp 3644}# + (lambda (#{e 3647}# + #{r 3648}# + #{w 3649}# + #{s 3650}# + #{mod 3651}#) + (let ((#{tmp 3657}# #{e 3647}#)) + (let ((#{tmp 3658}# + ($sc-dispatch #{tmp 3657}# '(_ any any)))) + (if #{tmp 3658}# (@apply - (lambda (#{test 3647}# #{then 3648}#) - (#{build-conditional 267}# - #{s 3636}# - (#{chi 419}# - #{test 3647}# - #{r 3634}# - #{w 3635}# - #{mod 3637}#) - (#{chi 419}# - #{then 3648}# - #{r 3634}# - #{w 3635}# - #{mod 3637}#) - (#{build-void 263}# #f))) - #{tmp 3644}#) - (let ((#{tmp 3650}# - ($sc-dispatch #{tmp 3643}# '(_ any any any)))) - (if #{tmp 3650}# + (lambda (#{test 3661}# #{then 3662}#) + (#{build-conditional 269}# + #{s 3650}# + (#{chi 423}# + #{test 3661}# + #{r 3648}# + #{w 3649}# + #{mod 3651}#) + (#{chi 423}# + #{then 3662}# + #{r 3648}# + #{w 3649}# + #{mod 3651}#) + (#{build-void 265}# #f))) + #{tmp 3658}#) + (let ((#{tmp 3664}# + ($sc-dispatch #{tmp 3657}# '(_ any any any)))) + (if #{tmp 3664}# (@apply - (lambda (#{test 3654}# #{then 3655}# #{else 3656}#) - (#{build-conditional 267}# - #{s 3636}# - (#{chi 419}# - #{test 3654}# - #{r 3634}# - #{w 3635}# - #{mod 3637}#) - (#{chi 419}# - #{then 3655}# - #{r 3634}# - #{w 3635}# - #{mod 3637}#) - (#{chi 419}# - #{else 3656}# - #{r 3634}# - #{w 3635}# - #{mod 3637}#))) - #{tmp 3650}#) + (lambda (#{test 3668}# #{then 3669}# #{else 3670}#) + (#{build-conditional 269}# + #{s 3650}# + (#{chi 423}# + #{test 3668}# + #{r 3648}# + #{w 3649}# + #{mod 3651}#) + (#{chi 423}# + #{then 3669}# + #{r 3648}# + #{w 3649}# + #{mod 3651}#) + (#{chi 423}# + #{else 3670}# + #{r 3648}# + #{w 3649}# + #{mod 3651}#))) + #{tmp 3664}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 3643}#)))))))) - (#{global-extend 335}# + #{tmp 3657}#)))))))) + (#{global-extend 339}# 'core 'with-fluids - (lambda (#{e 3657}# - #{r 3658}# - #{w 3659}# - #{s 3660}# - #{mod 3661}#) - (let ((#{tmp 3667}# #{e 3657}#)) - (let ((#{tmp 3668}# + (lambda (#{e 3671}# + #{r 3672}# + #{w 3673}# + #{s 3674}# + #{mod 3675}#) + (let ((#{tmp 3681}# #{e 3671}#)) + (let ((#{tmp 3682}# ($sc-dispatch - #{tmp 3667}# + #{tmp 3681}# '(_ #(each (any any)) any . each-any)))) - (if #{tmp 3668}# + (if #{tmp 3682}# (@apply - (lambda (#{fluid 3673}# - #{val 3674}# - #{b 3675}# - #{b* 3676}#) - (#{build-dynlet 269}# - #{s 3660}# - (map (lambda (#{x 3677}#) - (#{chi 419}# - #{x 3677}# - #{r 3658}# - #{w 3659}# - #{mod 3661}#)) - #{fluid 3673}#) - (map (lambda (#{x 3680}#) - (#{chi 419}# - #{x 3680}# - #{r 3658}# - #{w 3659}# - #{mod 3661}#)) - #{val 3674}#) - (#{chi-body 427}# - (cons #{b 3675}# #{b* 3676}#) - (#{source-wrap 407}# - #{e 3657}# - #{w 3659}# - #{s 3660}# - #{mod 3661}#) - #{r 3658}# - #{w 3659}# - #{mod 3661}#))) - #{tmp 3668}#) + (lambda (#{fluid 3687}# + #{val 3688}# + #{b 3689}# + #{b* 3690}#) + (#{build-dynlet 271}# + #{s 3674}# + (map (lambda (#{x 3691}#) + (#{chi 423}# + #{x 3691}# + #{r 3672}# + #{w 3673}# + #{mod 3675}#)) + #{fluid 3687}#) + (map (lambda (#{x 3694}#) + (#{chi 423}# + #{x 3694}# + #{r 3672}# + #{w 3673}# + #{mod 3675}#)) + #{val 3688}#) + (#{chi-body 431}# + (cons #{b 3689}# #{b* 3690}#) + (#{source-wrap 411}# + #{e 3671}# + #{w 3673}# + #{s 3674}# + #{mod 3675}#) + #{r 3672}# + #{w 3673}# + #{mod 3675}#))) + #{tmp 3682}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 3667}#)))))) - (#{global-extend 335}# 'begin 'begin '()) - (#{global-extend 335}# 'define 'define '()) - (#{global-extend 335}# + #{tmp 3681}#)))))) + (#{global-extend 339}# 'begin 'begin '()) + (#{global-extend 339}# 'define 'define '()) + (#{global-extend 339}# 'define-syntax 'define-syntax '()) - (#{global-extend 335}# 'eval-when 'eval-when '()) - (#{global-extend 335}# + (#{global-extend 339}# 'eval-when 'eval-when '()) + (#{global-extend 339}# 'core 'syntax-case (letrec* - ((#{convert-pattern 3685}# - (lambda (#{pattern 3692}# #{keys 3693}#) + ((#{convert-pattern 3699}# + (lambda (#{pattern 3706}# #{keys 3707}#) (letrec* - ((#{cvt* 3697}# - (lambda (#{p* 3700}# #{n 3701}# #{ids 3702}#) - (if (null? #{p* 3700}#) - (values '() #{ids 3702}#) + ((#{cvt* 3711}# + (lambda (#{p* 3714}# #{n 3715}# #{ids 3716}#) + (if (null? #{p* 3714}#) + (values '() #{ids 3716}#) (call-with-values (lambda () - (#{cvt* 3697}# - (cdr #{p* 3700}#) - #{n 3701}# - #{ids 3702}#)) - (lambda (#{y 3706}# #{ids 3707}#) + (#{cvt* 3711}# + (cdr #{p* 3714}#) + #{n 3715}# + #{ids 3716}#)) + (lambda (#{y 3720}# #{ids 3721}#) (call-with-values (lambda () - (#{cvt 3699}# - (car #{p* 3700}#) - #{n 3701}# - #{ids 3707}#)) - (lambda (#{x 3710}# #{ids 3711}#) + (#{cvt 3713}# + (car #{p* 3714}#) + #{n 3715}# + #{ids 3721}#)) + (lambda (#{x 3724}# #{ids 3725}#) (values - (cons #{x 3710}# #{y 3706}#) - #{ids 3711}#)))))))) - (#{cvt 3699}# - (lambda (#{p 3714}# #{n 3715}# #{ids 3716}#) - (if (#{id? 339}# #{p 3714}#) - (if (#{bound-id-member? 403}# - #{p 3714}# - #{keys 3693}#) + (cons #{x 3724}# #{y 3720}#) + #{ids 3725}#)))))))) + (#{cvt 3713}# + (lambda (#{p 3728}# #{n 3729}# #{ids 3730}#) + (if (#{id? 343}# #{p 3728}#) + (if (#{bound-id-member? 407}# + #{p 3728}# + #{keys 3707}#) (values - (vector 'free-id #{p 3714}#) - #{ids 3716}#) - (if (#{free-id=? 395}# - #{p 3714}# + (vector 'free-id #{p 3728}#) + #{ids 3730}#) + (if (#{free-id=? 399}# + #{p 3728}# '#(syntax-object _ ((top) @@ -11499,22 +11580,22 @@ #(ribcage #(p n ids) #((top) (top) (top)) - #("i3717" "i3718" "i3719")) + #("i3731" "i3732" "i3733")) #(ribcage (cvt cvt*) ((top) (top)) - ("i3698" "i3696")) + ("i3712" "i3710")) #(ribcage #(pattern keys) #((top) (top)) - #("i3694" "i3695")) + #("i3708" "i3709")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) - ("i3690" "i3688" "i3686" "i3684")) + ("i3704" "i3702" "i3700" "i3698")) #(ribcage (lambda-var-list gen-var @@ -11529,7 +11610,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -11607,6 +11688,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -11618,7 +11700,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -11640,7 +11722,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -11787,8 +11870,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -11821,14 +11908,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -11836,33 +11923,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -11895,17 +11982,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -11931,322 +12018,322 @@ ((top) (top) (top)) ("i40" "i39" "i38"))) (hygiene guile))) - (values '_ #{ids 3716}#) + (values '_ #{ids 3730}#) (values 'any - (cons (cons #{p 3714}# #{n 3715}#) - #{ids 3716}#)))) - (let ((#{tmp 3725}# #{p 3714}#)) - (let ((#{tmp 3726}# - ($sc-dispatch #{tmp 3725}# '(any any)))) - (if (if #{tmp 3726}# + (cons (cons #{p 3728}# #{n 3729}#) + #{ids 3730}#)))) + (let ((#{tmp 3739}# #{p 3728}#)) + (let ((#{tmp 3740}# + ($sc-dispatch #{tmp 3739}# '(any any)))) + (if (if #{tmp 3740}# (@apply - (lambda (#{x 3729}# #{dots 3730}#) - (#{ellipsis? 435}# #{dots 3730}#)) - #{tmp 3726}#) + (lambda (#{x 3743}# #{dots 3744}#) + (#{ellipsis? 439}# #{dots 3744}#)) + #{tmp 3740}#) #f) (@apply - (lambda (#{x 3733}# #{dots 3734}#) + (lambda (#{x 3747}# #{dots 3748}#) (call-with-values (lambda () - (#{cvt 3699}# - #{x 3733}# - (#{1+}# #{n 3715}#) - #{ids 3716}#)) - (lambda (#{p 3736}# #{ids 3737}#) + (#{cvt 3713}# + #{x 3747}# + (#{1+}# #{n 3729}#) + #{ids 3730}#)) + (lambda (#{p 3750}# #{ids 3751}#) (values - (if (eq? #{p 3736}# 'any) + (if (eq? #{p 3750}# 'any) 'each-any - (vector 'each #{p 3736}#)) - #{ids 3737}#)))) - #{tmp 3726}#) - (let ((#{tmp 3740}# + (vector 'each #{p 3750}#)) + #{ids 3751}#)))) + #{tmp 3740}#) + (let ((#{tmp 3754}# ($sc-dispatch - #{tmp 3725}# + #{tmp 3739}# '(any any . each-any)))) - (if (if #{tmp 3740}# + (if (if #{tmp 3754}# (@apply - (lambda (#{x 3744}# - #{dots 3745}# - #{ys 3746}#) - (#{ellipsis? 435}# #{dots 3745}#)) - #{tmp 3740}#) + (lambda (#{x 3758}# + #{dots 3759}# + #{ys 3760}#) + (#{ellipsis? 439}# #{dots 3759}#)) + #{tmp 3754}#) #f) (@apply - (lambda (#{x 3750}# - #{dots 3751}# - #{ys 3752}#) + (lambda (#{x 3764}# + #{dots 3765}# + #{ys 3766}#) (call-with-values (lambda () - (#{cvt* 3697}# - #{ys 3752}# - #{n 3715}# - #{ids 3716}#)) - (lambda (#{ys 3754}# #{ids 3755}#) + (#{cvt* 3711}# + #{ys 3766}# + #{n 3729}# + #{ids 3730}#)) + (lambda (#{ys 3768}# #{ids 3769}#) (call-with-values (lambda () - (#{cvt 3699}# - #{x 3750}# - (#{1+}# #{n 3715}#) - #{ids 3755}#)) - (lambda (#{x 3758}# #{ids 3759}#) + (#{cvt 3713}# + #{x 3764}# + (#{1+}# #{n 3729}#) + #{ids 3769}#)) + (lambda (#{x 3772}# #{ids 3773}#) (values (vector 'each+ - #{x 3758}# - (reverse #{ys 3754}#) + #{x 3772}# + (reverse #{ys 3768}#) '()) - #{ids 3759}#)))))) - #{tmp 3740}#) - (let ((#{tmp 3763}# + #{ids 3773}#)))))) + #{tmp 3754}#) + (let ((#{tmp 3777}# ($sc-dispatch - #{tmp 3725}# + #{tmp 3739}# '(any . any)))) - (if #{tmp 3763}# + (if #{tmp 3777}# (@apply - (lambda (#{x 3766}# #{y 3767}#) + (lambda (#{x 3780}# #{y 3781}#) (call-with-values (lambda () - (#{cvt 3699}# - #{y 3767}# - #{n 3715}# - #{ids 3716}#)) - (lambda (#{y 3768}# #{ids 3769}#) + (#{cvt 3713}# + #{y 3781}# + #{n 3729}# + #{ids 3730}#)) + (lambda (#{y 3782}# #{ids 3783}#) (call-with-values (lambda () - (#{cvt 3699}# - #{x 3766}# - #{n 3715}# - #{ids 3769}#)) - (lambda (#{x 3772}# - #{ids 3773}#) + (#{cvt 3713}# + #{x 3780}# + #{n 3729}# + #{ids 3783}#)) + (lambda (#{x 3786}# + #{ids 3787}#) (values - (cons #{x 3772}# - #{y 3768}#) - #{ids 3773}#)))))) - #{tmp 3763}#) - (let ((#{tmp 3776}# - ($sc-dispatch #{tmp 3725}# '()))) - (if #{tmp 3776}# + (cons #{x 3786}# + #{y 3782}#) + #{ids 3787}#)))))) + #{tmp 3777}#) + (let ((#{tmp 3790}# + ($sc-dispatch #{tmp 3739}# '()))) + (if #{tmp 3790}# (@apply (lambda () - (values '() #{ids 3716}#)) - #{tmp 3776}#) - (let ((#{tmp 3777}# + (values '() #{ids 3730}#)) + #{tmp 3790}#) + (let ((#{tmp 3791}# ($sc-dispatch - #{tmp 3725}# + #{tmp 3739}# '#(vector each-any)))) - (if #{tmp 3777}# + (if #{tmp 3791}# (@apply - (lambda (#{x 3779}#) + (lambda (#{x 3793}#) (call-with-values (lambda () - (#{cvt 3699}# - #{x 3779}# - #{n 3715}# - #{ids 3716}#)) - (lambda (#{p 3781}# - #{ids 3782}#) + (#{cvt 3713}# + #{x 3793}# + #{n 3729}# + #{ids 3730}#)) + (lambda (#{p 3795}# + #{ids 3796}#) (values (vector 'vector - #{p 3781}#) - #{ids 3782}#)))) - #{tmp 3777}#) - (let ((#{x 3786}# #{tmp 3725}#)) + #{p 3795}#) + #{ids 3796}#)))) + #{tmp 3791}#) + (let ((#{x 3800}# #{tmp 3739}#)) (values (vector 'atom - (#{strip 445}# - #{p 3714}# + (#{strip 449}# + #{p 3728}# '(()))) - #{ids 3716}#))))))))))))))))) - (begin (#{cvt 3699}# #{pattern 3692}# 0 '()))))) - (#{build-dispatch-call 3687}# - (lambda (#{pvars 3788}# - #{exp 3789}# - #{y 3790}# - #{r 3791}# - #{mod 3792}#) + #{ids 3730}#))))))))))))))))) + (begin (#{cvt 3713}# #{pattern 3706}# 0 '()))))) + (#{build-dispatch-call 3701}# + (lambda (#{pvars 3802}# + #{exp 3803}# + #{y 3804}# + #{r 3805}# + #{mod 3806}#) (begin - (map cdr #{pvars 3788}#) - (let ((#{ids 3800}# (map car #{pvars 3788}#))) + (map cdr #{pvars 3802}#) + (let ((#{ids 3814}# (map car #{pvars 3802}#))) (begin - (let ((#{labels 3804}# - (#{gen-labels 354}# #{ids 3800}#)) - (#{new-vars 3805}# - (map #{gen-var 447}# #{ids 3800}#))) - (#{build-application 265}# + (let ((#{labels 3818}# + (#{gen-labels 358}# #{ids 3814}#)) + (#{new-vars 3819}# + (map #{gen-var 451}# #{ids 3814}#))) + (#{build-primcall 291}# #f - (#{build-primref 289}# #f 'apply) - (list (#{build-simple-lambda 283}# + 'apply + (list (#{build-simple-lambda 285}# #f - (map syntax->datum #{ids 3800}#) + (map syntax->datum #{ids 3814}#) #f - #{new-vars 3805}# + #{new-vars 3819}# '() - (#{chi 419}# - #{exp 3789}# - (#{extend-env 327}# - #{labels 3804}# - (map (lambda (#{var 3809}# #{level 3810}#) + (#{chi 423}# + #{exp 3803}# + (#{extend-env 331}# + #{labels 3818}# + (map (lambda (#{var 3822}# #{level 3823}#) (cons 'syntax - (cons #{var 3809}# - #{level 3810}#))) - #{new-vars 3805}# - (map cdr #{pvars 3788}#)) - #{r 3791}#) - (#{make-binding-wrap 383}# - #{ids 3800}# - #{labels 3804}# + (cons #{var 3822}# + #{level 3823}#))) + #{new-vars 3819}# + (map cdr #{pvars 3802}#)) + #{r 3805}#) + (#{make-binding-wrap 387}# + #{ids 3814}# + #{labels 3818}# '(())) - #{mod 3792}#)) - #{y 3790}#)))))))) - (#{gen-clause 3689}# - (lambda (#{x 3816}# - #{keys 3817}# - #{clauses 3818}# - #{r 3819}# - #{pat 3820}# - #{fender 3821}# - #{exp 3822}# - #{mod 3823}#) + #{mod 3806}#)) + #{y 3804}#)))))))) + (#{gen-clause 3703}# + (lambda (#{x 3829}# + #{keys 3830}# + #{clauses 3831}# + #{r 3832}# + #{pat 3833}# + #{fender 3834}# + #{exp 3835}# + #{mod 3836}#) (call-with-values (lambda () - (#{convert-pattern 3685}# - #{pat 3820}# - #{keys 3817}#)) - (lambda (#{p 3832}# #{pvars 3833}#) - (if (not (#{distinct-bound-ids? 401}# - (map car #{pvars 3833}#))) + (#{convert-pattern 3699}# + #{pat 3833}# + #{keys 3830}#)) + (lambda (#{p 3845}# #{pvars 3846}#) + (if (not (#{distinct-bound-ids? 405}# + (map car #{pvars 3846}#))) (syntax-violation 'syntax-case "duplicate pattern variable" - #{pat 3820}#) + #{pat 3833}#) (if (not (and-map - (lambda (#{x 3840}#) - (not (#{ellipsis? 435}# (car #{x 3840}#)))) - #{pvars 3833}#)) + (lambda (#{x 3853}#) + (not (#{ellipsis? 439}# (car #{x 3853}#)))) + #{pvars 3846}#)) (syntax-violation 'syntax-case "misplaced ellipsis" - #{pat 3820}#) + #{pat 3833}#) (begin - (let ((#{y 3844}# (#{gen-var 447}# 'tmp))) - (#{build-application 265}# + (let ((#{y 3857}# (#{gen-var 451}# 'tmp))) + (#{build-call 267}# #f - (#{build-simple-lambda 283}# + (#{build-simple-lambda 285}# #f (list 'tmp) #f - (list #{y 3844}#) + (list #{y 3857}#) '() (begin - (let ((#{y 3848}# - (#{build-lexical-reference 271}# + (let ((#{y 3861}# + (#{build-lexical-reference 273}# 'value #f 'tmp - #{y 3844}#))) - (#{build-conditional 267}# + #{y 3857}#))) + (#{build-conditional 269}# #f - (let ((#{tmp 3851}# #{fender 3821}#)) - (let ((#{tmp 3852}# + (let ((#{tmp 3864}# #{fender 3834}#)) + (let ((#{tmp 3865}# ($sc-dispatch - #{tmp 3851}# + #{tmp 3864}# '#(atom #t)))) - (if #{tmp 3852}# + (if #{tmp 3865}# (@apply - (lambda () #{y 3848}#) - #{tmp 3852}#) - (let ((#{_ 3854}# #{tmp 3851}#)) - (#{build-conditional 267}# + (lambda () #{y 3861}#) + #{tmp 3865}#) + (let ((#{_ 3867}# #{tmp 3864}#)) + (#{build-conditional 269}# #f - #{y 3848}# - (#{build-dispatch-call 3687}# - #{pvars 3833}# - #{fender 3821}# - #{y 3848}# - #{r 3819}# - #{mod 3823}#) - (#{build-data 291}# #f #f)))))) - (#{build-dispatch-call 3687}# - #{pvars 3833}# - #{exp 3822}# - #{y 3848}# - #{r 3819}# - #{mod 3823}#) - (#{gen-syntax-case 3691}# - #{x 3816}# - #{keys 3817}# - #{clauses 3818}# - #{r 3819}# - #{mod 3823}#))))) - (list (if (eq? #{p 3832}# 'any) - (#{build-application 265}# + #{y 3861}# + (#{build-dispatch-call 3701}# + #{pvars 3846}# + #{fender 3834}# + #{y 3861}# + #{r 3832}# + #{mod 3836}#) + (#{build-data 295}# #f #f)))))) + (#{build-dispatch-call 3701}# + #{pvars 3846}# + #{exp 3835}# + #{y 3861}# + #{r 3832}# + #{mod 3836}#) + (#{gen-syntax-case 3705}# + #{x 3829}# + #{keys 3830}# + #{clauses 3831}# + #{r 3832}# + #{mod 3836}#))))) + (list (if (eq? #{p 3845}# 'any) + (#{build-primcall 291}# #f - (#{build-primref 289}# #f 'list) - (list #{x 3816}#)) - (#{build-application 265}# + 'list + (list #{x 3829}#)) + (#{build-primcall 291}# #f - (#{build-primref 289}# #f '$sc-dispatch) - (list #{x 3816}# - (#{build-data 291}# + '$sc-dispatch + (list #{x 3829}# + (#{build-data 295}# #f - #{p 3832}#)))))))))))))) - (#{gen-syntax-case 3691}# - (lambda (#{x 3862}# - #{keys 3863}# - #{clauses 3864}# - #{r 3865}# - #{mod 3866}#) - (if (null? #{clauses 3864}#) - (#{build-application 265}# + #{p 3845}#)))))))))))))) + (#{gen-syntax-case 3705}# + (lambda (#{x 3873}# + #{keys 3874}# + #{clauses 3875}# + #{r 3876}# + #{mod 3877}#) + (if (null? #{clauses 3875}#) + (#{build-primcall 291}# #f - (#{build-primref 289}# #f 'syntax-violation) - (list (#{build-data 291}# #f #f) - (#{build-data 291}# + 'syntax-violation + (list (#{build-data 295}# #f #f) + (#{build-data 295}# #f "source expression failed to match any pattern") - #{x 3862}#)) - (let ((#{tmp 3876}# (car #{clauses 3864}#))) - (let ((#{tmp 3877}# - ($sc-dispatch #{tmp 3876}# '(any any)))) - (if #{tmp 3877}# + #{x 3873}#)) + (let ((#{tmp 3886}# (car #{clauses 3875}#))) + (let ((#{tmp 3887}# + ($sc-dispatch #{tmp 3886}# '(any any)))) + (if #{tmp 3887}# (@apply - (lambda (#{pat 3880}# #{exp 3881}#) - (if (if (#{id? 339}# #{pat 3880}#) + (lambda (#{pat 3890}# #{exp 3891}#) + (if (if (#{id? 343}# #{pat 3890}#) (and-map - (lambda (#{x 3884}#) - (not (#{free-id=? 395}# - #{pat 3880}# - #{x 3884}#))) + (lambda (#{x 3894}#) + (not (#{free-id=? 399}# + #{pat 3890}# + #{x 3894}#))) (cons '#(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) - #("i3878" "i3879")) + #("i3888" "i3889")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) - #("i3867" - "i3868" - "i3869" - "i3870" - "i3871")) + #("i3878" + "i3879" + "i3880" + "i3881" + "i3882")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) - ("i3690" - "i3688" - "i3686" - "i3684")) + ("i3704" + "i3702" + "i3700" + "i3698")) #(ribcage (lambda-var-list gen-var @@ -12261,7 +12348,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -12339,6 +12426,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -12350,7 +12438,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -12372,7 +12460,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -12519,8 +12608,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -12553,14 +12646,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -12568,33 +12661,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -12627,17 +12720,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -12663,32 +12756,32 @@ ((top) (top) (top)) ("i40" "i39" "i38"))) (hygiene guile)) - #{keys 3863}#)) + #{keys 3874}#)) #f) - (if (#{free-id=? 395}# + (if (#{free-id=? 399}# '#(syntax-object pad ((top) #(ribcage #(pat exp) #((top) (top)) - #("i3878" "i3879")) + #("i3888" "i3889")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) - #("i3867" - "i3868" - "i3869" - "i3870" - "i3871")) + #("i3878" + "i3879" + "i3880" + "i3881" + "i3882")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) - ("i3690" "i3688" "i3686" "i3684")) + ("i3704" "i3702" "i3700" "i3698")) #(ribcage (lambda-var-list gen-var @@ -12703,7 +12796,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -12781,6 +12874,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -12792,7 +12886,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -12814,7 +12908,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -12961,8 +13056,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -12995,14 +13094,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -13010,33 +13109,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -13069,17 +13168,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -13111,23 +13210,23 @@ #(ribcage #(pat exp) #((top) (top)) - #("i3878" "i3879")) + #("i3888" "i3889")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) - #("i3867" - "i3868" - "i3869" - "i3870" - "i3871")) + #("i3878" + "i3879" + "i3880" + "i3881" + "i3882")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) - ("i3690" "i3688" "i3686" "i3684")) + ("i3704" "i3702" "i3700" "i3698")) #(ribcage (lambda-var-list gen-var @@ -13142,7 +13241,7 @@ chi-local-syntax chi-body chi-macro - chi-application + chi-call chi-expr chi syntax-type @@ -13220,6 +13319,7 @@ build-sequence build-data build-primref + build-primcall build-lambda-case build-case-lambda build-simple-lambda @@ -13231,7 +13331,7 @@ build-lexical-reference build-dynlet build-conditional - build-application + build-call build-void maybe-name-value! decorate-source @@ -13253,7 +13353,8 @@ make-lambda-case make-lambda make-sequence - make-application + make-primcall + make-call make-conditional make-toplevel-define make-toplevel-set @@ -13400,8 +13501,12 @@ (top) (top) (top) + (top) + (top) (top)) - ("i448" + ("i452" + "i450" + "i448" "i446" "i444" "i442" @@ -13434,14 +13539,14 @@ "i388" "i386" "i384" + "i383" "i382" "i380" "i379" "i378" + "i377" "i376" - "i375" "i374" - "i373" "i372" "i370" "i368" @@ -13449,33 +13554,33 @@ "i364" "i362" "i360" - "i358" - "i356" + "i357" + "i355" + "i354" "i353" + "i352" "i351" "i350" "i349" "i348" "i347" - "i346" "i345" "i344" - "i343" - "i341" + "i342" "i340" "i338" "i336" "i334" "i332" "i330" + "i329" "i328" + "i327" "i326" "i325" - "i324" "i323" "i322" - "i321" - "i319" + "i320" "i318" "i316" "i314" @@ -13508,17 +13613,17 @@ "i260" "i258" "i256" - "i254" + "i255" "i253" "i251" + "i250" "i249" "i248" "i247" - "i246" "i245" "i243" "i241" - "i239" + "i238" "i236" "i234" "i232" @@ -13544,562 +13649,560 @@ ((top) (top) (top)) ("i40" "i39" "i38"))) (hygiene guile))) - (#{chi 419}# - #{exp 3881}# - #{r 3865}# + (#{chi 423}# + #{exp 3891}# + #{r 3876}# '(()) - #{mod 3866}#) + #{mod 3877}#) (begin - (let ((#{labels 3889}# - (list (#{gen-label 352}#))) - (#{var 3890}# - (#{gen-var 447}# #{pat 3880}#))) - (#{build-application 265}# + (let ((#{labels 3899}# + (list (#{gen-label 356}#))) + (#{var 3900}# + (#{gen-var 451}# #{pat 3890}#))) + (#{build-call 267}# #f - (#{build-simple-lambda 283}# + (#{build-simple-lambda 285}# #f - (list (syntax->datum #{pat 3880}#)) + (list (syntax->datum #{pat 3890}#)) #f - (list #{var 3890}#) + (list #{var 3900}#) '() - (#{chi 419}# - #{exp 3881}# - (#{extend-env 327}# - #{labels 3889}# + (#{chi 423}# + #{exp 3891}# + (#{extend-env 331}# + #{labels 3899}# (list (cons 'syntax - (cons #{var 3890}# 0))) - #{r 3865}#) - (#{make-binding-wrap 383}# - (list #{pat 3880}#) - #{labels 3889}# + (cons #{var 3900}# 0))) + #{r 3876}#) + (#{make-binding-wrap 387}# + (list #{pat 3890}#) + #{labels 3899}# '(())) - #{mod 3866}#)) - (list #{x 3862}#))))) - (#{gen-clause 3689}# - #{x 3862}# - #{keys 3863}# - (cdr #{clauses 3864}#) - #{r 3865}# - #{pat 3880}# + #{mod 3877}#)) + (list #{x 3873}#))))) + (#{gen-clause 3703}# + #{x 3873}# + #{keys 3874}# + (cdr #{clauses 3875}#) + #{r 3876}# + #{pat 3890}# #t - #{exp 3881}# - #{mod 3866}#))) - #{tmp 3877}#) - (let ((#{tmp 3896}# - ($sc-dispatch #{tmp 3876}# '(any any any)))) - (if #{tmp 3896}# + #{exp 3891}# + #{mod 3877}#))) + #{tmp 3887}#) + (let ((#{tmp 3906}# + ($sc-dispatch #{tmp 3886}# '(any any any)))) + (if #{tmp 3906}# (@apply - (lambda (#{pat 3900}# - #{fender 3901}# - #{exp 3902}#) - (#{gen-clause 3689}# - #{x 3862}# - #{keys 3863}# - (cdr #{clauses 3864}#) - #{r 3865}# - #{pat 3900}# - #{fender 3901}# - #{exp 3902}# - #{mod 3866}#)) - #{tmp 3896}#) - (let ((#{_ 3904}# #{tmp 3876}#)) + (lambda (#{pat 3910}# + #{fender 3911}# + #{exp 3912}#) + (#{gen-clause 3703}# + #{x 3873}# + #{keys 3874}# + (cdr #{clauses 3875}#) + #{r 3876}# + #{pat 3910}# + #{fender 3911}# + #{exp 3912}# + #{mod 3877}#)) + #{tmp 3906}#) + (let ((#{_ 3914}# #{tmp 3886}#)) (syntax-violation 'syntax-case "invalid clause" - (car #{clauses 3864}#)))))))))))) + (car #{clauses 3875}#)))))))))))) (begin - (lambda (#{e 3905}# - #{r 3906}# - #{w 3907}# - #{s 3908}# - #{mod 3909}#) + (lambda (#{e 3915}# + #{r 3916}# + #{w 3917}# + #{s 3918}# + #{mod 3919}#) (begin - (let ((#{e 3916}# - (#{source-wrap 407}# - #{e 3905}# - #{w 3907}# - #{s 3908}# - #{mod 3909}#))) - (let ((#{tmp 3917}# #{e 3916}#)) - (let ((#{tmp 3918}# + (let ((#{e 3926}# + (#{source-wrap 411}# + #{e 3915}# + #{w 3917}# + #{s 3918}# + #{mod 3919}#))) + (let ((#{tmp 3927}# #{e 3926}#)) + (let ((#{tmp 3928}# ($sc-dispatch - #{tmp 3917}# + #{tmp 3927}# '(_ any each-any . each-any)))) - (if #{tmp 3918}# + (if #{tmp 3928}# (@apply - (lambda (#{val 3922}# #{key 3923}# #{m 3924}#) + (lambda (#{val 3932}# #{key 3933}# #{m 3934}#) (if (and-map - (lambda (#{x 3925}#) - (if (#{id? 339}# #{x 3925}#) - (not (#{ellipsis? 435}# #{x 3925}#)) + (lambda (#{x 3935}#) + (if (#{id? 343}# #{x 3935}#) + (not (#{ellipsis? 439}# #{x 3935}#)) #f)) - #{key 3923}#) + #{key 3933}#) (begin - (let ((#{x 3931}# (#{gen-var 447}# 'tmp))) - (#{build-application 265}# - #{s 3908}# - (#{build-simple-lambda 283}# + (let ((#{x 3941}# (#{gen-var 451}# 'tmp))) + (#{build-call 267}# + #{s 3918}# + (#{build-simple-lambda 285}# #f (list 'tmp) #f - (list #{x 3931}#) + (list #{x 3941}#) '() - (#{gen-syntax-case 3691}# - (#{build-lexical-reference 271}# + (#{gen-syntax-case 3705}# + (#{build-lexical-reference 273}# 'value #f 'tmp - #{x 3931}#) - #{key 3923}# - #{m 3924}# - #{r 3906}# - #{mod 3909}#)) - (list (#{chi 419}# - #{val 3922}# - #{r 3906}# + #{x 3941}#) + #{key 3933}# + #{m 3934}# + #{r 3916}# + #{mod 3919}#)) + (list (#{chi 423}# + #{val 3932}# + #{r 3916}# '(()) - #{mod 3909}#))))) + #{mod 3919}#))))) (syntax-violation 'syntax-case "invalid literals list" - #{e 3916}#))) - #{tmp 3918}#) + #{e 3926}#))) + #{tmp 3928}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 3917}#)))))))))) + #{tmp 3927}#)))))))))) (set! macroexpand (lambda* - (#{x 3937}# + (#{x 3947}# #:optional - (#{m 3939}# 'e) - (#{esew 3941}# '(eval))) - (#{chi-top-sequence 411}# - (list #{x 3937}#) + (#{m 3949}# 'e) + (#{esew 3951}# '(eval))) + (#{chi-top-sequence 415}# + (list #{x 3947}#) '() '((top)) #f - #{m 3939}# - #{esew 3941}# + #{m 3949}# + #{esew 3951}# (cons 'hygiene (module-name (current-module)))))) (set! identifier? - (lambda (#{x 3945}#) - (#{nonsymbol-id? 337}# #{x 3945}#))) + (lambda (#{x 3955}#) + (#{nonsymbol-id? 341}# #{x 3955}#))) (set! datum->syntax - (lambda (#{id 3947}# #{datum 3948}#) - (#{make-syntax-object 303}# - #{datum 3948}# - (#{syntax-object-wrap 309}# #{id 3947}#) - (#{syntax-object-module 311}# #{id 3947}#)))) + (lambda (#{id 3957}# #{datum 3958}#) + (#{make-syntax-object 307}# + #{datum 3958}# + (#{syntax-object-wrap 313}# #{id 3957}#) + (#{syntax-object-module 315}# #{id 3957}#)))) (set! syntax->datum - (lambda (#{x 3951}#) - (#{strip 445}# #{x 3951}# '(())))) + (lambda (#{x 3961}#) + (#{strip 449}# #{x 3961}# '(())))) (set! syntax-source - (lambda (#{x 3954}#) - (#{source-annotation 320}# #{x 3954}#))) + (lambda (#{x 3964}#) + (#{source-annotation 324}# #{x 3964}#))) (set! generate-temporaries - (lambda (#{ls 3956}#) + (lambda (#{ls 3966}#) (begin (begin - (let ((#{x 3960}# #{ls 3956}#)) - (if (not (list? #{x 3960}#)) + (let ((#{x 3970}# #{ls 3966}#)) + (if (not (list? #{x 3970}#)) (syntax-violation 'generate-temporaries "invalid argument" - #{x 3960}#)))) - (map (lambda (#{x 3961}#) - (#{wrap 405}# (gensym) '((top)) #f)) - #{ls 3956}#)))) + #{x 3970}#)))) + (map (lambda (#{x 3971}#) + (#{wrap 409}# (gensym) '((top)) #f)) + #{ls 3966}#)))) (set! free-identifier=? - (lambda (#{x 3965}# #{y 3966}#) + (lambda (#{x 3975}# #{y 3976}#) (begin (begin - (let ((#{x 3971}# #{x 3965}#)) - (if (not (#{nonsymbol-id? 337}# #{x 3971}#)) + (let ((#{x 3981}# #{x 3975}#)) + (if (not (#{nonsymbol-id? 341}# #{x 3981}#)) (syntax-violation 'free-identifier=? "invalid argument" - #{x 3971}#)))) + #{x 3981}#)))) (begin - (let ((#{x 3974}# #{y 3966}#)) - (if (not (#{nonsymbol-id? 337}# #{x 3974}#)) + (let ((#{x 3984}# #{y 3976}#)) + (if (not (#{nonsymbol-id? 341}# #{x 3984}#)) (syntax-violation 'free-identifier=? "invalid argument" - #{x 3974}#)))) - (#{free-id=? 395}# #{x 3965}# #{y 3966}#)))) + #{x 3984}#)))) + (#{free-id=? 399}# #{x 3975}# #{y 3976}#)))) (set! bound-identifier=? - (lambda (#{x 3975}# #{y 3976}#) + (lambda (#{x 3985}# #{y 3986}#) (begin (begin - (let ((#{x 3981}# #{x 3975}#)) - (if (not (#{nonsymbol-id? 337}# #{x 3981}#)) + (let ((#{x 3991}# #{x 3985}#)) + (if (not (#{nonsymbol-id? 341}# #{x 3991}#)) (syntax-violation 'bound-identifier=? "invalid argument" - #{x 3981}#)))) + #{x 3991}#)))) (begin - (let ((#{x 3984}# #{y 3976}#)) - (if (not (#{nonsymbol-id? 337}# #{x 3984}#)) + (let ((#{x 3994}# #{y 3986}#)) + (if (not (#{nonsymbol-id? 341}# #{x 3994}#)) (syntax-violation 'bound-identifier=? "invalid argument" - #{x 3984}#)))) - (#{bound-id=? 397}# #{x 3975}# #{y 3976}#)))) + #{x 3994}#)))) + (#{bound-id=? 401}# #{x 3985}# #{y 3986}#)))) (set! syntax-violation (lambda* - (#{who 3985}# - #{message 3986}# - #{form 3987}# + (#{who 3995}# + #{message 3996}# + #{form 3997}# #:optional - (#{subform 3991}# #f)) + (#{subform 4001}# #f)) (begin (begin - (let ((#{x 3995}# #{who 3985}#)) - (if (not (let ((#{x 3996}# #{x 3995}#)) + (let ((#{x 4005}# #{who 3995}#)) + (if (not (let ((#{x 4006}# #{x 4005}#)) (begin - (let ((#{t 4000}# (not #{x 3996}#))) - (if #{t 4000}# - #{t 4000}# + (let ((#{t 4010}# (not #{x 4006}#))) + (if #{t 4010}# + #{t 4010}# (begin - (let ((#{t 4003}# (string? #{x 3996}#))) - (if #{t 4003}# - #{t 4003}# - (symbol? #{x 3996}#))))))))) + (let ((#{t 4013}# (string? #{x 4006}#))) + (if #{t 4013}# + #{t 4013}# + (symbol? #{x 4006}#))))))))) (syntax-violation 'syntax-violation "invalid argument" - #{x 3995}#)))) + #{x 4005}#)))) (begin - (let ((#{x 4007}# #{message 3986}#)) - (if (not (string? #{x 4007}#)) + (let ((#{x 4017}# #{message 3996}#)) + (if (not (string? #{x 4017}#)) (syntax-violation 'syntax-violation "invalid argument" - #{x 4007}#)))) + #{x 4017}#)))) (throw 'syntax-error - #{who 3985}# - #{message 3986}# - (#{source-annotation 320}# + #{who 3995}# + #{message 3996}# + (#{source-annotation 324}# (begin - (let ((#{t 4010}# #{form 3987}#)) - (if #{t 4010}# #{t 4010}# #{subform 3991}#)))) - (#{strip 445}# #{form 3987}# '(())) - (if #{subform 3991}# - (#{strip 445}# #{subform 3991}# '(())) + (let ((#{t 4020}# #{form 3997}#)) + (if #{t 4020}# #{t 4020}# #{subform 4001}#)))) + (#{strip 449}# #{form 3997}# '(())) + (if #{subform 4001}# + (#{strip 449}# #{subform 4001}# '(())) #f))))) (letrec* - ((#{match-each 4017}# - (lambda (#{e 4030}# #{p 4031}# #{w 4032}# #{mod 4033}#) - (if (pair? #{e 4030}#) + ((#{match-each 4027}# + (lambda (#{e 4040}# #{p 4041}# #{w 4042}# #{mod 4043}#) + (if (pair? #{e 4040}#) (begin - (let ((#{first 4041}# - (#{match 4029}# - (car #{e 4030}#) - #{p 4031}# - #{w 4032}# + (let ((#{first 4051}# + (#{match 4039}# + (car #{e 4040}#) + #{p 4041}# + #{w 4042}# '() - #{mod 4033}#))) - (if #{first 4041}# + #{mod 4043}#))) + (if #{first 4051}# (begin - (let ((#{rest 4045}# - (#{match-each 4017}# - (cdr #{e 4030}#) - #{p 4031}# - #{w 4032}# - #{mod 4033}#))) - (if #{rest 4045}# - (cons #{first 4041}# #{rest 4045}#) + (let ((#{rest 4055}# + (#{match-each 4027}# + (cdr #{e 4040}#) + #{p 4041}# + #{w 4042}# + #{mod 4043}#))) + (if #{rest 4055}# + (cons #{first 4051}# #{rest 4055}#) #f))) #f))) - (if (null? #{e 4030}#) + (if (null? #{e 4040}#) '() - (if (#{syntax-object? 305}# #{e 4030}#) - (#{match-each 4017}# - (#{syntax-object-expression 307}# #{e 4030}#) - #{p 4031}# - (#{join-wraps 387}# - #{w 4032}# - (#{syntax-object-wrap 309}# #{e 4030}#)) - (#{syntax-object-module 311}# #{e 4030}#)) + (if (#{syntax-object? 309}# #{e 4040}#) + (#{match-each 4027}# + (#{syntax-object-expression 311}# #{e 4040}#) + #{p 4041}# + (#{join-wraps 391}# + #{w 4042}# + (#{syntax-object-wrap 313}# #{e 4040}#)) + (#{syntax-object-module 315}# #{e 4040}#)) #f))))) - (#{match-each+ 4019}# - (lambda (#{e 4053}# - #{x-pat 4054}# - #{y-pat 4055}# - #{z-pat 4056}# - #{w 4057}# - #{r 4058}# - #{mod 4059}#) + (#{match-each+ 4029}# + (lambda (#{e 4063}# + #{x-pat 4064}# + #{y-pat 4065}# + #{z-pat 4066}# + #{w 4067}# + #{r 4068}# + #{mod 4069}#) (letrec* - ((#{f 4070}# - (lambda (#{e 4071}# #{w 4072}#) - (if (pair? #{e 4071}#) + ((#{f 4080}# + (lambda (#{e 4081}# #{w 4082}#) + (if (pair? #{e 4081}#) (call-with-values (lambda () - (#{f 4070}# (cdr #{e 4071}#) #{w 4072}#)) - (lambda (#{xr* 4075}# #{y-pat 4076}# #{r 4077}#) - (if #{r 4077}# - (if (null? #{y-pat 4076}#) + (#{f 4080}# (cdr #{e 4081}#) #{w 4082}#)) + (lambda (#{xr* 4085}# #{y-pat 4086}# #{r 4087}#) + (if #{r 4087}# + (if (null? #{y-pat 4086}#) (begin - (let ((#{xr 4082}# - (#{match 4029}# - (car #{e 4071}#) - #{x-pat 4054}# - #{w 4072}# + (let ((#{xr 4092}# + (#{match 4039}# + (car #{e 4081}#) + #{x-pat 4064}# + #{w 4082}# '() - #{mod 4059}#))) - (if #{xr 4082}# + #{mod 4069}#))) + (if #{xr 4092}# (values - (cons #{xr 4082}# #{xr* 4075}#) - #{y-pat 4076}# - #{r 4077}#) + (cons #{xr 4092}# #{xr* 4085}#) + #{y-pat 4086}# + #{r 4087}#) (values #f #f #f)))) (values '() - (cdr #{y-pat 4076}#) - (#{match 4029}# - (car #{e 4071}#) - (car #{y-pat 4076}#) - #{w 4072}# - #{r 4077}# - #{mod 4059}#))) + (cdr #{y-pat 4086}#) + (#{match 4039}# + (car #{e 4081}#) + (car #{y-pat 4086}#) + #{w 4082}# + #{r 4087}# + #{mod 4069}#))) (values #f #f #f)))) - (if (#{syntax-object? 305}# #{e 4071}#) - (#{f 4070}# - (#{syntax-object-expression 307}# #{e 4071}#) - (#{join-wraps 387}# #{w 4072}# #{e 4071}#)) + (if (#{syntax-object? 309}# #{e 4081}#) + (#{f 4080}# + (#{syntax-object-expression 311}# #{e 4081}#) + (#{join-wraps 391}# #{w 4082}# #{e 4081}#)) (values '() - #{y-pat 4055}# - (#{match 4029}# - #{e 4071}# - #{z-pat 4056}# - #{w 4072}# - #{r 4058}# - #{mod 4059}#))))))) - (begin (#{f 4070}# #{e 4053}# #{w 4057}#))))) - (#{match-each-any 4021}# - (lambda (#{e 4086}# #{w 4087}# #{mod 4088}#) - (if (pair? #{e 4086}#) + #{y-pat 4065}# + (#{match 4039}# + #{e 4081}# + #{z-pat 4066}# + #{w 4082}# + #{r 4068}# + #{mod 4069}#))))))) + (begin (#{f 4080}# #{e 4063}# #{w 4067}#))))) + (#{match-each-any 4031}# + (lambda (#{e 4096}# #{w 4097}# #{mod 4098}#) + (if (pair? #{e 4096}#) (begin - (let ((#{l 4095}# - (#{match-each-any 4021}# - (cdr #{e 4086}#) - #{w 4087}# - #{mod 4088}#))) - (if #{l 4095}# - (cons (#{wrap 405}# - (car #{e 4086}#) - #{w 4087}# - #{mod 4088}#) - #{l 4095}#) + (let ((#{l 4105}# + (#{match-each-any 4031}# + (cdr #{e 4096}#) + #{w 4097}# + #{mod 4098}#))) + (if #{l 4105}# + (cons (#{wrap 409}# + (car #{e 4096}#) + #{w 4097}# + #{mod 4098}#) + #{l 4105}#) #f))) - (if (null? #{e 4086}#) + (if (null? #{e 4096}#) '() - (if (#{syntax-object? 305}# #{e 4086}#) - (#{match-each-any 4021}# - (#{syntax-object-expression 307}# #{e 4086}#) - (#{join-wraps 387}# - #{w 4087}# - (#{syntax-object-wrap 309}# #{e 4086}#)) - #{mod 4088}#) + (if (#{syntax-object? 309}# #{e 4096}#) + (#{match-each-any 4031}# + (#{syntax-object-expression 311}# #{e 4096}#) + (#{join-wraps 391}# + #{w 4097}# + (#{syntax-object-wrap 313}# #{e 4096}#)) + #{mod 4098}#) #f))))) - (#{match-empty 4023}# - (lambda (#{p 4103}# #{r 4104}#) - (if (null? #{p 4103}#) - #{r 4104}# - (if (eq? #{p 4103}# '_) - #{r 4104}# - (if (eq? #{p 4103}# 'any) - (cons '() #{r 4104}#) - (if (pair? #{p 4103}#) - (#{match-empty 4023}# - (car #{p 4103}#) - (#{match-empty 4023}# - (cdr #{p 4103}#) - #{r 4104}#)) - (if (eq? #{p 4103}# 'each-any) - (cons '() #{r 4104}#) + (#{match-empty 4033}# + (lambda (#{p 4113}# #{r 4114}#) + (if (null? #{p 4113}#) + #{r 4114}# + (if (eq? #{p 4113}# '_) + #{r 4114}# + (if (eq? #{p 4113}# 'any) + (cons '() #{r 4114}#) + (if (pair? #{p 4113}#) + (#{match-empty 4033}# + (car #{p 4113}#) + (#{match-empty 4033}# + (cdr #{p 4113}#) + #{r 4114}#)) + (if (eq? #{p 4113}# 'each-any) + (cons '() #{r 4114}#) (begin - (let ((#{atom-key 4120}# (vector-ref #{p 4103}# 0))) - (if (eqv? #{atom-key 4120}# 'each) - (#{match-empty 4023}# - (vector-ref #{p 4103}# 1) - #{r 4104}#) - (if (eqv? #{atom-key 4120}# 'each+) - (#{match-empty 4023}# - (vector-ref #{p 4103}# 1) - (#{match-empty 4023}# - (reverse (vector-ref #{p 4103}# 2)) - (#{match-empty 4023}# - (vector-ref #{p 4103}# 3) - #{r 4104}#))) - (if (if (eqv? #{atom-key 4120}# 'free-id) - #t - (eqv? #{atom-key 4120}# 'atom)) - #{r 4104}# - (if (eqv? #{atom-key 4120}# 'vector) - (#{match-empty 4023}# - (vector-ref #{p 4103}# 1) - #{r 4104}#)))))))))))))) - (#{combine 4025}# - (lambda (#{r* 4125}# #{r 4126}#) - (if (null? (car #{r* 4125}#)) - #{r 4126}# - (cons (map car #{r* 4125}#) - (#{combine 4025}# - (map cdr #{r* 4125}#) - #{r 4126}#))))) - (#{match* 4027}# - (lambda (#{e 4129}# - #{p 4130}# - #{w 4131}# - #{r 4132}# - #{mod 4133}#) - (if (null? #{p 4130}#) - (if (null? #{e 4129}#) #{r 4132}# #f) - (if (pair? #{p 4130}#) - (if (pair? #{e 4129}#) - (#{match 4029}# - (car #{e 4129}#) - (car #{p 4130}#) - #{w 4131}# - (#{match 4029}# - (cdr #{e 4129}#) - (cdr #{p 4130}#) - #{w 4131}# - #{r 4132}# - #{mod 4133}#) - #{mod 4133}#) + (let ((#{atom-key 4130}# (vector-ref #{p 4113}# 0))) + (if (memv #{atom-key 4130}# '(each)) + (#{match-empty 4033}# + (vector-ref #{p 4113}# 1) + #{r 4114}#) + (if (memv #{atom-key 4130}# '(each+)) + (#{match-empty 4033}# + (vector-ref #{p 4113}# 1) + (#{match-empty 4033}# + (reverse (vector-ref #{p 4113}# 2)) + (#{match-empty 4033}# + (vector-ref #{p 4113}# 3) + #{r 4114}#))) + (if (memv #{atom-key 4130}# '(free-id atom)) + #{r 4114}# + (if (memv #{atom-key 4130}# '(vector)) + (#{match-empty 4033}# + (vector-ref #{p 4113}# 1) + #{r 4114}#)))))))))))))) + (#{combine 4035}# + (lambda (#{r* 4135}# #{r 4136}#) + (if (null? (car #{r* 4135}#)) + #{r 4136}# + (cons (map car #{r* 4135}#) + (#{combine 4035}# + (map cdr #{r* 4135}#) + #{r 4136}#))))) + (#{match* 4037}# + (lambda (#{e 4139}# + #{p 4140}# + #{w 4141}# + #{r 4142}# + #{mod 4143}#) + (if (null? #{p 4140}#) + (if (null? #{e 4139}#) #{r 4142}# #f) + (if (pair? #{p 4140}#) + (if (pair? #{e 4139}#) + (#{match 4039}# + (car #{e 4139}#) + (car #{p 4140}#) + #{w 4141}# + (#{match 4039}# + (cdr #{e 4139}#) + (cdr #{p 4140}#) + #{w 4141}# + #{r 4142}# + #{mod 4143}#) + #{mod 4143}#) #f) - (if (eq? #{p 4130}# 'each-any) + (if (eq? #{p 4140}# 'each-any) (begin - (let ((#{l 4150}# - (#{match-each-any 4021}# - #{e 4129}# - #{w 4131}# - #{mod 4133}#))) - (if #{l 4150}# (cons #{l 4150}# #{r 4132}#) #f))) + (let ((#{l 4160}# + (#{match-each-any 4031}# + #{e 4139}# + #{w 4141}# + #{mod 4143}#))) + (if #{l 4160}# (cons #{l 4160}# #{r 4142}#) #f))) (begin - (let ((#{atom-key 4156}# (vector-ref #{p 4130}# 0))) - (if (eqv? #{atom-key 4156}# 'each) - (if (null? #{e 4129}#) - (#{match-empty 4023}# - (vector-ref #{p 4130}# 1) - #{r 4132}#) + (let ((#{atom-key 4166}# (vector-ref #{p 4140}# 0))) + (if (memv #{atom-key 4166}# '(each)) + (if (null? #{e 4139}#) + (#{match-empty 4033}# + (vector-ref #{p 4140}# 1) + #{r 4142}#) (begin - (let ((#{l 4159}# - (#{match-each 4017}# - #{e 4129}# - (vector-ref #{p 4130}# 1) - #{w 4131}# - #{mod 4133}#))) - (if #{l 4159}# + (let ((#{l 4169}# + (#{match-each 4027}# + #{e 4139}# + (vector-ref #{p 4140}# 1) + #{w 4141}# + #{mod 4143}#))) + (if #{l 4169}# (letrec* - ((#{collect 4164}# - (lambda (#{l 4165}#) - (if (null? (car #{l 4165}#)) - #{r 4132}# - (cons (map car #{l 4165}#) - (#{collect 4164}# - (map cdr #{l 4165}#))))))) - (begin (#{collect 4164}# #{l 4159}#))) + ((#{collect 4174}# + (lambda (#{l 4175}#) + (if (null? (car #{l 4175}#)) + #{r 4142}# + (cons (map car #{l 4175}#) + (#{collect 4174}# + (map cdr #{l 4175}#))))))) + (begin (#{collect 4174}# #{l 4169}#))) #f)))) - (if (eqv? #{atom-key 4156}# 'each+) + (if (memv #{atom-key 4166}# '(each+)) (call-with-values (lambda () - (#{match-each+ 4019}# - #{e 4129}# - (vector-ref #{p 4130}# 1) - (vector-ref #{p 4130}# 2) - (vector-ref #{p 4130}# 3) - #{w 4131}# - #{r 4132}# - #{mod 4133}#)) - (lambda (#{xr* 4167}# #{y-pat 4168}# #{r 4169}#) - (if #{r 4169}# - (if (null? #{y-pat 4168}#) - (if (null? #{xr* 4167}#) - (#{match-empty 4023}# - (vector-ref #{p 4130}# 1) - #{r 4169}#) - (#{combine 4025}# - #{xr* 4167}# - #{r 4169}#)) + (#{match-each+ 4029}# + #{e 4139}# + (vector-ref #{p 4140}# 1) + (vector-ref #{p 4140}# 2) + (vector-ref #{p 4140}# 3) + #{w 4141}# + #{r 4142}# + #{mod 4143}#)) + (lambda (#{xr* 4177}# #{y-pat 4178}# #{r 4179}#) + (if #{r 4179}# + (if (null? #{y-pat 4178}#) + (if (null? #{xr* 4177}#) + (#{match-empty 4033}# + (vector-ref #{p 4140}# 1) + #{r 4179}#) + (#{combine 4035}# + #{xr* 4177}# + #{r 4179}#)) #f) #f))) - (if (eqv? #{atom-key 4156}# 'free-id) - (if (#{id? 339}# #{e 4129}#) - (if (#{free-id=? 395}# - (#{wrap 405}# - #{e 4129}# - #{w 4131}# - #{mod 4133}#) - (vector-ref #{p 4130}# 1)) - #{r 4132}# + (if (memv #{atom-key 4166}# '(free-id)) + (if (#{id? 343}# #{e 4139}#) + (if (#{free-id=? 399}# + (#{wrap 409}# + #{e 4139}# + #{w 4141}# + #{mod 4143}#) + (vector-ref #{p 4140}# 1)) + #{r 4142}# #f) #f) - (if (eqv? #{atom-key 4156}# 'atom) + (if (memv #{atom-key 4166}# '(atom)) (if (equal? - (vector-ref #{p 4130}# 1) - (#{strip 445}# #{e 4129}# #{w 4131}#)) - #{r 4132}# + (vector-ref #{p 4140}# 1) + (#{strip 449}# #{e 4139}# #{w 4141}#)) + #{r 4142}# #f) - (if (eqv? #{atom-key 4156}# 'vector) - (if (vector? #{e 4129}#) - (#{match 4029}# - (vector->list #{e 4129}#) - (vector-ref #{p 4130}# 1) - #{w 4131}# - #{r 4132}# - #{mod 4133}#) + (if (memv #{atom-key 4166}# '(vector)) + (if (vector? #{e 4139}#) + (#{match 4039}# + (vector->list #{e 4139}#) + (vector-ref #{p 4140}# 1) + #{w 4141}# + #{r 4142}# + #{mod 4143}#) #f))))))))))))) - (#{match 4029}# - (lambda (#{e 4186}# - #{p 4187}# - #{w 4188}# - #{r 4189}# - #{mod 4190}#) - (if (not #{r 4189}#) + (#{match 4039}# + (lambda (#{e 4196}# + #{p 4197}# + #{w 4198}# + #{r 4199}# + #{mod 4200}#) + (if (not #{r 4199}#) #f - (if (eq? #{p 4187}# '_) - #{r 4189}# - (if (eq? #{p 4187}# 'any) - (cons (#{wrap 405}# #{e 4186}# #{w 4188}# #{mod 4190}#) - #{r 4189}#) - (if (#{syntax-object? 305}# #{e 4186}#) - (#{match* 4027}# - (#{syntax-object-expression 307}# #{e 4186}#) - #{p 4187}# - (#{join-wraps 387}# - #{w 4188}# - (#{syntax-object-wrap 309}# #{e 4186}#)) - #{r 4189}# - (#{syntax-object-module 311}# #{e 4186}#)) - (#{match* 4027}# - #{e 4186}# - #{p 4187}# - #{w 4188}# - #{r 4189}# - #{mod 4190}#)))))))) + (if (eq? #{p 4197}# '_) + #{r 4199}# + (if (eq? #{p 4197}# 'any) + (cons (#{wrap 409}# #{e 4196}# #{w 4198}# #{mod 4200}#) + #{r 4199}#) + (if (#{syntax-object? 309}# #{e 4196}#) + (#{match* 4037}# + (#{syntax-object-expression 311}# #{e 4196}#) + #{p 4197}# + (#{join-wraps 391}# + #{w 4198}# + (#{syntax-object-wrap 313}# #{e 4196}#)) + #{r 4199}# + (#{syntax-object-module 315}# #{e 4196}#)) + (#{match* 4037}# + #{e 4196}# + #{p 4197}# + #{w 4198}# + #{r 4199}# + #{mod 4200}#)))))))) (begin (set! $sc-dispatch - (lambda (#{e 4205}# #{p 4206}#) - (if (eq? #{p 4206}# 'any) - (list #{e 4205}#) - (if (eq? #{p 4206}# '_) + (lambda (#{e 4215}# #{p 4216}#) + (if (eq? #{p 4216}# 'any) + (list #{e 4215}#) + (if (eq? #{p 4216}# '_) '() - (if (#{syntax-object? 305}# #{e 4205}#) - (#{match* 4027}# - (#{syntax-object-expression 307}# #{e 4205}#) - #{p 4206}# - (#{syntax-object-wrap 309}# #{e 4205}#) + (if (#{syntax-object? 309}# #{e 4215}#) + (#{match* 4037}# + (#{syntax-object-expression 311}# #{e 4215}#) + #{p 4216}# + (#{syntax-object-wrap 313}# #{e 4215}#) '() - (#{syntax-object-module 311}# #{e 4205}#)) - (#{match* 4027}# - #{e 4205}# - #{p 4206}# + (#{syntax-object-module 315}# #{e 4215}#)) + (#{match* 4037}# + #{e 4215}# + #{p 4216}# '(()) '() #f))))))))))) @@ -14108,82 +14211,82 @@ (make-syntax-transformer 'with-syntax 'macro - (lambda (#{x 4217}#) - (let ((#{tmp 4219}# #{x 4217}#)) - (let ((#{tmp 4220}# + (lambda (#{x 4227}#) + (let ((#{tmp 4229}# #{x 4227}#)) + (let ((#{tmp 4230}# ($sc-dispatch - #{tmp 4219}# + #{tmp 4229}# '(_ () any . each-any)))) - (if #{tmp 4220}# + (if #{tmp 4230}# (@apply - (lambda (#{e1 4223}# #{e2 4224}#) + (lambda (#{e1 4233}# #{e2 4234}#) (cons '#(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i4221" "i4222")) + #("i4231" "i4232")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4218"))) + #(ribcage #(x) #((top)) #("i4228"))) (hygiene guile)) - (cons '() (cons #{e1 4223}# #{e2 4224}#)))) - #{tmp 4220}#) - (let ((#{tmp 4226}# + (cons '() (cons #{e1 4233}# #{e2 4234}#)))) + #{tmp 4230}#) + (let ((#{tmp 4236}# ($sc-dispatch - #{tmp 4219}# + #{tmp 4229}# '(_ ((any any)) any . each-any)))) - (if #{tmp 4226}# + (if #{tmp 4236}# (@apply - (lambda (#{out 4231}# - #{in 4232}# - #{e1 4233}# - #{e2 4234}#) + (lambda (#{out 4241}# + #{in 4242}# + #{e1 4243}# + #{e2 4244}#) (list '#(syntax-object syntax-case ((top) #(ribcage #(out in e1 e2) #((top) (top) (top) (top)) - #("i4227" "i4228" "i4229" "i4230")) + #("i4237" "i4238" "i4239" "i4240")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4218"))) + #(ribcage #(x) #((top)) #("i4228"))) (hygiene guile)) - #{in 4232}# + #{in 4242}# '() - (list #{out 4231}# + (list #{out 4241}# (cons '#(syntax-object let ((top) #(ribcage #(out in e1 e2) #((top) (top) (top) (top)) - #("i4227" "i4228" "i4229" "i4230")) + #("i4237" "i4238" "i4239" "i4240")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4218"))) + #(ribcage #(x) #((top)) #("i4228"))) (hygiene guile)) (cons '() - (cons #{e1 4233}# #{e2 4234}#)))))) - #{tmp 4226}#) - (let ((#{tmp 4236}# + (cons #{e1 4243}# #{e2 4244}#)))))) + #{tmp 4236}#) + (let ((#{tmp 4246}# ($sc-dispatch - #{tmp 4219}# + #{tmp 4229}# '(_ #(each (any any)) any . each-any)))) - (if #{tmp 4236}# + (if #{tmp 4246}# (@apply - (lambda (#{out 4241}# - #{in 4242}# - #{e1 4243}# - #{e2 4244}#) + (lambda (#{out 4251}# + #{in 4252}# + #{e1 4253}# + #{e2 4254}#) (list '#(syntax-object syntax-case ((top) #(ribcage #(out in e1 e2) #((top) (top) (top) (top)) - #("i4237" "i4238" "i4239" "i4240")) + #("i4247" "i4248" "i4249" "i4250")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4218"))) + #(ribcage #(x) #((top)) #("i4228"))) (hygiene guile)) (cons '#(syntax-object list @@ -14191,63 +14294,63 @@ #(ribcage #(out in e1 e2) #((top) (top) (top) (top)) - #("i4237" "i4238" "i4239" "i4240")) + #("i4247" "i4248" "i4249" "i4250")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4218"))) + #(ribcage #(x) #((top)) #("i4228"))) (hygiene guile)) - #{in 4242}#) + #{in 4252}#) '() - (list #{out 4241}# + (list #{out 4251}# (cons '#(syntax-object let ((top) #(ribcage #(out in e1 e2) #((top) (top) (top) (top)) - #("i4237" - "i4238" - "i4239" - "i4240")) + #("i4247" + "i4248" + "i4249" + "i4250")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4218"))) + #("i4228"))) (hygiene guile)) (cons '() - (cons #{e1 4243}# - #{e2 4244}#)))))) - #{tmp 4236}#) + (cons #{e1 4253}# + #{e2 4254}#)))))) + #{tmp 4246}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4219}#))))))))))) + #{tmp 4229}#))))))))))) (define syntax-rules (make-syntax-transformer 'syntax-rules 'macro - (lambda (#{x 4248}#) - (let ((#{tmp 4250}# #{x 4248}#)) - (let ((#{tmp 4251}# + (lambda (#{x 4258}#) + (let ((#{tmp 4260}# #{x 4258}#)) + (let ((#{tmp 4261}# ($sc-dispatch - #{tmp 4250}# + #{tmp 4260}# '(_ each-any . #(each ((any . any) any)))))) - (if #{tmp 4251}# + (if #{tmp 4261}# (@apply - (lambda (#{k 4256}# - #{keyword 4257}# - #{pattern 4258}# - #{template 4259}#) + (lambda (#{k 4266}# + #{keyword 4267}# + #{pattern 4268}# + #{template 4269}#) (list '#(syntax-object lambda ((top) #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i4252" "i4253" "i4254" "i4255")) + #("i4262" "i4263" "i4264" "i4265")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile)) '(#(syntax-object x @@ -14255,9 +14358,9 @@ #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i4252" "i4253" "i4254" "i4255")) + #("i4262" "i4263" "i4264" "i4265")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile))) (vector '(#(syntax-object @@ -14266,9 +14369,9 @@ #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i4252" "i4253" "i4254" "i4255")) + #("i4262" "i4263" "i4264" "i4265")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile)) . #(syntax-object @@ -14277,9 +14380,9 @@ #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i4252" "i4253" "i4254" "i4255")) + #("i4262" "i4263" "i4264" "i4265")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile))) (cons '#(syntax-object patterns @@ -14287,20 +14390,20 @@ #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i4252" "i4253" "i4254" "i4255")) + #("i4262" "i4263" "i4264" "i4265")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile)) - #{pattern 4258}#)) + #{pattern 4268}#)) (cons '#(syntax-object syntax-case ((top) #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i4252" "i4253" "i4254" "i4255")) + #("i4262" "i4263" "i4264" "i4265")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile)) (cons '#(syntax-object x @@ -14308,13 +14411,13 @@ #(ribcage #(k keyword pattern template) #((top) (top) (top) (top)) - #("i4252" "i4253" "i4254" "i4255")) + #("i4262" "i4263" "i4264" "i4265")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile)) - (cons #{k 4256}# - (map (lambda (#{tmp 4263}# - #{tmp 4262}#) + (cons #{k 4266}# + (map (lambda (#{tmp 4273}# + #{tmp 4272}#) (list (cons '#(syntax-object dummy ((top) @@ -14327,10 +14430,10 @@ (top) (top) (top)) - #("i4252" - "i4253" - "i4254" - "i4255")) + #("i4262" + "i4263" + "i4264" + "i4265")) #(ribcage () () @@ -14338,9 +14441,9 @@ #(ribcage #(x) #((top)) - #("i4249"))) + #("i4259"))) (hygiene guile)) - #{tmp 4262}#) + #{tmp 4272}#) (list '#(syntax-object syntax ((top) @@ -14353,10 +14456,10 @@ (top) (top) (top)) - #("i4252" - "i4253" - "i4254" - "i4255")) + #("i4262" + "i4263" + "i4264" + "i4265")) #(ribcage () () @@ -14364,41 +14467,41 @@ #(ribcage #(x) #((top)) - #("i4249"))) + #("i4259"))) (hygiene guile)) - #{tmp 4263}#))) - #{template 4259}# - #{pattern 4258}#)))))) - #{tmp 4251}#) - (let ((#{tmp 4264}# + #{tmp 4273}#))) + #{template 4269}# + #{pattern 4268}#)))))) + #{tmp 4261}#) + (let ((#{tmp 4274}# ($sc-dispatch - #{tmp 4250}# + #{tmp 4260}# '(_ each-any any . #(each ((any . any) any)))))) - (if (if #{tmp 4264}# + (if (if #{tmp 4274}# (@apply - (lambda (#{k 4270}# - #{docstring 4271}# - #{keyword 4272}# - #{pattern 4273}# - #{template 4274}#) - (string? (syntax->datum #{docstring 4271}#))) - #{tmp 4264}#) + (lambda (#{k 4280}# + #{docstring 4281}# + #{keyword 4282}# + #{pattern 4283}# + #{template 4284}#) + (string? (syntax->datum #{docstring 4281}#))) + #{tmp 4274}#) #f) (@apply - (lambda (#{k 4280}# - #{docstring 4281}# - #{keyword 4282}# - #{pattern 4283}# - #{template 4284}#) + (lambda (#{k 4290}# + #{docstring 4291}# + #{keyword 4292}# + #{pattern 4293}# + #{template 4294}#) (list '#(syntax-object lambda ((top) #(ribcage #(k docstring keyword pattern template) #((top) (top) (top) (top) (top)) - #("i4275" "i4276" "i4277" "i4278" "i4279")) + #("i4285" "i4286" "i4287" "i4288" "i4289")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile)) '(#(syntax-object x @@ -14406,11 +14509,11 @@ #(ribcage #(k docstring keyword pattern template) #((top) (top) (top) (top) (top)) - #("i4275" "i4276" "i4277" "i4278" "i4279")) + #("i4285" "i4286" "i4287" "i4288" "i4289")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile))) - #{docstring 4281}# + #{docstring 4291}# (vector '(#(syntax-object macro-type @@ -14418,9 +14521,9 @@ #(ribcage #(k docstring keyword pattern template) #((top) (top) (top) (top) (top)) - #("i4275" "i4276" "i4277" "i4278" "i4279")) + #("i4285" "i4286" "i4287" "i4288" "i4289")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile)) . #(syntax-object @@ -14429,9 +14532,9 @@ #(ribcage #(k docstring keyword pattern template) #((top) (top) (top) (top) (top)) - #("i4275" "i4276" "i4277" "i4278" "i4279")) + #("i4285" "i4286" "i4287" "i4288" "i4289")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile))) (cons '#(syntax-object patterns @@ -14439,28 +14542,28 @@ #(ribcage #(k docstring keyword pattern template) #((top) (top) (top) (top) (top)) - #("i4275" - "i4276" - "i4277" - "i4278" - "i4279")) + #("i4285" + "i4286" + "i4287" + "i4288" + "i4289")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile)) - #{pattern 4283}#)) + #{pattern 4293}#)) (cons '#(syntax-object syntax-case ((top) #(ribcage #(k docstring keyword pattern template) #((top) (top) (top) (top) (top)) - #("i4275" - "i4276" - "i4277" - "i4278" - "i4279")) + #("i4285" + "i4286" + "i4287" + "i4288" + "i4289")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile)) (cons '#(syntax-object x @@ -14472,17 +14575,17 @@ pattern template) #((top) (top) (top) (top) (top)) - #("i4275" - "i4276" - "i4277" - "i4278" - "i4279")) + #("i4285" + "i4286" + "i4287" + "i4288" + "i4289")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4249"))) + #(ribcage #(x) #((top)) #("i4259"))) (hygiene guile)) - (cons #{k 4280}# - (map (lambda (#{tmp 4288}# - #{tmp 4287}#) + (cons #{k 4290}# + (map (lambda (#{tmp 4298}# + #{tmp 4297}#) (list (cons '#(syntax-object dummy ((top) @@ -14497,11 +14600,11 @@ (top) (top) (top)) - #("i4275" - "i4276" - "i4277" - "i4278" - "i4279")) + #("i4285" + "i4286" + "i4287" + "i4288" + "i4289")) #(ribcage () () @@ -14509,10 +14612,10 @@ #(ribcage #(x) #((top)) - #("i4249"))) + #("i4259"))) (hygiene guile)) - #{tmp 4287}#) + #{tmp 4297}#) (list '#(syntax-object syntax ((top) @@ -14527,11 +14630,11 @@ (top) (top) (top)) - #("i4275" - "i4276" - "i4277" - "i4278" - "i4279")) + #("i4285" + "i4286" + "i4287" + "i4288" + "i4289")) #(ribcage () () @@ -14539,48 +14642,48 @@ #(ribcage #(x) #((top)) - #("i4249"))) + #("i4259"))) (hygiene guile)) - #{tmp 4288}#))) - #{template 4284}# - #{pattern 4283}#)))))) - #{tmp 4264}#) + #{tmp 4298}#))) + #{template 4294}# + #{pattern 4293}#)))))) + #{tmp 4274}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4250}#))))))))) + #{tmp 4260}#))))))))) (define let* (make-syntax-transformer 'let* 'macro - (lambda (#{x 4289}#) - (let ((#{tmp 4291}# #{x 4289}#)) - (let ((#{tmp 4292}# + (lambda (#{x 4299}#) + (let ((#{tmp 4301}# #{x 4299}#)) + (let ((#{tmp 4302}# ($sc-dispatch - #{tmp 4291}# + #{tmp 4301}# '(any #(each (any any)) any . each-any)))) - (if (if #{tmp 4292}# + (if (if #{tmp 4302}# (@apply - (lambda (#{let* 4298}# - #{x 4299}# - #{v 4300}# - #{e1 4301}# - #{e2 4302}#) - (and-map identifier? #{x 4299}#)) - #{tmp 4292}#) + (lambda (#{let* 4308}# + #{x 4309}# + #{v 4310}# + #{e1 4311}# + #{e2 4312}#) + (and-map identifier? #{x 4309}#)) + #{tmp 4302}#) #f) (@apply - (lambda (#{let* 4309}# - #{x 4310}# - #{v 4311}# - #{e1 4312}# - #{e2 4313}#) + (lambda (#{let* 4319}# + #{x 4320}# + #{v 4321}# + #{e1 4322}# + #{e2 4323}#) (letrec* - ((#{f 4316}# - (lambda (#{bindings 4317}#) - (if (null? #{bindings 4317}#) + ((#{f 4326}# + (lambda (#{bindings 4327}#) + (if (null? #{bindings 4327}#) (cons '#(syntax-object let ((top) @@ -14588,27 +14691,27 @@ #(ribcage #(f bindings) #((top) (top)) - #("i4314" "i4315")) + #("i4324" "i4325")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) - #("i4304" - "i4305" - "i4306" - "i4307" - "i4308")) + #("i4314" + "i4315" + "i4316" + "i4317" + "i4318")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4290"))) + #(ribcage #(x) #((top)) #("i4300"))) (hygiene guile)) - (cons '() (cons #{e1 4312}# #{e2 4313}#))) - (let ((#{tmp 4322}# - (list (#{f 4316}# (cdr #{bindings 4317}#)) - (car #{bindings 4317}#)))) - (let ((#{tmp 4323}# - ($sc-dispatch #{tmp 4322}# '(any any)))) - (if #{tmp 4323}# + (cons '() (cons #{e1 4322}# #{e2 4323}#))) + (let ((#{tmp 4332}# + (list (#{f 4326}# (cdr #{bindings 4327}#)) + (car #{bindings 4327}#)))) + (let ((#{tmp 4333}# + ($sc-dispatch #{tmp 4332}# '(any any)))) + (if #{tmp 4333}# (@apply - (lambda (#{body 4326}# #{binding 4327}#) + (lambda (#{body 4336}# #{binding 4337}#) (list '#(syntax-object let ((top) @@ -14616,96 +14719,96 @@ #(ribcage #(body binding) #((top) (top)) - #("i4324" "i4325")) + #("i4334" "i4335")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) - #("i4314" "i4315")) + #("i4324" "i4325")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) - #("i4304" - "i4305" - "i4306" - "i4307" - "i4308")) + #("i4314" + "i4315" + "i4316" + "i4317" + "i4318")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4290"))) + #("i4300"))) (hygiene guile)) - (list #{binding 4327}#) - #{body 4326}#)) - #{tmp 4323}#) + (list #{binding 4337}#) + #{body 4336}#)) + #{tmp 4333}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4322}#)))))))) + #{tmp 4332}#)))))))) (begin - (#{f 4316}# (map list #{x 4310}# #{v 4311}#))))) - #{tmp 4292}#) + (#{f 4326}# (map list #{x 4320}# #{v 4321}#))))) + #{tmp 4302}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4291}#))))))) + #{tmp 4301}#))))))) (define do (make-syntax-transformer 'do 'macro - (lambda (#{orig-x 4328}#) - (let ((#{tmp 4330}# #{orig-x 4328}#)) - (let ((#{tmp 4331}# + (lambda (#{orig-x 4338}#) + (let ((#{tmp 4340}# #{orig-x 4338}#)) + (let ((#{tmp 4341}# ($sc-dispatch - #{tmp 4330}# + #{tmp 4340}# '(_ #(each (any any . any)) (any . each-any) . each-any)))) - (if #{tmp 4331}# + (if #{tmp 4341}# (@apply - (lambda (#{var 4338}# - #{init 4339}# - #{step 4340}# - #{e0 4341}# - #{e1 4342}# - #{c 4343}#) - (let ((#{tmp 4345}# - (map (lambda (#{v 4366}# #{s 4367}#) - (let ((#{tmp 4370}# #{s 4367}#)) - (let ((#{tmp 4371}# - ($sc-dispatch #{tmp 4370}# '()))) - (if #{tmp 4371}# + (lambda (#{var 4348}# + #{init 4349}# + #{step 4350}# + #{e0 4351}# + #{e1 4352}# + #{c 4353}#) + (let ((#{tmp 4355}# + (map (lambda (#{v 4376}# #{s 4377}#) + (let ((#{tmp 4380}# #{s 4377}#)) + (let ((#{tmp 4381}# + ($sc-dispatch #{tmp 4380}# '()))) + (if #{tmp 4381}# (@apply - (lambda () #{v 4366}#) - #{tmp 4371}#) - (let ((#{tmp 4372}# + (lambda () #{v 4376}#) + #{tmp 4381}#) + (let ((#{tmp 4382}# ($sc-dispatch - #{tmp 4370}# + #{tmp 4380}# '(any)))) - (if #{tmp 4372}# + (if #{tmp 4382}# (@apply - (lambda (#{e 4374}#) #{e 4374}#) - #{tmp 4372}#) - (let ((#{_ 4376}# #{tmp 4370}#)) + (lambda (#{e 4384}#) #{e 4384}#) + #{tmp 4382}#) + (let ((#{_ 4386}# #{tmp 4380}#)) (syntax-violation 'do "bad step expression" - #{orig-x 4328}# - #{s 4367}#)))))))) - #{var 4338}# - #{step 4340}#))) - (let ((#{tmp 4346}# - ($sc-dispatch #{tmp 4345}# 'each-any))) - (if #{tmp 4346}# + #{orig-x 4338}# + #{s 4377}#)))))))) + #{var 4348}# + #{step 4350}#))) + (let ((#{tmp 4356}# + ($sc-dispatch #{tmp 4355}# 'each-any))) + (if #{tmp 4356}# (@apply - (lambda (#{step 4348}#) - (let ((#{tmp 4349}# #{e1 4342}#)) - (let ((#{tmp 4350}# - ($sc-dispatch #{tmp 4349}# '()))) - (if #{tmp 4350}# + (lambda (#{step 4358}#) + (let ((#{tmp 4359}# #{e1 4352}#)) + (let ((#{tmp 4360}# + ($sc-dispatch #{tmp 4359}# '()))) + (if #{tmp 4360}# (@apply (lambda () (list '#(syntax-object @@ -14715,7 +14818,7 @@ #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init step e0 e1 c) #((top) @@ -14724,17 +14827,17 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) '#(syntax-object doloop @@ -14743,7 +14846,7 @@ #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init step e0 e1 c) #((top) @@ -14752,19 +14855,19 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) - (map list #{var 4338}# #{init 4339}#) + (map list #{var 4348}# #{init 4349}#) (list '#(syntax-object if ((top) @@ -14772,7 +14875,7 @@ #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init step e0 e1 c) #((top) @@ -14781,17 +14884,17 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) (list '#(syntax-object not @@ -14800,7 +14903,7 @@ #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init @@ -14814,19 +14917,19 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) - #{e0 4341}#) + #{e0 4351}#) (cons '#(syntax-object begin ((top) @@ -14834,7 +14937,7 @@ #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init @@ -14848,20 +14951,20 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) (append - #{c 4343}# + #{c 4353}# (list (cons '#(syntax-object doloop ((top) @@ -14872,7 +14975,7 @@ #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init @@ -14886,12 +14989,12 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () @@ -14899,30 +15002,30 @@ #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) - #{step 4348}#))))))) - #{tmp 4350}#) - (let ((#{tmp 4355}# + #{step 4358}#))))))) + #{tmp 4360}#) + (let ((#{tmp 4365}# ($sc-dispatch - #{tmp 4349}# + #{tmp 4359}# '(any . each-any)))) - (if #{tmp 4355}# + (if #{tmp 4365}# (@apply - (lambda (#{e1 4358}# #{e2 4359}#) + (lambda (#{e1 4368}# #{e2 4369}#) (list '#(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i4356" "i4357")) + #("i4366" "i4367")) #(ribcage () () ()) #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init step e0 e1 c) #((top) @@ -14931,17 +15034,17 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) '#(syntax-object doloop @@ -14949,12 +15052,12 @@ #(ribcage #(e1 e2) #((top) (top)) - #("i4356" "i4357")) + #("i4366" "i4367")) #(ribcage () () ()) #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init step e0 e1 c) #((top) @@ -14963,33 +15066,33 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) (map list - #{var 4338}# - #{init 4339}#) + #{var 4348}# + #{init 4349}#) (list '#(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i4356" "i4357")) + #("i4366" "i4367")) #(ribcage () () ()) #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init @@ -15003,27 +15106,27 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) - #{e0 4341}# + #{e0 4351}# (cons '#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i4356" - "i4357")) + #("i4366" + "i4367")) #(ribcage () () @@ -15031,7 +15134,7 @@ #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init @@ -15045,12 +15148,12 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () @@ -15058,18 +15161,18 @@ #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) - (cons #{e1 4358}# - #{e2 4359}#)) + (cons #{e1 4368}# + #{e2 4369}#)) (cons '#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i4356" - "i4357")) + #("i4366" + "i4367")) #(ribcage () () @@ -15077,7 +15180,7 @@ #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init @@ -15091,12 +15194,12 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () @@ -15104,10 +15207,10 @@ #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) (append - #{c 4343}# + #{c 4353}# (list (cons '#(syntax-object doloop ((top) @@ -15116,8 +15219,8 @@ e2) #((top) (top)) - #("i4356" - "i4357")) + #("i4366" + "i4367")) #(ribcage () () @@ -15125,7 +15228,7 @@ #(ribcage #(step) #((top)) - #("i4347")) + #("i4357")) #(ribcage #(var init @@ -15139,12 +15242,12 @@ (top) (top) (top)) - #("i4332" - "i4333" - "i4334" - "i4335" - "i4336" - "i4337")) + #("i4342" + "i4343" + "i4344" + "i4345" + "i4346" + "i4347")) #(ribcage () () @@ -15152,37 +15255,37 @@ #(ribcage #(orig-x) #((top)) - #("i4329"))) + #("i4339"))) (hygiene guile)) - #{step 4348}#))))))) - #{tmp 4355}#) + #{step 4358}#))))))) + #{tmp 4365}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4349}#))))))) - #{tmp 4346}#) + #{tmp 4359}#))))))) + #{tmp 4356}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4345}#))))) - #{tmp 4331}#) + #{tmp 4355}#))))) + #{tmp 4341}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4330}#))))))) + #{tmp 4340}#))))))) (define quasiquote (make-syntax-transformer 'quasiquote 'macro (letrec* - ((#{quasi 4380}# - (lambda (#{p 4393}# #{lev 4394}#) - (let ((#{tmp 4397}# #{p 4393}#)) - (let ((#{tmp 4398}# + ((#{quasi 4390}# + (lambda (#{p 4403}# #{lev 4404}#) + (let ((#{tmp 4407}# #{p 4403}#)) + (let ((#{tmp 4408}# ($sc-dispatch - #{tmp 4397}# + #{tmp 4407}# '(#(free-id #(syntax-object unquote @@ -15191,7 +15294,7 @@ #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15200,28 +15303,28 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) any)))) - (if #{tmp 4398}# + (if #{tmp 4408}# (@apply - (lambda (#{p 4400}#) - (if (= #{lev 4394}# 0) + (lambda (#{p 4410}#) + (if (= #{lev 4404}# 0) (list '#(syntax-object "value" ((top) - #(ribcage #(p) #((top)) #("i4399")) + #(ribcage #(p) #((top)) #("i4409")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15230,25 +15333,25 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{p 4400}#) - (#{quasicons 4384}# + #{p 4410}#) + (#{quasicons 4394}# '(#(syntax-object "quote" ((top) - #(ribcage #(p) #((top)) #("i4399")) + #(ribcage #(p) #((top)) #("i4409")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15257,23 +15360,23 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) #(syntax-object unquote ((top) - #(ribcage #(p) #((top)) #("i4399")) + #(ribcage #(p) #((top)) #("i4409")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15282,21 +15385,21 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) - (#{quasi 4380}# - (list #{p 4400}#) - (#{1-}# #{lev 4394}#))))) - #{tmp 4398}#) - (let ((#{tmp 4401}# + (#{quasi 4390}# + (list #{p 4410}#) + (#{1-}# #{lev 4404}#))))) + #{tmp 4408}#) + (let ((#{tmp 4411}# ($sc-dispatch - #{tmp 4397}# + #{tmp 4407}# '(#(free-id #(syntax-object quasiquote @@ -15305,7 +15408,7 @@ #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15314,28 +15417,28 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) any)))) - (if #{tmp 4401}# + (if #{tmp 4411}# (@apply - (lambda (#{p 4403}#) - (#{quasicons 4384}# + (lambda (#{p 4413}#) + (#{quasicons 4394}# '(#(syntax-object "quote" ((top) - #(ribcage #(p) #((top)) #("i4402")) + #(ribcage #(p) #((top)) #("i4412")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15344,23 +15447,23 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) #(syntax-object quasiquote ((top) - #(ribcage #(p) #((top)) #("i4402")) + #(ribcage #(p) #((top)) #("i4412")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15369,27 +15472,27 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) - (#{quasi 4380}# - (list #{p 4403}#) - (#{1+}# #{lev 4394}#)))) - #{tmp 4401}#) - (let ((#{tmp 4404}# - ($sc-dispatch #{tmp 4397}# '(any . any)))) - (if #{tmp 4404}# + (#{quasi 4390}# + (list #{p 4413}#) + (#{1+}# #{lev 4404}#)))) + #{tmp 4411}#) + (let ((#{tmp 4414}# + ($sc-dispatch #{tmp 4407}# '(any . any)))) + (if #{tmp 4414}# (@apply - (lambda (#{p 4407}# #{q 4408}#) - (let ((#{tmp 4409}# #{p 4407}#)) - (let ((#{tmp 4410}# + (lambda (#{p 4417}# #{q 4418}#) + (let ((#{tmp 4419}# #{p 4417}#)) + (let ((#{tmp 4420}# ($sc-dispatch - #{tmp 4409}# + #{tmp 4419}# '(#(free-id #(syntax-object unquote @@ -15397,12 +15500,12 @@ #(ribcage #(p q) #((top) (top)) - #("i4405" "i4406")) + #("i4415" "i4416")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15417,40 +15520,40 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) . each-any)))) - (if #{tmp 4410}# + (if #{tmp 4420}# (@apply - (lambda (#{p 4412}#) - (if (= #{lev 4394}# 0) - (#{quasilist* 4388}# - (map (lambda (#{tmp 4413}#) + (lambda (#{p 4422}#) + (if (= #{lev 4404}# 0) + (#{quasilist* 4398}# + (map (lambda (#{tmp 4423}#) (list '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) - #("i4411")) + #("i4421")) #(ribcage #(p q) #((top) (top)) - #("i4405" - "i4406")) + #("i4415" + "i4416")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" - "i4396")) + #("i4405" + "i4406")) #(ribcage (emit quasivector quasilist* @@ -15465,37 +15568,37 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{tmp 4413}#)) - #{p 4412}#) - (#{quasi 4380}# - #{q 4408}# - #{lev 4394}#)) - (#{quasicons 4384}# - (#{quasicons 4384}# + #{tmp 4423}#)) + #{p 4422}#) + (#{quasi 4390}# + #{q 4418}# + #{lev 4404}#)) + (#{quasicons 4394}# + (#{quasicons 4394}# '(#(syntax-object "quote" ((top) #(ribcage #(p) #((top)) - #("i4411")) + #("i4421")) #(ribcage #(p q) #((top) (top)) - #("i4405" "i4406")) + #("i4415" "i4416")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15510,13 +15613,13 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) #(syntax-object unquote @@ -15524,16 +15627,16 @@ #(ribcage #(p) #((top)) - #("i4411")) + #("i4421")) #(ribcage #(p q) #((top) (top)) - #("i4405" "i4406")) + #("i4415" "i4416")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15548,24 +15651,24 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) - (#{quasi 4380}# - #{p 4412}# - (#{1-}# #{lev 4394}#))) - (#{quasi 4380}# - #{q 4408}# - #{lev 4394}#)))) - #{tmp 4410}#) - (let ((#{tmp 4415}# + (#{quasi 4390}# + #{p 4422}# + (#{1-}# #{lev 4404}#))) + (#{quasi 4390}# + #{q 4418}# + #{lev 4404}#)))) + #{tmp 4420}#) + (let ((#{tmp 4425}# ($sc-dispatch - #{tmp 4409}# + #{tmp 4419}# '(#(free-id #(syntax-object unquote-splicing @@ -15573,12 +15676,12 @@ #(ribcage #(p q) #((top) (top)) - #("i4405" "i4406")) + #("i4415" "i4416")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15593,35 +15696,35 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) . each-any)))) - (if #{tmp 4415}# + (if #{tmp 4425}# (@apply - (lambda (#{p 4417}#) - (if (= #{lev 4394}# 0) - (#{quasiappend 4386}# - (map (lambda (#{tmp 4418}#) + (lambda (#{p 4427}#) + (if (= #{lev 4404}# 0) + (#{quasiappend 4396}# + (map (lambda (#{tmp 4428}#) (list '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) - #("i4416")) + #("i4426")) #(ribcage #(p q) #((top) (top)) - #("i4405" - "i4406")) + #("i4415" + "i4416")) #(ribcage () () @@ -15630,8 +15733,8 @@ #(p lev) #((top) (top)) - #("i4395" - "i4396")) + #("i4405" + "i4406")) #(ribcage (emit quasivector quasilist* @@ -15646,37 +15749,37 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{tmp 4418}#)) - #{p 4417}#) - (#{quasi 4380}# - #{q 4408}# - #{lev 4394}#)) - (#{quasicons 4384}# - (#{quasicons 4384}# + #{tmp 4428}#)) + #{p 4427}#) + (#{quasi 4390}# + #{q 4418}# + #{lev 4404}#)) + (#{quasicons 4394}# + (#{quasicons 4394}# '(#(syntax-object "quote" ((top) #(ribcage #(p) #((top)) - #("i4416")) + #("i4426")) #(ribcage #(p q) #((top) (top)) - #("i4405" "i4406")) + #("i4415" "i4416")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15691,13 +15794,13 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) #(syntax-object unquote-splicing @@ -15705,16 +15808,16 @@ #(ribcage #(p) #((top)) - #("i4416")) + #("i4426")) #(ribcage #(p q) #((top) (top)) - #("i4405" "i4406")) + #("i4415" "i4416")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15729,50 +15832,50 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) - (#{quasi 4380}# - #{p 4417}# - (#{1-}# #{lev 4394}#))) - (#{quasi 4380}# - #{q 4408}# - #{lev 4394}#)))) - #{tmp 4415}#) - (let ((#{_ 4421}# #{tmp 4409}#)) - (#{quasicons 4384}# - (#{quasi 4380}# - #{p 4407}# - #{lev 4394}#) - (#{quasi 4380}# - #{q 4408}# - #{lev 4394}#))))))))) - #{tmp 4404}#) - (let ((#{tmp 4422}# + (#{quasi 4390}# + #{p 4427}# + (#{1-}# #{lev 4404}#))) + (#{quasi 4390}# + #{q 4418}# + #{lev 4404}#)))) + #{tmp 4425}#) + (let ((#{_ 4431}# #{tmp 4419}#)) + (#{quasicons 4394}# + (#{quasi 4390}# + #{p 4417}# + #{lev 4404}#) + (#{quasi 4390}# + #{q 4418}# + #{lev 4404}#))))))))) + #{tmp 4414}#) + (let ((#{tmp 4432}# ($sc-dispatch - #{tmp 4397}# + #{tmp 4407}# '#(vector each-any)))) - (if #{tmp 4422}# + (if #{tmp 4432}# (@apply - (lambda (#{x 4424}#) - (#{quasivector 4390}# - (#{vquasi 4382}# #{x 4424}# #{lev 4394}#))) - #{tmp 4422}#) - (let ((#{p 4427}# #{tmp 4397}#)) + (lambda (#{x 4434}#) + (#{quasivector 4400}# + (#{vquasi 4392}# #{x 4434}# #{lev 4404}#))) + #{tmp 4432}#) + (let ((#{p 4437}# #{tmp 4407}#)) (list '#(syntax-object "quote" ((top) - #(ribcage #(p) #((top)) #("i4426")) + #(ribcage #(p) #((top)) #("i4436")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4395" "i4396")) + #("i4405" "i4406")) #(ribcage (emit quasivector quasilist* @@ -15787,27 +15890,27 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{p 4427}#))))))))))))) - (#{vquasi 4382}# - (lambda (#{p 4428}# #{lev 4429}#) - (let ((#{tmp 4432}# #{p 4428}#)) - (let ((#{tmp 4433}# - ($sc-dispatch #{tmp 4432}# '(any . any)))) - (if #{tmp 4433}# + #{p 4437}#))))))))))))) + (#{vquasi 4392}# + (lambda (#{p 4438}# #{lev 4439}#) + (let ((#{tmp 4442}# #{p 4438}#)) + (let ((#{tmp 4443}# + ($sc-dispatch #{tmp 4442}# '(any . any)))) + (if #{tmp 4443}# (@apply - (lambda (#{p 4436}# #{q 4437}#) - (let ((#{tmp 4438}# #{p 4436}#)) - (let ((#{tmp 4439}# + (lambda (#{p 4446}# #{q 4447}#) + (let ((#{tmp 4448}# #{p 4446}#)) + (let ((#{tmp 4449}# ($sc-dispatch - #{tmp 4438}# + #{tmp 4448}# '(#(free-id #(syntax-object unquote @@ -15815,12 +15918,12 @@ #(ribcage #(p q) #((top) (top)) - #("i4434" "i4435")) + #("i4444" "i4445")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4430" "i4431")) + #("i4440" "i4441")) #(ribcage (emit quasivector quasilist* @@ -15835,38 +15938,38 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) . each-any)))) - (if #{tmp 4439}# + (if #{tmp 4449}# (@apply - (lambda (#{p 4441}#) - (if (= #{lev 4429}# 0) - (#{quasilist* 4388}# - (map (lambda (#{tmp 4442}#) + (lambda (#{p 4451}#) + (if (= #{lev 4439}# 0) + (#{quasilist* 4398}# + (map (lambda (#{tmp 4452}#) (list '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) - #("i4440")) + #("i4450")) #(ribcage #(p q) #((top) (top)) - #("i4434" "i4435")) + #("i4444" "i4445")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4430" "i4431")) + #("i4440" "i4441")) #(ribcage (emit quasivector quasilist* @@ -15881,32 +15984,32 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{tmp 4442}#)) - #{p 4441}#) - (#{vquasi 4382}# #{q 4437}# #{lev 4429}#)) - (#{quasicons 4384}# - (#{quasicons 4384}# + #{tmp 4452}#)) + #{p 4451}#) + (#{vquasi 4392}# #{q 4447}# #{lev 4439}#)) + (#{quasicons 4394}# + (#{quasicons 4394}# '(#(syntax-object "quote" ((top) - #(ribcage #(p) #((top)) #("i4440")) + #(ribcage #(p) #((top)) #("i4450")) #(ribcage #(p q) #((top) (top)) - #("i4434" "i4435")) + #("i4444" "i4445")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4430" "i4431")) + #("i4440" "i4441")) #(ribcage (emit quasivector quasilist* @@ -15921,27 +16024,27 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) #(syntax-object unquote ((top) - #(ribcage #(p) #((top)) #("i4440")) + #(ribcage #(p) #((top)) #("i4450")) #(ribcage #(p q) #((top) (top)) - #("i4434" "i4435")) + #("i4444" "i4445")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4430" "i4431")) + #("i4440" "i4441")) #(ribcage (emit quasivector quasilist* @@ -15956,22 +16059,22 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) - (#{quasi 4380}# - #{p 4441}# - (#{1-}# #{lev 4429}#))) - (#{vquasi 4382}# #{q 4437}# #{lev 4429}#)))) - #{tmp 4439}#) - (let ((#{tmp 4444}# + (#{quasi 4390}# + #{p 4451}# + (#{1-}# #{lev 4439}#))) + (#{vquasi 4392}# #{q 4447}# #{lev 4439}#)))) + #{tmp 4449}#) + (let ((#{tmp 4454}# ($sc-dispatch - #{tmp 4438}# + #{tmp 4448}# '(#(free-id #(syntax-object unquote-splicing @@ -15979,12 +16082,12 @@ #(ribcage #(p q) #((top) (top)) - #("i4434" "i4435")) + #("i4444" "i4445")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4430" "i4431")) + #("i4440" "i4441")) #(ribcage (emit quasivector quasilist* @@ -15999,38 +16102,38 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) . each-any)))) - (if #{tmp 4444}# + (if #{tmp 4454}# (@apply - (lambda (#{p 4446}#) - (if (= #{lev 4429}# 0) - (#{quasiappend 4386}# - (map (lambda (#{tmp 4447}#) + (lambda (#{p 4456}#) + (if (= #{lev 4439}# 0) + (#{quasiappend 4396}# + (map (lambda (#{tmp 4457}#) (list '#(syntax-object "value" ((top) #(ribcage #(p) #((top)) - #("i4445")) + #("i4455")) #(ribcage #(p q) #((top) (top)) - #("i4434" "i4435")) + #("i4444" "i4445")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4430" "i4431")) + #("i4440" "i4441")) #(ribcage (emit quasivector quasilist* @@ -16045,37 +16148,37 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{tmp 4447}#)) - #{p 4446}#) - (#{vquasi 4382}# - #{q 4437}# - #{lev 4429}#)) - (#{quasicons 4384}# - (#{quasicons 4384}# + #{tmp 4457}#)) + #{p 4456}#) + (#{vquasi 4392}# + #{q 4447}# + #{lev 4439}#)) + (#{quasicons 4394}# + (#{quasicons 4394}# '(#(syntax-object "quote" ((top) #(ribcage #(p) #((top)) - #("i4445")) + #("i4455")) #(ribcage #(p q) #((top) (top)) - #("i4434" "i4435")) + #("i4444" "i4445")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4430" "i4431")) + #("i4440" "i4441")) #(ribcage (emit quasivector quasilist* @@ -16090,13 +16193,13 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) #(syntax-object unquote-splicing @@ -16104,16 +16207,16 @@ #(ribcage #(p) #((top)) - #("i4445")) + #("i4455")) #(ribcage #(p q) #((top) (top)) - #("i4434" "i4435")) + #("i4444" "i4445")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) - #("i4430" "i4431")) + #("i4440" "i4441")) #(ribcage (emit quasivector quasilist* @@ -16128,30 +16231,30 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile))) - (#{quasi 4380}# - #{p 4446}# - (#{1-}# #{lev 4429}#))) - (#{vquasi 4382}# - #{q 4437}# - #{lev 4429}#)))) - #{tmp 4444}#) - (let ((#{_ 4450}# #{tmp 4438}#)) - (#{quasicons 4384}# - (#{quasi 4380}# #{p 4436}# #{lev 4429}#) - (#{vquasi 4382}# - #{q 4437}# - #{lev 4429}#))))))))) - #{tmp 4433}#) - (let ((#{tmp 4451}# ($sc-dispatch #{tmp 4432}# '()))) - (if #{tmp 4451}# + (#{quasi 4390}# + #{p 4456}# + (#{1-}# #{lev 4439}#))) + (#{vquasi 4392}# + #{q 4447}# + #{lev 4439}#)))) + #{tmp 4454}#) + (let ((#{_ 4460}# #{tmp 4448}#)) + (#{quasicons 4394}# + (#{quasi 4390}# #{p 4446}# #{lev 4439}#) + (#{vquasi 4392}# + #{q 4447}# + #{lev 4439}#))))))))) + #{tmp 4443}#) + (let ((#{tmp 4461}# ($sc-dispatch #{tmp 4442}# '()))) + (if #{tmp 4461}# (@apply (lambda () '(#(syntax-object @@ -16161,7 +16264,7 @@ #(ribcage #(p lev) #((top) (top)) - #("i4430" "i4431")) + #("i4440" "i4441")) #(ribcage (emit quasivector quasilist* @@ -16170,66 +16273,66 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) ())) - #{tmp 4451}#) + #{tmp 4461}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4432}#)))))))) - (#{quasicons 4384}# - (lambda (#{x 4452}# #{y 4453}#) - (let ((#{tmp 4457}# (list #{x 4452}# #{y 4453}#))) - (let ((#{tmp 4458}# - ($sc-dispatch #{tmp 4457}# '(any any)))) - (if #{tmp 4458}# + #{tmp 4442}#)))))))) + (#{quasicons 4394}# + (lambda (#{x 4462}# #{y 4463}#) + (let ((#{tmp 4467}# (list #{x 4462}# #{y 4463}#))) + (let ((#{tmp 4468}# + ($sc-dispatch #{tmp 4467}# '(any any)))) + (if #{tmp 4468}# (@apply - (lambda (#{x 4461}# #{y 4462}#) - (let ((#{tmp 4463}# #{y 4462}#)) - (let ((#{tmp 4464}# + (lambda (#{x 4471}# #{y 4472}#) + (let ((#{tmp 4473}# #{y 4472}#)) + (let ((#{tmp 4474}# ($sc-dispatch - #{tmp 4463}# + #{tmp 4473}# '(#(atom "quote") any)))) - (if #{tmp 4464}# + (if #{tmp 4474}# (@apply - (lambda (#{dy 4466}#) - (let ((#{tmp 4467}# #{x 4461}#)) - (let ((#{tmp 4468}# + (lambda (#{dy 4476}#) + (let ((#{tmp 4477}# #{x 4471}#)) + (let ((#{tmp 4478}# ($sc-dispatch - #{tmp 4467}# + #{tmp 4477}# '(#(atom "quote") any)))) - (if #{tmp 4468}# + (if #{tmp 4478}# (@apply - (lambda (#{dx 4470}#) + (lambda (#{dx 4480}#) (list '#(syntax-object "quote" ((top) #(ribcage #(dx) #((top)) - #("i4469")) + #("i4479")) #(ribcage #(dy) #((top)) - #("i4465")) + #("i4475")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4459" "i4460")) + #("i4469" "i4470")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4454" "i4455")) + #("i4464" "i4465")) #(ribcage (emit quasivector quasilist* @@ -16244,40 +16347,40 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - (cons #{dx 4470}# #{dy 4466}#))) - #{tmp 4468}#) - (let ((#{_ 4472}# #{tmp 4467}#)) - (if (null? #{dy 4466}#) + (cons #{dx 4480}# #{dy 4476}#))) + #{tmp 4478}#) + (let ((#{_ 4482}# #{tmp 4477}#)) + (if (null? #{dy 4476}#) (list '#(syntax-object "list" ((top) #(ribcage #(_) #((top)) - #("i4471")) + #("i4481")) #(ribcage #(dy) #((top)) - #("i4465")) + #("i4475")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4459" "i4460")) + #("i4469" "i4470")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4454" "i4455")) + #("i4464" "i4465")) #(ribcage (emit quasivector quasilist* @@ -16292,37 +16395,37 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{x 4461}#) + #{x 4471}#) (list '#(syntax-object "list*" ((top) #(ribcage #(_) #((top)) - #("i4471")) + #("i4481")) #(ribcage #(dy) #((top)) - #("i4465")) + #("i4475")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4459" "i4460")) + #("i4469" "i4470")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4454" "i4455")) + #("i4464" "i4465")) #(ribcage (emit quasivector quasilist* @@ -16337,42 +16440,42 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{x 4461}# - #{y 4462}#))))))) - #{tmp 4464}#) - (let ((#{tmp 4473}# + #{x 4471}# + #{y 4472}#))))))) + #{tmp 4474}#) + (let ((#{tmp 4483}# ($sc-dispatch - #{tmp 4463}# + #{tmp 4473}# '(#(atom "list") . any)))) - (if #{tmp 4473}# + (if #{tmp 4483}# (@apply - (lambda (#{stuff 4475}#) + (lambda (#{stuff 4485}#) (cons '#(syntax-object "list" ((top) #(ribcage #(stuff) #((top)) - #("i4474")) + #("i4484")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4459" "i4460")) + #("i4469" "i4470")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4454" "i4455")) + #("i4464" "i4465")) #(ribcage (emit quasivector quasilist* @@ -16387,41 +16490,41 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - (cons #{x 4461}# #{stuff 4475}#))) - #{tmp 4473}#) - (let ((#{tmp 4476}# + (cons #{x 4471}# #{stuff 4485}#))) + #{tmp 4483}#) + (let ((#{tmp 4486}# ($sc-dispatch - #{tmp 4463}# + #{tmp 4473}# '(#(atom "list*") . any)))) - (if #{tmp 4476}# + (if #{tmp 4486}# (@apply - (lambda (#{stuff 4478}#) + (lambda (#{stuff 4488}#) (cons '#(syntax-object "list*" ((top) #(ribcage #(stuff) #((top)) - #("i4477")) + #("i4487")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4459" "i4460")) + #("i4469" "i4470")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4454" "i4455")) + #("i4464" "i4465")) #(ribcage (emit quasivector quasilist* @@ -16436,35 +16539,35 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - (cons #{x 4461}# #{stuff 4478}#))) - #{tmp 4476}#) - (let ((#{_ 4480}# #{tmp 4463}#)) + (cons #{x 4471}# #{stuff 4488}#))) + #{tmp 4486}#) + (let ((#{_ 4490}# #{tmp 4473}#)) (list '#(syntax-object "list*" ((top) #(ribcage #(_) #((top)) - #("i4479")) + #("i4489")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4459" "i4460")) + #("i4469" "i4470")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4454" "i4455")) + #("i4464" "i4465")) #(ribcage (emit quasivector quasilist* @@ -16479,30 +16582,30 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{x 4461}# - #{y 4462}#)))))))))) - #{tmp 4458}#) + #{x 4471}# + #{y 4472}#)))))))))) + #{tmp 4468}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4457}#)))))) - (#{quasiappend 4386}# - (lambda (#{x 4481}# #{y 4482}#) - (let ((#{tmp 4485}# #{y 4482}#)) - (let ((#{tmp 4486}# - ($sc-dispatch #{tmp 4485}# '(#(atom "quote") ())))) - (if #{tmp 4486}# + #{tmp 4467}#)))))) + (#{quasiappend 4396}# + (lambda (#{x 4491}# #{y 4492}#) + (let ((#{tmp 4495}# #{y 4492}#)) + (let ((#{tmp 4496}# + ($sc-dispatch #{tmp 4495}# '(#(atom "quote") ())))) + (if #{tmp 4496}# (@apply (lambda () - (if (null? #{x 4481}#) + (if (null? #{x 4491}#) '(#(syntax-object "quote" ((top) @@ -16510,7 +16613,7 @@ #(ribcage #(x y) #((top) (top)) - #("i4483" "i4484")) + #("i4493" "i4494")) #(ribcage (emit quasivector quasilist* @@ -16519,23 +16622,23 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) ()) - (if (null? (cdr #{x 4481}#)) - (car #{x 4481}#) - (let ((#{tmp 4493}# #{x 4481}#)) - (let ((#{tmp 4494}# - ($sc-dispatch #{tmp 4493}# 'each-any))) - (if #{tmp 4494}# + (if (null? (cdr #{x 4491}#)) + (car #{x 4491}#) + (let ((#{tmp 4503}# #{x 4491}#)) + (let ((#{tmp 4504}# + ($sc-dispatch #{tmp 4503}# 'each-any))) + (if #{tmp 4504}# (@apply - (lambda (#{p 4496}#) + (lambda (#{p 4506}#) (cons '#(syntax-object "append" ((top) @@ -16543,12 +16646,12 @@ #(ribcage #(p) #((top)) - #("i4495")) + #("i4505")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4483" "i4484")) + #("i4493" "i4494")) #(ribcage (emit quasivector quasilist* @@ -16563,30 +16666,30 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{p 4496}#)) - #{tmp 4494}#) + #{p 4506}#)) + #{tmp 4504}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4493}#))))))) - #{tmp 4486}#) - (let ((#{_ 4499}# #{tmp 4485}#)) - (if (null? #{x 4481}#) - #{y 4482}# - (let ((#{tmp 4504}# (list #{x 4481}# #{y 4482}#))) - (let ((#{tmp 4505}# - ($sc-dispatch #{tmp 4504}# '(each-any any)))) - (if #{tmp 4505}# + #{tmp 4503}#))))))) + #{tmp 4496}#) + (let ((#{_ 4509}# #{tmp 4495}#)) + (if (null? #{x 4491}#) + #{y 4492}# + (let ((#{tmp 4514}# (list #{x 4491}# #{y 4492}#))) + (let ((#{tmp 4515}# + ($sc-dispatch #{tmp 4514}# '(each-any any)))) + (if #{tmp 4515}# (@apply - (lambda (#{p 4508}# #{y 4509}#) + (lambda (#{p 4518}# #{y 4519}#) (cons '#(syntax-object "append" ((top) @@ -16594,13 +16697,13 @@ #(ribcage #(p y) #((top) (top)) - #("i4506" "i4507")) - #(ribcage #(_) #((top)) #("i4498")) + #("i4516" "i4517")) + #(ribcage #(_) #((top)) #("i4508")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) - #("i4483" "i4484")) + #("i4493" "i4494")) #(ribcage (emit quasivector quasilist* @@ -16615,47 +16718,47 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - (append #{p 4508}# (list #{y 4509}#)))) - #{tmp 4505}#) + (append #{p 4518}# (list #{y 4519}#)))) + #{tmp 4515}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4504}#))))))))))) - (#{quasilist* 4388}# - (lambda (#{x 4511}# #{y 4512}#) + #{tmp 4514}#))))))))))) + (#{quasilist* 4398}# + (lambda (#{x 4521}# #{y 4522}#) (letrec* - ((#{f 4517}# - (lambda (#{x 4518}#) - (if (null? #{x 4518}#) - #{y 4512}# - (#{quasicons 4384}# - (car #{x 4518}#) - (#{f 4517}# (cdr #{x 4518}#))))))) - (begin (#{f 4517}# #{x 4511}#))))) - (#{quasivector 4390}# - (lambda (#{x 4519}#) - (let ((#{tmp 4521}# #{x 4519}#)) - (let ((#{tmp 4522}# + ((#{f 4527}# + (lambda (#{x 4528}#) + (if (null? #{x 4528}#) + #{y 4522}# + (#{quasicons 4394}# + (car #{x 4528}#) + (#{f 4527}# (cdr #{x 4528}#))))))) + (begin (#{f 4527}# #{x 4521}#))))) + (#{quasivector 4400}# + (lambda (#{x 4529}#) + (let ((#{tmp 4531}# #{x 4529}#)) + (let ((#{tmp 4532}# ($sc-dispatch - #{tmp 4521}# + #{tmp 4531}# '(#(atom "quote") each-any)))) - (if #{tmp 4522}# + (if #{tmp 4532}# (@apply - (lambda (#{x 4524}#) + (lambda (#{x 4534}#) (list '#(syntax-object "quote" ((top) - #(ribcage #(x) #((top)) #("i4523")) + #(ribcage #(x) #((top)) #("i4533")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4520")) + #(ribcage #(x) #((top)) #("i4530")) #(ribcage (emit quasivector quasilist* @@ -16664,53 +16767,53 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - (list->vector #{x 4524}#))) - #{tmp 4522}#) - (let ((#{_ 4527}# #{tmp 4521}#)) + (list->vector #{x 4534}#))) + #{tmp 4532}#) + (let ((#{_ 4537}# #{tmp 4531}#)) (letrec* - ((#{f 4531}# - (lambda (#{y 4532}# #{k 4533}#) - (let ((#{tmp 4544}# #{y 4532}#)) - (let ((#{tmp 4545}# + ((#{f 4541}# + (lambda (#{y 4542}# #{k 4543}#) + (let ((#{tmp 4554}# #{y 4542}#)) + (let ((#{tmp 4555}# ($sc-dispatch - #{tmp 4544}# + #{tmp 4554}# '(#(atom "quote") each-any)))) - (if #{tmp 4545}# + (if #{tmp 4555}# (@apply - (lambda (#{y 4547}#) - (#{k 4533}# - (map (lambda (#{tmp 4548}#) + (lambda (#{y 4557}#) + (#{k 4543}# + (map (lambda (#{tmp 4558}#) (list '#(syntax-object "quote" ((top) #(ribcage #(y) #((top)) - #("i4546")) + #("i4556")) #(ribcage () () ()) #(ribcage #(f y k) #((top) (top) (top)) - #("i4528" - "i4529" - "i4530")) + #("i4538" + "i4539" + "i4540")) #(ribcage #(_) #((top)) - #("i4526")) + #("i4536")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4520")) + #("i4530")) #(ribcage (emit quasivector quasilist* @@ -16725,75 +16828,75 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{tmp 4548}#)) - #{y 4547}#))) - #{tmp 4545}#) - (let ((#{tmp 4549}# + #{tmp 4558}#)) + #{y 4557}#))) + #{tmp 4555}#) + (let ((#{tmp 4559}# ($sc-dispatch - #{tmp 4544}# + #{tmp 4554}# '(#(atom "list") . each-any)))) - (if #{tmp 4549}# + (if #{tmp 4559}# (@apply - (lambda (#{y 4551}#) - (#{k 4533}# #{y 4551}#)) - #{tmp 4549}#) - (let ((#{tmp 4553}# + (lambda (#{y 4561}#) + (#{k 4543}# #{y 4561}#)) + #{tmp 4559}#) + (let ((#{tmp 4563}# ($sc-dispatch - #{tmp 4544}# + #{tmp 4554}# '(#(atom "list*") . #(each+ any (any) ()))))) - (if #{tmp 4553}# + (if #{tmp 4563}# (@apply - (lambda (#{y 4556}# #{z 4557}#) - (#{f 4531}# - #{z 4557}# - (lambda (#{ls 4558}#) - (#{k 4533}# + (lambda (#{y 4566}# #{z 4567}#) + (#{f 4541}# + #{z 4567}# + (lambda (#{ls 4568}#) + (#{k 4543}# (append - #{y 4556}# - #{ls 4558}#))))) - #{tmp 4553}#) - (let ((#{else 4562}# #{tmp 4544}#)) - (let ((#{tmp 4566}# #{x 4519}#)) - (let ((#{ g4563 4568}# - #{tmp 4566}#)) + #{y 4566}# + #{ls 4568}#))))) + #{tmp 4563}#) + (let ((#{else 4572}# #{tmp 4554}#)) + (let ((#{tmp 4576}# #{x 4529}#)) + (let ((#{ g4573 4578}# + #{tmp 4576}#)) (list '#(syntax-object "list->vector" ((top) #(ribcage () () ()) #(ribcage - #(#{ g4563}#) - #((m4564 top)) - #("i4567")) + #(#{ g4573}#) + #((m4574 top)) + #("i4577")) #(ribcage #(else) #((top)) - #("i4561")) + #("i4571")) #(ribcage () () ()) #(ribcage #(f y k) #((top) (top) (top)) - #("i4528" - "i4529" - "i4530")) + #("i4538" + "i4539" + "i4540")) #(ribcage #(_) #((top)) - #("i4526")) + #("i4536")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4520")) + #("i4530")) #(ribcage (emit quasivector quasilist* @@ -16808,49 +16911,49 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{ g4563 4568}#)))))))))))))) + #{ g4573 4578}#)))))))))))))) (begin - (#{f 4531}# - #{x 4519}# - (lambda (#{ls 4534}#) - (let ((#{tmp 4539}# #{ls 4534}#)) - (let ((#{tmp 4540}# - ($sc-dispatch #{tmp 4539}# 'each-any))) - (if #{tmp 4540}# + (#{f 4541}# + #{x 4529}# + (lambda (#{ls 4544}#) + (let ((#{tmp 4549}# #{ls 4544}#)) + (let ((#{tmp 4550}# + ($sc-dispatch #{tmp 4549}# 'each-any))) + (if #{tmp 4550}# (@apply - (lambda (#{ g4536 4542}#) + (lambda (#{ g4546 4552}#) (cons '#(syntax-object "vector" ((top) #(ribcage () () ()) #(ribcage - #(#{ g4536}#) - #((m4537 top)) - #("i4541")) + #(#{ g4546}#) + #((m4547 top)) + #("i4551")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(ls) #((top)) - #("i4535")) + #("i4545")) #(ribcage #(_) #((top)) - #("i4526")) + #("i4536")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4520")) + #("i4530")) #(ribcage (emit quasivector quasilist* @@ -16865,36 +16968,36 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{ g4536 4542}#)) - #{tmp 4540}#) + #{ g4546 4552}#)) + #{tmp 4550}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4539}#)))))))))))))) - (#{emit 4392}# - (lambda (#{x 4569}#) - (let ((#{tmp 4571}# #{x 4569}#)) - (let ((#{tmp 4572}# + #{tmp 4549}#)))))))))))))) + (#{emit 4402}# + (lambda (#{x 4579}#) + (let ((#{tmp 4581}# #{x 4579}#)) + (let ((#{tmp 4582}# ($sc-dispatch - #{tmp 4571}# + #{tmp 4581}# '(#(atom "quote") any)))) - (if #{tmp 4572}# + (if #{tmp 4582}# (@apply - (lambda (#{x 4574}#) + (lambda (#{x 4584}#) (list '#(syntax-object quote ((top) - #(ribcage #(x) #((top)) #("i4573")) + #(ribcage #(x) #((top)) #("i4583")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4570")) + #(ribcage #(x) #((top)) #("i4580")) #(ribcage (emit quasivector quasilist* @@ -16903,46 +17006,46 @@ vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{x 4574}#)) - #{tmp 4572}#) - (let ((#{tmp 4575}# + #{x 4584}#)) + #{tmp 4582}#) + (let ((#{tmp 4585}# ($sc-dispatch - #{tmp 4571}# + #{tmp 4581}# '(#(atom "list") . each-any)))) - (if #{tmp 4575}# + (if #{tmp 4585}# (@apply - (lambda (#{x 4577}#) - (let ((#{tmp 4581}# (map #{emit 4392}# #{x 4577}#))) - (let ((#{tmp 4582}# - ($sc-dispatch #{tmp 4581}# 'each-any))) - (if #{tmp 4582}# + (lambda (#{x 4587}#) + (let ((#{tmp 4591}# (map #{emit 4402}# #{x 4587}#))) + (let ((#{tmp 4592}# + ($sc-dispatch #{tmp 4591}# 'each-any))) + (if #{tmp 4592}# (@apply - (lambda (#{ g4578 4584}#) + (lambda (#{ g4588 4594}#) (cons '#(syntax-object list ((top) #(ribcage () () ()) #(ribcage - #(#{ g4578}#) - #((m4579 top)) - #("i4583")) + #(#{ g4588}#) + #((m4589 top)) + #("i4593")) #(ribcage #(x) #((top)) - #("i4576")) + #("i4586")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4570")) + #("i4580")) #(ribcage (emit quasivector quasilist* @@ -16957,70 +17060,70 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{ g4578 4584}#)) - #{tmp 4582}#) + #{ g4588 4594}#)) + #{tmp 4592}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4581}#))))) - #{tmp 4575}#) - (let ((#{tmp 4587}# + #{tmp 4591}#))))) + #{tmp 4585}#) + (let ((#{tmp 4597}# ($sc-dispatch - #{tmp 4571}# + #{tmp 4581}# '(#(atom "list*") . #(each+ any (any) ()))))) - (if #{tmp 4587}# + (if #{tmp 4597}# (@apply - (lambda (#{x 4590}# #{y 4591}#) + (lambda (#{x 4600}# #{y 4601}#) (letrec* - ((#{f 4594}# - (lambda (#{x* 4595}#) - (if (null? #{x* 4595}#) - (#{emit 4392}# #{y 4591}#) - (let ((#{tmp 4601}# - (list (#{emit 4392}# - (car #{x* 4595}#)) - (#{f 4594}# - (cdr #{x* 4595}#))))) - (let ((#{tmp 4602}# + ((#{f 4604}# + (lambda (#{x* 4605}#) + (if (null? #{x* 4605}#) + (#{emit 4402}# #{y 4601}#) + (let ((#{tmp 4611}# + (list (#{emit 4402}# + (car #{x* 4605}#)) + (#{f 4604}# + (cdr #{x* 4605}#))))) + (let ((#{tmp 4612}# ($sc-dispatch - #{tmp 4601}# + #{tmp 4611}# '(any any)))) - (if #{tmp 4602}# + (if #{tmp 4612}# (@apply - (lambda (#{ g4598 4605}# - #{ g4597 4606}#) + (lambda (#{ g4608 4615}# + #{ g4607 4616}#) (list '#(syntax-object cons ((top) #(ribcage () () ()) #(ribcage - #(#{ g4598}# - #{ g4597}#) - #((m4599 top) - (m4599 top)) - #("i4603" "i4604")) + #(#{ g4608}# + #{ g4607}#) + #((m4609 top) + (m4609 top)) + #("i4613" "i4614")) #(ribcage () () ()) #(ribcage #(f x*) #((top) (top)) - #("i4592" "i4593")) + #("i4602" "i4603")) #(ribcage #(x y) #((top) (top)) - #("i4588" "i4589")) + #("i4598" "i4599")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4570")) + #("i4580")) #(ribcage (emit quasivector quasilist* @@ -17035,56 +17138,56 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{ g4598 4605}# - #{ g4597 4606}#)) - #{tmp 4602}#) + #{ g4608 4615}# + #{ g4607 4616}#)) + #{tmp 4612}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4601}#)))))))) - (begin (#{f 4594}# #{x 4590}#)))) - #{tmp 4587}#) - (let ((#{tmp 4607}# + #{tmp 4611}#)))))))) + (begin (#{f 4604}# #{x 4600}#)))) + #{tmp 4597}#) + (let ((#{tmp 4617}# ($sc-dispatch - #{tmp 4571}# + #{tmp 4581}# '(#(atom "append") . each-any)))) - (if #{tmp 4607}# + (if #{tmp 4617}# (@apply - (lambda (#{x 4609}#) - (let ((#{tmp 4613}# - (map #{emit 4392}# #{x 4609}#))) - (let ((#{tmp 4614}# + (lambda (#{x 4619}#) + (let ((#{tmp 4623}# + (map #{emit 4402}# #{x 4619}#))) + (let ((#{tmp 4624}# ($sc-dispatch - #{tmp 4613}# + #{tmp 4623}# 'each-any))) - (if #{tmp 4614}# + (if #{tmp 4624}# (@apply - (lambda (#{ g4610 4616}#) + (lambda (#{ g4620 4626}#) (cons '#(syntax-object append ((top) #(ribcage () () ()) #(ribcage - #(#{ g4610}#) - #((m4611 top)) - #("i4615")) + #(#{ g4620}#) + #((m4621 top)) + #("i4625")) #(ribcage #(x) #((top)) - #("i4608")) + #("i4618")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4570")) + #("i4580")) #(ribcage (emit quasivector quasilist* @@ -17099,54 +17202,54 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{ g4610 4616}#)) - #{tmp 4614}#) + #{ g4620 4626}#)) + #{tmp 4624}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4613}#))))) - #{tmp 4607}#) - (let ((#{tmp 4619}# + #{tmp 4623}#))))) + #{tmp 4617}#) + (let ((#{tmp 4629}# ($sc-dispatch - #{tmp 4571}# + #{tmp 4581}# '(#(atom "vector") . each-any)))) - (if #{tmp 4619}# + (if #{tmp 4629}# (@apply - (lambda (#{x 4621}#) - (let ((#{tmp 4625}# - (map #{emit 4392}# #{x 4621}#))) - (let ((#{tmp 4626}# + (lambda (#{x 4631}#) + (let ((#{tmp 4635}# + (map #{emit 4402}# #{x 4631}#))) + (let ((#{tmp 4636}# ($sc-dispatch - #{tmp 4625}# + #{tmp 4635}# 'each-any))) - (if #{tmp 4626}# + (if #{tmp 4636}# (@apply - (lambda (#{ g4622 4628}#) + (lambda (#{ g4632 4638}#) (cons '#(syntax-object vector ((top) #(ribcage () () ()) #(ribcage - #(#{ g4622}#) - #((m4623 top)) - #("i4627")) + #(#{ g4632}#) + #((m4633 top)) + #("i4637")) #(ribcage #(x) #((top)) - #("i4620")) + #("i4630")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4570")) + #("i4580")) #(ribcage (emit quasivector quasilist* @@ -17161,49 +17264,49 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{ g4622 4628}#)) - #{tmp 4626}#) + #{ g4632 4638}#)) + #{tmp 4636}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4625}#))))) - #{tmp 4619}#) - (let ((#{tmp 4631}# + #{tmp 4635}#))))) + #{tmp 4629}#) + (let ((#{tmp 4641}# ($sc-dispatch - #{tmp 4571}# + #{tmp 4581}# '(#(atom "list->vector") any)))) - (if #{tmp 4631}# + (if #{tmp 4641}# (@apply - (lambda (#{x 4633}#) - (let ((#{tmp 4637}# - (#{emit 4392}# #{x 4633}#))) - (let ((#{ g4634 4639}# - #{tmp 4637}#)) + (lambda (#{x 4643}#) + (let ((#{tmp 4647}# + (#{emit 4402}# #{x 4643}#))) + (let ((#{ g4644 4649}# + #{tmp 4647}#)) (list '#(syntax-object list->vector ((top) #(ribcage () () ()) #(ribcage - #(#{ g4634}#) - #((m4635 top)) - #("i4638")) + #(#{ g4644}#) + #((m4645 top)) + #("i4648")) #(ribcage #(x) #((top)) - #("i4632")) + #("i4642")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4570")) + #("i4580")) #(ribcage (emit quasivector quasilist* @@ -17218,83 +17321,83 @@ (top) (top) (top)) - ("i4391" - "i4389" - "i4387" - "i4385" - "i4383" - "i4381" - "i4379"))) + ("i4401" + "i4399" + "i4397" + "i4395" + "i4393" + "i4391" + "i4389"))) (hygiene guile)) - #{ g4634 4639}#)))) - #{tmp 4631}#) - (let ((#{tmp 4640}# + #{ g4644 4649}#)))) + #{tmp 4641}#) + (let ((#{tmp 4650}# ($sc-dispatch - #{tmp 4571}# + #{tmp 4581}# '(#(atom "value") any)))) - (if #{tmp 4640}# + (if #{tmp 4650}# (@apply - (lambda (#{x 4642}#) #{x 4642}#) - #{tmp 4640}#) + (lambda (#{x 4652}#) #{x 4652}#) + #{tmp 4650}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4571}#))))))))))))))))))) + #{tmp 4581}#))))))))))))))))))) (begin - (lambda (#{x 4643}#) - (let ((#{tmp 4645}# #{x 4643}#)) - (let ((#{tmp 4646}# - ($sc-dispatch #{tmp 4645}# '(_ any)))) - (if #{tmp 4646}# + (lambda (#{x 4653}#) + (let ((#{tmp 4655}# #{x 4653}#)) + (let ((#{tmp 4656}# + ($sc-dispatch #{tmp 4655}# '(_ any)))) + (if #{tmp 4656}# (@apply - (lambda (#{e 4648}#) - (#{emit 4392}# (#{quasi 4380}# #{e 4648}# 0))) - #{tmp 4646}#) + (lambda (#{e 4658}#) + (#{emit 4402}# (#{quasi 4390}# #{e 4658}# 0))) + #{tmp 4656}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4645}#))))))))) + #{tmp 4655}#))))))))) (define include (make-syntax-transformer 'include 'macro - (lambda (#{x 4649}#) + (lambda (#{x 4659}#) (letrec* - ((#{read-file 4652}# - (lambda (#{fn 4653}# #{k 4654}#) + ((#{read-file 4662}# + (lambda (#{fn 4663}# #{k 4664}#) (begin - (let ((#{p 4658}# (open-input-file #{fn 4653}#))) + (let ((#{p 4668}# (open-input-file #{fn 4663}#))) (letrec* - ((#{f 4662}# - (lambda (#{x 4663}# #{result 4664}#) - (if (eof-object? #{x 4663}#) + ((#{f 4672}# + (lambda (#{x 4673}# #{result 4674}#) + (if (eof-object? #{x 4673}#) (begin - (close-input-port #{p 4658}#) - (reverse #{result 4664}#)) - (#{f 4662}# - (read #{p 4658}#) - (cons (datum->syntax #{k 4654}# #{x 4663}#) - #{result 4664}#)))))) - (begin (#{f 4662}# (read #{p 4658}#) '())))))))) + (close-input-port #{p 4668}#) + (reverse #{result 4674}#)) + (#{f 4672}# + (read #{p 4668}#) + (cons (datum->syntax #{k 4664}# #{x 4673}#) + #{result 4674}#)))))) + (begin (#{f 4672}# (read #{p 4668}#) '())))))))) (begin - (let ((#{tmp 4665}# #{x 4649}#)) - (let ((#{tmp 4666}# - ($sc-dispatch #{tmp 4665}# '(any any)))) - (if #{tmp 4666}# + (let ((#{tmp 4675}# #{x 4659}#)) + (let ((#{tmp 4676}# + ($sc-dispatch #{tmp 4675}# '(any any)))) + (if #{tmp 4676}# (@apply - (lambda (#{k 4669}# #{filename 4670}#) + (lambda (#{k 4679}# #{filename 4680}#) (begin - (let ((#{fn 4672}# (syntax->datum #{filename 4670}#))) - (let ((#{tmp 4674}# - (#{read-file 4652}# - #{fn 4672}# - #{filename 4670}#))) - (let ((#{tmp 4675}# - ($sc-dispatch #{tmp 4674}# 'each-any))) - (if #{tmp 4675}# + (let ((#{fn 4682}# (syntax->datum #{filename 4680}#))) + (let ((#{tmp 4684}# + (#{read-file 4662}# + #{fn 4682}# + #{filename 4680}#))) + (let ((#{tmp 4685}# + ($sc-dispatch #{tmp 4684}# 'each-any))) + (if #{tmp 4685}# (@apply - (lambda (#{exp 4677}#) + (lambda (#{exp 4687}#) (cons '#(syntax-object begin ((top) @@ -17302,129 +17405,129 @@ #(ribcage #(exp) #((top)) - #("i4676")) + #("i4686")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) - #("i4671")) + #("i4681")) #(ribcage #(k filename) #((top) (top)) - #("i4667" "i4668")) + #("i4677" "i4678")) #(ribcage (read-file) ((top)) - ("i4651")) + ("i4661")) #(ribcage #(x) #((top)) - #("i4650"))) + #("i4660"))) (hygiene guile)) - #{exp 4677}#)) - #{tmp 4675}#) + #{exp 4687}#)) + #{tmp 4685}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4674}#))))))) - #{tmp 4666}#) + #{tmp 4684}#))))))) + #{tmp 4676}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4665}#))))))))) + #{tmp 4675}#))))))))) (define include-from-path (make-syntax-transformer 'include-from-path 'macro - (lambda (#{x 4679}#) - (let ((#{tmp 4681}# #{x 4679}#)) - (let ((#{tmp 4682}# - ($sc-dispatch #{tmp 4681}# '(any any)))) - (if #{tmp 4682}# + (lambda (#{x 4689}#) + (let ((#{tmp 4691}# #{x 4689}#)) + (let ((#{tmp 4692}# + ($sc-dispatch #{tmp 4691}# '(any any)))) + (if #{tmp 4692}# (@apply - (lambda (#{k 4685}# #{filename 4686}#) + (lambda (#{k 4695}# #{filename 4696}#) (begin - (let ((#{fn 4688}# (syntax->datum #{filename 4686}#))) - (let ((#{tmp 4690}# + (let ((#{fn 4698}# (syntax->datum #{filename 4696}#))) + (let ((#{tmp 4700}# (datum->syntax - #{filename 4686}# + #{filename 4696}# (begin - (let ((#{t 4695}# - (%search-load-path #{fn 4688}#))) - (if #{t 4695}# - #{t 4695}# + (let ((#{t 4705}# + (%search-load-path #{fn 4698}#))) + (if #{t 4705}# + #{t 4705}# (syntax-violation 'include-from-path "file not found in path" - #{x 4679}# - #{filename 4686}#))))))) - (let ((#{fn 4692}# #{tmp 4690}#)) + #{x 4689}# + #{filename 4696}#))))))) + (let ((#{fn 4702}# #{tmp 4700}#)) (list '#(syntax-object include ((top) #(ribcage () () ()) - #(ribcage #(fn) #((top)) #("i4691")) + #(ribcage #(fn) #((top)) #("i4701")) #(ribcage () () ()) #(ribcage () () ()) - #(ribcage #(fn) #((top)) #("i4687")) + #(ribcage #(fn) #((top)) #("i4697")) #(ribcage #(k filename) #((top) (top)) - #("i4683" "i4684")) + #("i4693" "i4694")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4680"))) + #(ribcage #(x) #((top)) #("i4690"))) (hygiene guile)) - #{fn 4692}#)))))) - #{tmp 4682}#) + #{fn 4702}#)))))) + #{tmp 4692}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4681}#))))))) + #{tmp 4691}#))))))) (define unquote (make-syntax-transformer 'unquote 'macro - (lambda (#{x 4697}#) + (lambda (#{x 4707}#) (syntax-violation 'unquote "expression not valid outside of quasiquote" - #{x 4697}#)))) + #{x 4707}#)))) (define unquote-splicing (make-syntax-transformer 'unquote-splicing 'macro - (lambda (#{x 4699}#) + (lambda (#{x 4709}#) (syntax-violation 'unquote-splicing "expression not valid outside of quasiquote" - #{x 4699}#)))) + #{x 4709}#)))) (define case (make-syntax-transformer 'case 'macro - (lambda (#{x 4701}#) - (let ((#{tmp 4703}# #{x 4701}#)) - (let ((#{tmp 4704}# + (lambda (#{x 4711}#) + (let ((#{tmp 4713}# #{x 4711}#)) + (let ((#{tmp 4714}# ($sc-dispatch - #{tmp 4703}# + #{tmp 4713}# '(_ any any . each-any)))) - (if #{tmp 4704}# + (if #{tmp 4714}# (@apply - (lambda (#{e 4708}# #{m1 4709}# #{m2 4710}#) - (let ((#{tmp 4712}# + (lambda (#{e 4718}# #{m1 4719}# #{m2 4720}#) + (let ((#{tmp 4722}# (letrec* - ((#{f 4718}# - (lambda (#{clause 4719}# #{clauses 4720}#) - (if (null? #{clauses 4720}#) - (let ((#{tmp 4722}# #{clause 4719}#)) - (let ((#{tmp 4723}# + ((#{f 4728}# + (lambda (#{clause 4729}# #{clauses 4730}#) + (if (null? #{clauses 4730}#) + (let ((#{tmp 4732}# #{clause 4729}#)) + (let ((#{tmp 4733}# ($sc-dispatch - #{tmp 4722}# + #{tmp 4732}# '(#(free-id #(syntax-object else @@ -17433,92 +17536,92 @@ #(ribcage #(f clause clauses) #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile))) any . each-any)))) - (if #{tmp 4723}# + (if #{tmp 4733}# (@apply - (lambda (#{e1 4726}# #{e2 4727}#) + (lambda (#{e1 4736}# #{e2 4737}#) (cons '#(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) - #("i4724" "i4725")) + #("i4734" "i4735")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile)) - (cons #{e1 4726}# - #{e2 4727}#))) - #{tmp 4723}#) - (let ((#{tmp 4729}# + (cons #{e1 4736}# + #{e2 4737}#))) + #{tmp 4733}#) + (let ((#{tmp 4739}# ($sc-dispatch - #{tmp 4722}# + #{tmp 4732}# '(each-any any . each-any)))) - (if #{tmp 4729}# + (if #{tmp 4739}# (@apply - (lambda (#{k 4733}# - #{e1 4734}# - #{e2 4735}#) + (lambda (#{k 4743}# + #{e1 4744}# + #{e2 4745}#) (list '#(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) - #("i4730" - "i4731" - "i4732")) + #("i4740" + "i4741" + "i4742")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile)) (list '#(syntax-object memv @@ -17528,9 +17631,9 @@ #((top) (top) (top)) - #("i4730" - "i4731" - "i4732")) + #("i4740" + "i4741" + "i4742")) #(ribcage () () @@ -17542,17 +17645,17 @@ #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () @@ -17560,7 +17663,7 @@ #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile)) '#(syntax-object t @@ -17570,9 +17673,9 @@ #((top) (top) (top)) - #("i4730" - "i4731" - "i4732")) + #("i4740" + "i4741" + "i4742")) #(ribcage () () @@ -17584,17 +17687,17 @@ #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () @@ -17602,7 +17705,7 @@ #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile)) (list '#(syntax-object quote @@ -17614,9 +17717,9 @@ #((top) (top) (top)) - #("i4730" - "i4731" - "i4732")) + #("i4740" + "i4741" + "i4742")) #(ribcage () () @@ -17628,9 +17731,9 @@ #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 @@ -17638,9 +17741,9 @@ #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () @@ -17648,10 +17751,10 @@ #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile)) - #{k 4733}#)) + #{k 4743}#)) (cons '#(syntax-object begin ((top) @@ -17660,9 +17763,9 @@ #((top) (top) (top)) - #("i4730" - "i4731" - "i4732")) + #("i4740" + "i4741" + "i4742")) #(ribcage () () @@ -17674,17 +17777,17 @@ #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () @@ -17692,64 +17795,64 @@ #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile)) - (cons #{e1 4734}# - #{e2 4735}#)))) - #{tmp 4729}#) - (let ((#{_ 4739}# #{tmp 4722}#)) + (cons #{e1 4744}# + #{e2 4745}#)))) + #{tmp 4739}#) + (let ((#{_ 4749}# #{tmp 4732}#)) (syntax-violation 'case "bad clause" - #{x 4701}# - #{clause 4719}#))))))) - (let ((#{tmp 4741}# - (#{f 4718}# - (car #{clauses 4720}#) - (cdr #{clauses 4720}#)))) - (let ((#{rest 4743}# #{tmp 4741}#)) - (let ((#{tmp 4744}# #{clause 4719}#)) - (let ((#{tmp 4745}# + #{x 4711}# + #{clause 4729}#))))))) + (let ((#{tmp 4751}# + (#{f 4728}# + (car #{clauses 4730}#) + (cdr #{clauses 4730}#)))) + (let ((#{rest 4753}# #{tmp 4751}#)) + (let ((#{tmp 4754}# #{clause 4729}#)) + (let ((#{tmp 4755}# ($sc-dispatch - #{tmp 4744}# + #{tmp 4754}# '(each-any any . each-any)))) - (if #{tmp 4745}# + (if #{tmp 4755}# (@apply - (lambda (#{k 4749}# - #{e1 4750}# - #{e2 4751}#) + (lambda (#{k 4759}# + #{e1 4760}# + #{e2 4761}#) (list '#(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) - #("i4746" - "i4747" - "i4748")) + #("i4756" + "i4757" + "i4758")) #(ribcage () () ()) #(ribcage #(rest) #((top)) - #("i4742")) + #("i4752")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile)) (list '#(syntax-object memv @@ -17759,9 +17862,9 @@ #((top) (top) (top)) - #("i4746" - "i4747" - "i4748")) + #("i4756" + "i4757" + "i4758")) #(ribcage () () @@ -17769,7 +17872,7 @@ #(ribcage #(rest) #((top)) - #("i4742")) + #("i4752")) #(ribcage () () @@ -17781,17 +17884,17 @@ #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () @@ -17799,7 +17902,7 @@ #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile)) '#(syntax-object t @@ -17809,9 +17912,9 @@ #((top) (top) (top)) - #("i4746" - "i4747" - "i4748")) + #("i4756" + "i4757" + "i4758")) #(ribcage () () @@ -17819,7 +17922,7 @@ #(ribcage #(rest) #((top)) - #("i4742")) + #("i4752")) #(ribcage () () @@ -17831,17 +17934,17 @@ #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () @@ -17849,7 +17952,7 @@ #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile)) (list '#(syntax-object quote @@ -17861,9 +17964,9 @@ #((top) (top) (top)) - #("i4746" - "i4747" - "i4748")) + #("i4756" + "i4757" + "i4758")) #(ribcage () () @@ -17871,7 +17974,7 @@ #(ribcage #(rest) #((top)) - #("i4742")) + #("i4752")) #(ribcage () () @@ -17883,9 +17986,9 @@ #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 @@ -17893,9 +17996,9 @@ #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () @@ -17903,10 +18006,10 @@ #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile)) - #{k 4749}#)) + #{k 4759}#)) (cons '#(syntax-object begin ((top) @@ -17915,9 +18018,9 @@ #((top) (top) (top)) - #("i4746" - "i4747" - "i4748")) + #("i4756" + "i4757" + "i4758")) #(ribcage () () @@ -17925,7 +18028,7 @@ #(ribcage #(rest) #((top)) - #("i4742")) + #("i4752")) #(ribcage () () @@ -17937,17 +18040,17 @@ #((top) (top) (top)) - #("i4715" - "i4716" - "i4717")) + #("i4725" + "i4726" + "i4727")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" - "i4706" - "i4707")) + #("i4715" + "i4716" + "i4717")) #(ribcage () () @@ -17955,31 +18058,31 @@ #(ribcage #(x) #((top)) - #("i4702"))) + #("i4712"))) (hygiene guile)) - (cons #{e1 4750}# - #{e2 4751}#)) - #{rest 4743}#)) - #{tmp 4745}#) - (let ((#{_ 4755}# #{tmp 4744}#)) + (cons #{e1 4760}# + #{e2 4761}#)) + #{rest 4753}#)) + #{tmp 4755}#) + (let ((#{_ 4765}# #{tmp 4754}#)) (syntax-violation 'case "bad clause" - #{x 4701}# - #{clause 4719}#))))))))))) - (begin (#{f 4718}# #{m1 4709}# #{m2 4710}#))))) - (let ((#{body 4714}# #{tmp 4712}#)) + #{x 4711}# + #{clause 4729}#))))))))))) + (begin (#{f 4728}# #{m1 4719}# #{m2 4720}#))))) + (let ((#{body 4724}# #{tmp 4722}#)) (list '#(syntax-object let ((top) #(ribcage () () ()) - #(ribcage #(body) #((top)) #("i4713")) + #(ribcage #(body) #((top)) #("i4723")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" "i4706" "i4707")) + #("i4715" "i4716" "i4717")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4702"))) + #(ribcage #(x) #((top)) #("i4712"))) (hygiene guile)) (list (list '#(syntax-object t @@ -17988,176 +18091,176 @@ #(ribcage #(body) #((top)) - #("i4713")) + #("i4723")) #(ribcage #(e m1 m2) #((top) (top) (top)) - #("i4705" "i4706" "i4707")) + #("i4715" "i4716" "i4717")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4702"))) + #(ribcage #(x) #((top)) #("i4712"))) (hygiene guile)) - #{e 4708}#)) - #{body 4714}#)))) - #{tmp 4704}#) + #{e 4718}#)) + #{body 4724}#)))) + #{tmp 4714}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4703}#))))))) + #{tmp 4713}#))))))) (define make-variable-transformer - (lambda (#{proc 4756}#) - (if (procedure? #{proc 4756}#) + (lambda (#{proc 4766}#) + (if (procedure? #{proc 4766}#) (begin (letrec* - ((#{trans 4759}# - (lambda (#{x 4760}#) (#{proc 4756}# #{x 4760}#)))) + ((#{trans 4769}# + (lambda (#{x 4770}#) (#{proc 4766}# #{x 4770}#)))) (begin (set-procedure-property! - #{trans 4759}# + #{trans 4769}# 'variable-transformer #t) - #{trans 4759}#))) + #{trans 4769}#))) (error "variable transformer not a procedure" - #{proc 4756}#)))) + #{proc 4766}#)))) (define identifier-syntax (make-syntax-transformer 'identifier-syntax 'macro - (lambda (#{x 4762}#) - (let ((#{tmp 4764}# #{x 4762}#)) - (let ((#{tmp 4765}# - ($sc-dispatch #{tmp 4764}# '(_ any)))) - (if #{tmp 4765}# + (lambda (#{x 4772}#) + (let ((#{tmp 4774}# #{x 4772}#)) + (let ((#{tmp 4775}# + ($sc-dispatch #{tmp 4774}# '(_ any)))) + (if #{tmp 4775}# (@apply - (lambda (#{e 4767}#) + (lambda (#{e 4777}#) (list '#(syntax-object lambda ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) '(#(syntax-object x ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile))) '#((#(syntax-object macro-type ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) . #(syntax-object identifier-syntax ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)))) (list '#(syntax-object syntax-case ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) '#(syntax-object x ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) '() (list '#(syntax-object id ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) '(#(syntax-object identifier? ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) (#(syntax-object syntax ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) #(syntax-object id ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)))) (list '#(syntax-object syntax ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)) - #{e 4767}#)) + #{e 4777}#)) (list '(#(syntax-object _ ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) #(syntax-object x ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) #(syntax-object ... ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile))) (list '#(syntax-object syntax ((top) - #(ribcage #(e) #((top)) #("i4766")) + #(ribcage #(e) #((top)) #("i4776")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)) - (cons #{e 4767}# + (cons #{e 4777}# '(#(syntax-object x ((top) #(ribcage #(e) #((top)) - #("i4766")) + #("i4776")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)) #(syntax-object ... @@ -18165,55 +18268,55 @@ #(ribcage #(e) #((top)) - #("i4766")) + #("i4776")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile))))))))) - #{tmp 4765}#) - (let ((#{tmp 4768}# + #{tmp 4775}#) + (let ((#{tmp 4778}# ($sc-dispatch - #{tmp 4764}# + #{tmp 4774}# '(_ (any any) ((#(free-id #(syntax-object set! ((top) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile))) any any) any))))) - (if (if #{tmp 4768}# + (if (if #{tmp 4778}# (@apply - (lambda (#{id 4774}# - #{exp1 4775}# - #{var 4776}# - #{val 4777}# - #{exp2 4778}#) - (if (identifier? #{id 4774}#) - (identifier? #{var 4776}#) + (lambda (#{id 4784}# + #{exp1 4785}# + #{var 4786}# + #{val 4787}# + #{exp2 4788}#) + (if (identifier? #{id 4784}#) + (identifier? #{var 4786}#) #f)) - #{tmp 4768}#) + #{tmp 4778}#) #f) (@apply - (lambda (#{id 4786}# - #{exp1 4787}# - #{var 4788}# - #{val 4789}# - #{exp2 4790}#) + (lambda (#{id 4796}# + #{exp1 4797}# + #{var 4798}# + #{val 4799}# + #{exp2 4800}#) (list '#(syntax-object make-variable-transformer ((top) #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i4781" "i4782" "i4783" "i4784" "i4785")) + #("i4791" "i4792" "i4793" "i4794" "i4795")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) (list '#(syntax-object lambda @@ -18221,13 +18324,13 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) '(#(syntax-object x @@ -18235,13 +18338,13 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile))) '#((#(syntax-object macro-type @@ -18249,13 +18352,13 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) . #(syntax-object @@ -18264,13 +18367,13 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)))) (list '#(syntax-object syntax-case @@ -18278,13 +18381,13 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) '#(syntax-object x @@ -18292,13 +18395,13 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile)) '(#(syntax-object set! @@ -18306,13 +18409,13 @@ #(ribcage #(id exp1 var val exp2) #((top) (top) (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4763"))) + #(ribcage #(x) #((top)) #("i4773"))) (hygiene guile))) (list (list '#(syntax-object set! @@ -18324,19 +18427,19 @@ (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)) - #{var 4788}# - #{val 4789}#) + #{var 4798}# + #{val 4799}#) (list '#(syntax-object syntax ((top) @@ -18347,19 +18450,19 @@ (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)) - #{exp2 4790}#)) - (list (cons #{id 4786}# + #{exp2 4800}#)) + (list (cons #{id 4796}# '(#(syntax-object x ((top) @@ -18374,16 +18477,16 @@ (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)) #(syntax-object ... @@ -18399,16 +18502,16 @@ (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)))) (list '#(syntax-object syntax @@ -18420,18 +18523,18 @@ (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)) - (cons #{exp1 4787}# + (cons #{exp1 4797}# '(#(syntax-object x ((top) @@ -18446,11 +18549,11 @@ (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () @@ -18458,7 +18561,7 @@ #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)) #(syntax-object ... @@ -18474,11 +18577,11 @@ (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () @@ -18486,10 +18589,10 @@ #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)))))) - (list #{id 4786}# + (list #{id 4796}# (list '#(syntax-object identifier? ((top) @@ -18500,16 +18603,16 @@ (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)) (list '#(syntax-object syntax @@ -18525,18 +18628,18 @@ (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)) - #{id 4786}#)) + #{id 4796}#)) (list '#(syntax-object syntax ((top) @@ -18547,69 +18650,69 @@ (top) (top) (top)) - #("i4781" - "i4782" - "i4783" - "i4784" - "i4785")) + #("i4791" + "i4792" + "i4793" + "i4794" + "i4795")) #(ribcage () () ()) #(ribcage #(x) #((top)) - #("i4763"))) + #("i4773"))) (hygiene guile)) - #{exp1 4787}#)))))) - #{tmp 4768}#) + #{exp1 4797}#)))))) + #{tmp 4778}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4764}#))))))))) + #{tmp 4774}#))))))))) (define define* (make-syntax-transformer 'define* 'macro - (lambda (#{x 4791}#) - (let ((#{tmp 4793}# #{x 4791}#)) - (let ((#{tmp 4794}# + (lambda (#{x 4801}#) + (let ((#{tmp 4803}# #{x 4801}#)) + (let ((#{tmp 4804}# ($sc-dispatch - #{tmp 4793}# + #{tmp 4803}# '(_ (any . any) any . each-any)))) - (if #{tmp 4794}# + (if #{tmp 4804}# (@apply - (lambda (#{id 4799}# - #{args 4800}# - #{b0 4801}# - #{b1 4802}#) + (lambda (#{id 4809}# + #{args 4810}# + #{b0 4811}# + #{b1 4812}#) (list '#(syntax-object define ((top) #(ribcage #(id args b0 b1) #((top) (top) (top) (top)) - #("i4795" "i4796" "i4797" "i4798")) + #("i4805" "i4806" "i4807" "i4808")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4792"))) + #(ribcage #(x) #((top)) #("i4802"))) (hygiene guile)) - #{id 4799}# + #{id 4809}# (cons '#(syntax-object lambda* ((top) #(ribcage #(id args b0 b1) #((top) (top) (top) (top)) - #("i4795" "i4796" "i4797" "i4798")) + #("i4805" "i4806" "i4807" "i4808")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4792"))) + #(ribcage #(x) #((top)) #("i4802"))) (hygiene guile)) - (cons #{args 4800}# - (cons #{b0 4801}# #{b1 4802}#))))) - #{tmp 4794}#) - (let ((#{tmp 4804}# - ($sc-dispatch #{tmp 4793}# '(_ any any)))) - (if (if #{tmp 4804}# + (cons #{args 4810}# + (cons #{b0 4811}# #{b1 4812}#))))) + #{tmp 4804}#) + (let ((#{tmp 4814}# + ($sc-dispatch #{tmp 4803}# '(_ any any)))) + (if (if #{tmp 4814}# (@apply - (lambda (#{id 4807}# #{val 4808}#) + (lambda (#{id 4817}# #{val 4818}#) (identifier? '#(syntax-object x @@ -18617,29 +18720,29 @@ #(ribcage #(id val) #((top) (top)) - #("i4805" "i4806")) + #("i4815" "i4816")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4792"))) + #(ribcage #(x) #((top)) #("i4802"))) (hygiene guile)))) - #{tmp 4804}#) + #{tmp 4814}#) #f) (@apply - (lambda (#{id 4811}# #{val 4812}#) + (lambda (#{id 4821}# #{val 4822}#) (list '#(syntax-object define ((top) #(ribcage #(id val) #((top) (top)) - #("i4809" "i4810")) + #("i4819" "i4820")) #(ribcage () () ()) - #(ribcage #(x) #((top)) #("i4792"))) + #(ribcage #(x) #((top)) #("i4802"))) (hygiene guile)) - #{id 4811}# - #{val 4812}#)) - #{tmp 4804}#) + #{id 4821}# + #{val 4822}#)) + #{tmp 4814}#) (syntax-violation #f "source expression failed to match any pattern" - #{tmp 4793}#))))))))) + #{tmp 4803}#))))))))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 5380ba787..ae9c273ae 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -313,9 +313,9 @@ (lambda (source) (make-void source))) - (define build-application + (define build-call (lambda (source fun-exp arg-exps) - (make-application source fun-exp arg-exps))) + (make-call source fun-exp arg-exps))) (define build-conditional (lambda (source test-exp then-exp else-exp) @@ -402,12 +402,14 @@ (lambda (src req opt rest kw inits vars body else-case) (make-lambda-case src req opt rest kw inits vars body else-case))) + (define build-primcall + (lambda (src name args) + (make-primcall src name args))) + (define build-primref (lambda (src name) - (if (equal? (module-name (current-module)) '(guile)) - (make-toplevel-ref src name) - (make-module-ref src '(guile) name #f)))) - + (make-primitive-ref src name))) + (define (build-data src exp) (make-const src exp)) @@ -415,7 +417,7 @@ (lambda (src exps) (if (null? (cdr exps)) (car exps) - (make-sequence src exps)))) + (make-seq src (car exps) (build-sequence #f (cdr exps)))))) (define build-let (lambda (src ids vars val-exps body-exp) @@ -436,8 +438,8 @@ (make-letrec src #f (list f-name) (list f) (list proc) - (build-application src (build-lexical-reference 'fun src f-name f) - val-exps)))))) + (build-call src (build-lexical-reference 'fun src f-name f) + val-exps)))))) (define build-letrec (lambda (src in-order? ids vars val-exps body-exp) @@ -1038,9 +1040,9 @@ (build-global-definition no-source name - (build-application + (build-primcall no-source - (build-primref no-source 'make-syntax-transformer) + 'make-syntax-transformer (list (build-data no-source name) (build-data no-source 'macro) e))))) @@ -1200,7 +1202,7 @@ (lambda (e r w s mod) (chi e r w mod)))) ((lexical-call) - (chi-application + (chi-call (let ((id (car e))) (build-lexical-reference 'fun (source-annotation id) (if (syntax-object? id) @@ -1209,7 +1211,7 @@ value)) e r w s mod)) ((global-call) - (chi-application + (chi-call (build-global-reference (source-annotation (car e)) (if (syntax-object? value) (syntax-object-expression value) @@ -1220,7 +1222,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) (chi-application (chi (car e) r w mod) e r w s mod)) + ((call) (chi-call (chi (car e) r w mod) e r w s mod)) ((begin-form) (syntax-case e () ((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod)))) @@ -1245,12 +1247,12 @@ (else (syntax-violation #f "unexpected syntax" (source-wrap e w s mod)))))) - (define chi-application + (define chi-call (lambda (x e r w s mod) (syntax-case e () ((e0 e1 ...) - (build-application s x - (map (lambda (e) (chi e r w mod)) #'(e1 ...))))))) + (build-call s x + (map (lambda (e) (chi e r w mod)) #'(e1 ...))))))) ;; (What follows is my interpretation of what's going on here -- Andy) ;; @@ -1954,9 +1956,7 @@ (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))))))) + (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))) @@ -2147,10 +2147,10 @@ (build-global-assignment s (syntax->datum #'e) val mod))))))) (else - (build-application s - (chi #'(setter head) r w mod) - (map (lambda (e) (chi e r w mod)) - #'(tail ... val)))))))) + (build-call s + (chi #'(setter head) r w mod) + (map (lambda (e) (chi e r w mod)) + #'(tail ... val)))))))) (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) (global-extend 'module-ref '@ @@ -2288,20 +2288,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 '() - (chi 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 '() + (chi 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) @@ -2316,36 +2317,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) @@ -2355,18 +2352,18 @@ (chi #'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) - '() - (chi #'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) + '() + (chi #'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) @@ -2383,14 +2380,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 (chi #'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 (chi #'val r empty-wrap mod)))) (syntax-violation 'syntax-case "invalid literals list" e)))))))) ;; The portable macroexpand seeds chi-top's mode m with 'e (for 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 c46fd621d..7a96d0723 100644 --- a/module/language/ecmascript/compile-tree-il.scm +++ b/module/language/ecmascript/compile-tree-il.scm @@ -38,7 +38,7 @@ (define-syntax @impl (syntax-rules () ((_ sym arg ...) - (-> (apply (@implv sym) arg ...))))) + (-> (call (@implv sym) arg ...))))) (define (empty-lexical-environment) '()) @@ -103,23 +103,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) @@ -127,27 +127,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) @@ -176,9 +176,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) @@ -189,9 +189,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) @@ -204,16 +204,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) @@ -224,9 +224,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) @@ -246,18 +246,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)) @@ -267,11 +267,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)) @@ -281,18 +281,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)) @@ -303,11 +303,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)) @@ -345,7 +345,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)) @@ -357,25 +357,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) @@ -450,14 +450,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))) @@ -467,9 +467,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 "))) @@ -483,10 +483,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 ")) @@ -506,9 +506,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 221cf264d..ec3c50263 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 @@ -52,6 +53,8 @@ <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) @@ -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))) @@ -253,8 +272,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 +316,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))) @@ -336,9 +358,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 +458,13 @@ 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 + tree-il->scheme))) ((<let> gensyms vals body) `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body))) @@ -478,7 +508,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 +520,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 +538,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) @@ -580,11 +613,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) @@ -633,9 +669,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)) @@ -663,9 +702,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))) @@ -717,9 +757,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)) @@ -746,9 +789,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))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 23eff2ce2..9e5c685a5 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -178,10 +178,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))) @@ -220,13 +223,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 @@ -364,9 +362,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))) @@ -382,8 +383,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 @@ -863,7 +865,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) @@ -929,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 @@ -967,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) @@ -1032,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? @@ -1120,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) @@ -1180,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) @@ -1197,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))) @@ -1348,7 +1350,7 @@ accurate information is missing from a given `tree-il' element." (record-case x ((<const> exp) exp) - ((<application> proc args) + ((<call> proc args) ;; Gettexted literals, like `(_ "foo")'. (and (record-case proc ((<toplevel-ref> name) (eq? name '_)) @@ -1412,7 +1414,7 @@ accurate information is missing from a given `tree-il' element." (false-if-exception (module-ref env name)))) (record-case x - ((<application> proc args src) + ((<call> proc args src) (let ((loc src)) (record-case proc ((<toplevel-ref> name src) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index f193e9dcd..2cb0806d9 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -246,182 +246,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) - (not (eq? context 'push))) - ;; 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)) - ((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 (make-glil-call 'return/values (length args)))))) - - ((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)))))) - ;; self-call in tail position ((and (lexical-ref? proc) self-label (eq? (lexical-ref-gensym proc) self-label) @@ -518,6 +348,141 @@ (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 . _) (guard (not (eq? context 'push))) + ;; 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)) + ((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 (make-glil-call 'return/values (length args)))))) + + ((@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) @@ -526,54 +491,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)))) @@ -948,7 +892,7 @@ ((<dynwind> src body winder unwinder) (comp-push winder) (comp-push unwinder) - (comp-drop (make-application src winder '())) + (comp-drop (make-call src winder '())) (emit-code #f (make-glil-call 'wind 2)) (case context @@ -957,14 +901,14 @@ (comp-vals body MV) ;; one value: unwind... (emit-code #f (make-glil-call 'unwind 0)) - (comp-drop (make-application src unwinder '())) + (comp-drop (make-call src unwinder '())) ;; ...and return the val (emit-code #f (make-glil-call 'return 1)) (emit-label MV) ;; multiple values: unwind... (emit-code #f (make-glil-call 'unwind 0)) - (comp-drop (make-application src unwinder '())) + (comp-drop (make-call src unwinder '())) ;; and return the values. (emit-code #f (make-glil-call 'return/nvalues 1)))) @@ -973,7 +917,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 (make-call src unwinder '()))) ((vals) (let ((MV (make-label))) @@ -984,7 +928,7 @@ (emit-label MV) ;; multiple values: unwind... (emit-code #f (make-glil-call 'unwind 0)) - (comp-drop (make-application src unwinder '())) + (comp-drop (make-call src unwinder '())) ;; and goto the MVRA. (emit-branch #f 'br MVRA))) @@ -992,7 +936,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 (make-call src unwinder '())) ;; and fall through, or goto RA if there is one. (if RA (emit-branch #f 'br RA))))) 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/inline.scm b/module/language/tree-il/inline.scm index de0cffc96..16af52a18 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -47,44 +47,36 @@ (else x))) (else x))) - ((<application> src proc args) - (record-case proc - ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x) - ((<primitive-ref> name) - (case name - ((memq memv) - (pmatch args - ((,k ,l) (guard (const? l) (list? (const-exp l))) - (cond - ((null? (const-exp l)) - (make-const #f #f)) - ((const? k) - (make-const #f (->bool ((case name - ((memq) memq) - ((memv) memv) - (else (error "unexpected member func" name))) - (const-exp k) (const-exp l))))) - (else - (let lp ((elts (const-exp l))) - (let ((test (make-application - #f - (make-primitive-ref #f (case name - ((memq) 'eq?) - ((memv) 'eqv?) - (else (error "what")))) - (list k (make-const #f (car elts)))))) - (if (null? (cdr elts)) - test - (make-conditional - src - test - (make-const #f #t) - (lp (cdr elts))))))))) - - (else x))) - - (else x))) - + ((<primcall> src name args) + (pmatch (cons name args) + ((,member ,k ,l) (guard (and (memq member '(memq memv)) + (const? k) + (list? (const-exp l)))) + (cond + ((null? (const-exp l)) + (make-const #f #f)) + ((const? k) + (make-const #f (->bool ((case member + ((memq) memq) + ((memv) memv) + (else (error "what" member))) + (const-exp k) (const-exp l))))) + (else + (let lp ((elts (const-exp l))) + (let ((test (make-primcall + #f + (case member + ((memq) 'eq?) + ((memv) 'eqv?) + (else (error "what" member))) + (list k (make-const #f (car elts)))))) + (if (null? (cdr elts)) + test + (make-conditional + src + test + (make-const #f #t) + (lp (cdr elts))))))))) (else x))) ((<lambda> meta body) @@ -101,7 +93,7 @@ (define (inline! x) (define (inline1 x) (record-case x - ((<application> src proc args) + ((<call> src proc args) (record-case proc ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x) ((<lambda> body) @@ -114,34 +106,29 @@ (or (inline1 x) x)) (lp alternate))))))) - ((<primitive-ref> name) - (case name - ((@call-with-values) - (pmatch args - ;; (call-with-values (lambda () foo) (lambda (a b . c) bar)) - ;; => (let-values (((a b . c) foo)) bar) - ;; - ;; Note that this is a singly-binding form of let-values. - ;; Also note that Scheme's let-values expands into - ;; call-with-values, then here we reduce it to tree-il's - ;; let-values. - ((,producer ,consumer) - (guard (lambda? consumer) - (lambda-case? (lambda-body consumer)) - (not (lambda-case-opt (lambda-body consumer))) - (not (lambda-case-kw (lambda-body consumer))) - (not (lambda-case-alternate (lambda-body consumer)))) - (make-let-values - src - (let ((x (make-application src producer '()))) - (or (inline1 x) x)) - (lambda-body consumer))) - (else #f))) - - (else #f))) - (else #f))) + ((<primcall> src name args) + (pmatch (cons name args) + ;; (call-with-values (lambda () foo) (lambda (a b . c) bar)) + ;; => (let-values (((a b . c) foo)) bar) + ;; + ;; Note that this is a singly-binding form of let-values. Also + ;; note that Scheme's let-values expands into call-with-values, + ;; then here we reduce it to tree-il's let-values. + ((@call-with-values ,producer ,consumer) + (guard (lambda? consumer) + (lambda-case? (lambda-body consumer)) + (not (lambda-case-opt (lambda-body consumer))) + (not (lambda-case-kw (lambda-body consumer))) + (not (lambda-case-alternate (lambda-body consumer)))) + (make-let-values + src + (let ((x (make-call src producer '()))) + (or (inline1 x) x)) + (lambda-body consumer))) + (else #f))) + ((<conditional> test consequent alternate) (let ((btest (boolean-value test))) (or (record-case btest @@ -178,10 +165,9 @@ (and (not opt) (not kw) rest (not alternate) (record-case body - ((<application> proc args) + ((<primcall> name args) ;; (lambda args (apply (lambda ...) args)) => (lambda ...) - (and (primitive-ref? proc) - (eq? (primitive-ref-name proc) '@apply) + (and (eq? name '@apply) (pair? args) (lambda? (car args)) (args-compatible? (cdr args) gensyms) @@ -189,7 +175,7 @@ (else #f)))) ;; Actually the opposite of inlining -- if the prompt cannot be proven to - ;; be escape-only, ensure that its body is the application of a thunk. + ;; be escape-only, ensure that its body is the call of a thunk. ((<prompt> src tag body handler) (define (escape-only? handler) (and (pair? (lambda-case-req handler)) @@ -206,13 +192,13 @@ (define (make-thunk body) (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f))) - (if (or (and (application? body) - (lambda? (application-proc body)) - (null? (application-args body))) + (if (or (and (call? body) + (lambda? (call-proc body)) + (null? (call-args body))) (escape-only? handler)) x (make-prompt src tag - (make-application #f (make-thunk body) '()) + (make-call #f (make-thunk body) '()) handler))) (else #f))) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 316a4628e..40fc19444 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -1,6 +1,6 @@ ;;; open-coding primitive procedures -;; 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 @@ -172,6 +172,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)) @@ -183,11 +186,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)) @@ -203,8 +204,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 @@ -222,8 +223,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) @@ -412,7 +413,7 @@ (make-dynwind src (make-lexical-ref #f 'pre PRE) - (make-application #f thunk '()) + (make-call #f thunk '()) (make-lexical-ref #f 'post POST))))) (else (let ((PRE (gensym " pre")) @@ -426,7 +427,7 @@ (make-dynwind src (make-lexical-ref #f 'pre PRE) - (make-application #f (make-lexical-ref #f 'thunk THUNK) '()) + (make-call #f (make-lexical-ref #f 'thunk THUNK) '()) (make-lexical-ref #f 'post POST))))))) (else #f))) @@ -470,9 +471,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))) @@ -486,14 +487,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..1c6611b4e 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!" x rest env)))) (define-language tree-il #:title "Tree Intermediate Language" 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/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/srfi-4.test b/test-suite/tests/srfi-4.test index fca065d55..3a0710222 100644 --- a/test-suite/tests/srfi-4.test +++ b/test-suite/tests/srfi-4.test @@ -477,4 +477,3 @@ (pass-if "+inf.0, -inf.0, +nan.0 in c64vector" (c64vector? #c64(+inf.0 -inf.0 +nan.0)))) - diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 1b86b99fc..a59835e0e 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -63,15 +63,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) @@ -79,7 +79,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)))) @@ -98,7 +98,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) @@ -115,7 +115,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)))) @@ -135,7 +135,7 @@ (unbind))) (assert-tree-il->glil - (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) @@ -145,7 +145,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) @@ -154,7 +154,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) @@ -164,8 +164,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) @@ -186,7 +186,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))) @@ -204,7 +204,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)))) @@ -223,7 +223,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))) @@ -241,7 +241,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)))) @@ -260,7 +260,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)))) @@ -279,7 +279,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)))) @@ -298,7 +298,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)))) @@ -315,7 +315,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (const 2)) + (primcall null? (const 2)) (program () (std-prelude 0 0 #f) (label _) (const 2) (call null? 1) (call return 1)))) @@ -323,7 +323,7 @@ ;; simple bindings -> let (assert-tree-il->glil (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)) @@ -335,8 +335,8 @@ ;; complex bindings -> box and set! within let (assert-tree-il->glil - (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)) @@ -351,8 +351,8 @@ ;; complex bindings in letrec* -> box and set! in order (assert-tree-il->glil - (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)) @@ -470,7 +470,7 @@ (const #t) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (begin (const #f) (const 2))) + (primcall null? (begin (const #f) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (call null? 1) (call return 1)))) @@ -512,10 +512,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) @@ -523,7 +523,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) @@ -531,10 +531,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) @@ -542,8 +542,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) @@ -580,9 +580,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) |