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
# 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
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])
-CFLAGS = `pkg-config guile-2.0 --cflags`
-LIBS = `pkg-config guile-2.0 --libs`
+CFLAGS = `pkg-config guile-2.2 --cflags`
+LIBS = `pkg-config guile-2.2 --libs`
O_FILES = image-type.o myguile.o
.\" groff -man -Tascii foo.1
.\"
.\" title section date source manual
-.TH GUILE 1 "2011-03-04" GNU "GNU Guile 2.0"
+.TH GUILE 1 "2011-03-04" GNU "GNU Guile 2.2"
.
.SH NAME
guile \- The GNU Project Extension Language
@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.
@node The Scheme Compiler
@subsection The Scheme Compiler
-The job of the Scheme compiler is to expand all macros and all of
-Scheme to its most primitive expressions. The definition of
-``primitive'' is given by the inventory of constructs provided by
-Tree-IL, the target language of the Scheme compiler: procedure
-applications, conditionals, lexical references, etc. This is described
-more fully in the next section.
+The job of the Scheme compiler is to expand all macros and all of Scheme
+to its most primitive expressions. The definition of ``primitive'' is
+given by the inventory of constructs provided by Tree-IL, the target
+language of the Scheme compiler: procedure calls, conditionals, lexical
+references, etc. This is described more fully in the next section.
The tricky and amusing thing about the Scheme-to-Tree-IL compiler is
that it is completely implemented by the macro expander. Since the
@lisp
(compile '(+ 1 2) #:from 'scheme #:to 'tree-il)
@result{}
- #<<application> src: #f
- proc: #<<toplevel-ref> src: #f name: +>
- args: (#<<const> src: #f exp: 1>
- #<<const> src: #f exp: 2>)>
+ #<<call> src: #f
+ proc: #<<toplevel-ref> src: #f name: +>
+ args: (#<<const> src: #f exp: 1>
+ #<<const> src: #f exp: 2>)>
@end lisp
Or, since Tree-IL is so close to Scheme, it is often useful to expand
Compilation of Tree-IL usually begins with a pass that resolves some
@code{<module-ref>} and @code{<toplevel-ref>} expressions to
-@code{<primitive-ref>} expressions. The actual compilation pass
-has special cases for applications of certain primitives, like
-@code{apply} or @code{cons}.
+@code{<primitive-ref>} expressions. The actual compilation pass has
+special cases for calls to certain primitives, like @code{apply} or
+@code{cons}.
@end deftp
@deftp {Scheme Variable} <lexical-ref> src name gensym
@deftpx {External Representation} (lexical @var{name} @var{gensym})
@deftpx {External Representation} (if @var{test} @var{then} @var{else})
A conditional. Note that @var{else} is not optional.
@end deftp
-@deftp {Scheme Variable} <application> src proc args
-@deftpx {External Representation} (apply @var{proc} . @var{args})
+@deftp {Scheme Variable} <call> src proc args
+@deftpx {External Representation} (call @var{proc} . @var{args})
A procedure call.
@end deftp
+@deftp {Scheme Variable} <primcall> src name args
+@deftpx {External Representation} (primcall @var{name} . @var{args})
+A call to a primitive. Equivalent to @code{(call (primitive @var{name})
+. @var{args})}. This construct is often more convenient to generate and
+analyze than @code{<call>}.
+
+As part of the compilation process, instances of @code{(call (primitive
+@var{name}) . @var{args})} are transformed into primcalls.
+@end deftp
@deftp {Scheme Variable} <sequence> src exps
@deftpx {External Representation} (begin . @var{exps})
Like Scheme's @code{begin}.
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
@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.
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
@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
@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.
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
#endif
\f
-/* {Supported Options}
- *
- * These may be defined or undefined.
- */
-
-/* #define GUILE_DEBUG_FREELIST */
-
-
-/* Use engineering notation when converting numbers strings?
- */
-#undef ENGNOT
-
-\f
-/* {Unsupported Options}
- *
- * These must be defined as given here.
- */
-
-
-/* Guile Scheme supports the #f/() distinction; Guile Lisp won't. We
- have horrible plans for their unification. */
-#undef SICP
-
-\f
-
-/* Random options (not yet supported or in final form). */
-
-#define STACK_CHECKING
-#undef NO_CEVAL_STACK_CHECKING
-
-\f
/* SCM_API is a macro prepended to all function and data definitions
which should be exported from libguile. */
\f
+/* 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
+
+\f
+
/* {Debugging Options}
*
* These compile time options determine whether to include code that is only
#define SCM_DEBUG 0
#endif
-/* For debugging purposes: define this is to ensure nobody is using
- * the mark bits outside of the marking phase. This is meant for
- * debugging purposes only.
- */
-#ifndef SCM_DEBUG_MARKING_API
-#define SCM_DEBUG_MARKING_API 0
-#endif
-
/* If SCM_DEBUG_CELL_ACCESSES is set to 1, cell accesses will perform
* exhaustive parameter checking: It will be verified that cell parameters
* actually point to a valid heap cell. Note: If this option is enabled,
#define SCM_DEBUG_CELL_ACCESSES SCM_DEBUG
#endif
-/* If SCM_DEBUG_INTERRUPTS is set to 1, with every deferring and allowing of
- * interrupts a consistency check will be performed.
- */
-#ifndef SCM_DEBUG_INTERRUPTS
-#define SCM_DEBUG_INTERRUPTS SCM_DEBUG
-#endif
-
/* If SCM_DEBUG_PAIR_ACCESSES is set to 1, accesses to cons cells will be
* exhaustively checked. Note: If this option is enabled, guile will run
* slower than normally.
#define SCM_DEBUG_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
-
\f
/* {Feature Options}
# 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)
#define SCM_T_INT64_MIN SCM_I_TYPE_MIN(scm_t_int64,SCM_T_UINT64_MAX)
#define SCM_T_INT64_MAX SCM_I_TYPE_MAX(scm_t_int64,SCM_T_UINT64_MAX)
-#if SCM_SIZEOF_LONG_LONG
-#define SCM_I_ULLONG_MAX SCM_I_UTYPE_MAX(unsigned long long)
-#define SCM_I_LLONG_MIN SCM_I_TYPE_MIN(long long,SCM_I_ULLONG_MAX)
-#define SCM_I_LLONG_MAX SCM_I_TYPE_MAX(long long,SCM_I_ULLONG_MAX)
-#endif
-
#define SCM_T_UINTMAX_MAX SCM_I_UTYPE_MAX(scm_t_uintmax)
#define SCM_T_INTMAX_MIN SCM_I_TYPE_MIN(scm_t_intmax,SCM_T_UINTMAX_MAX)
#define SCM_T_INTMAX_MAX SCM_I_TYPE_MAX(scm_t_intmax,SCM_T_UINTMAX_MAX)
#define SCM_T_INTPTR_MIN SCM_I_TYPE_MIN(scm_t_intptr,SCM_T_UINTPTR_MAX)
#define SCM_T_INTPTR_MAX SCM_I_TYPE_MAX(scm_t_intptr,SCM_T_UINTPTR_MAX)
-#define SCM_I_SIZE_MAX SCM_I_UTYPE_MAX(size_t)
-#define SCM_I_SSIZE_MIN SCM_I_TYPE_MIN(ssize_t,SCM_I_SIZE_MAX)
-#define SCM_I_SSIZE_MAX SCM_I_TYPE_MAX(ssize_t,SCM_I_SIZE_MAX)
-
\f
#include "libguile/tags.h"
#endif
\f
-#ifdef vms
-# ifndef CHEAP_CONTINUATIONS
- typedef int jmp_buf[17];
- extern int setjump(jmp_buf env);
- extern int longjump(jmp_buf env, int ret);
-# define setjmp setjump
-# define longjmp longjump
-# else
-# include <setjmp.h>
-# endif
-#else /* ndef vms */
-# ifdef _CRAY1
- typedef int jmp_buf[112];
- extern int setjump(jmp_buf env);
- extern int longjump(jmp_buf env, int ret);
-# define setjmp setjump
-# define longjmp longjump
-# else /* ndef _CRAY1 */
-# if defined (__ia64__)
-/* For IA64, emulate the setjmp API using getcontext. */
-# include <signal.h>
-# include <ucontext.h>
- typedef struct {
- ucontext_t ctx;
- int fresh;
- } scm_i_jmp_buf;
-# define SCM_I_SETJMP(JB) \
- ( (JB).fresh = 1, \
- getcontext (&((JB).ctx)), \
- ((JB).fresh ? ((JB).fresh = 0, 0) : 1) )
-# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
- void scm_ia64_longjmp (scm_i_jmp_buf *, int);
-# else /* ndef __ia64__ */
-# include <setjmp.h>
-# endif /* ndef __ia64__ */
-# endif /* ndef _CRAY1 */
-#endif /* ndef vms */
-
-/* For any platform where SCM_I_SETJMP hasn't been defined in some
- special way above, map SCM_I_SETJMP, SCM_I_LONGJMP and
- scm_i_jmp_buf to setjmp, longjmp and jmp_buf. */
-#ifndef SCM_I_SETJMP
-#define scm_i_jmp_buf jmp_buf
-#define SCM_I_SETJMP setjmp
-#define SCM_I_LONGJMP longjmp
-#endif
-/* James Clark came up with this neat one instruction fix for
- * continuations on the SPARC. It flushes the register windows so
- * that all the state of the process is contained in the stack.
+/* scm_i_jmp_buf
+ *
+ * The corresponding SCM_I_SETJMP and SCM_I_LONGJMP are defined in the
+ * _scm.h private header.
*/
-#if defined (sparc) || defined (__sparc__) || defined (__sparc)
-# define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3")
+#if defined (vms)
+typedef int scm_i_jmp_buf[17];
+
+#elif defined (_CRAY1)
+typedef int scm_i_jmp_buf[112];
+
+#elif defined (__ia64__)
+# include <signal.h>
+# include <ucontext.h>
+typedef struct {
+ ucontext_t ctx;
+ int fresh;
+} scm_i_jmp_buf;
+
#else
-# define SCM_FLUSH_REGISTER_WINDOWS /* empty */
+# include <setjmp.h>
+typedef jmp_buf scm_i_jmp_buf;
#endif
+
+\f
+
/* If stack is not longword aligned then
*/
#define SCM_STACK_PTR(ptr) ((SCM_STACKITEM *) (void *) (ptr))
\f
-SCM_API void scm_async_tick (void);
-
#ifdef BUILDING_LIBGUILE
-
-/* FIXME: should change names */
-# define SCM_ASYNC_TICK \
- do \
- { \
- if (SCM_UNLIKELY (SCM_I_CURRENT_THREAD->pending_asyncs)) \
- scm_async_click (); \
- } \
- while (0)
-
-/* SCM_ASYNC_TICK_WITH_CODE is only available to Guile itself */
-# define SCM_ASYNC_TICK_WITH_CODE(thr, stmt) \
- do \
- { \
- if (SCM_UNLIKELY (thr->pending_asyncs)) \
- { \
- stmt; \
- scm_async_click (); \
- } \
- } \
- while (0)
-
-#else /* !BUILDING_LIBGUILE */
-
-# define SCM_ASYNC_TICK (scm_async_tick ())
-
-#endif /* !BUILDING_LIBGUILE */
-
-
-/* Anthony Green writes:
- When the compiler sees...
- DEFER_INTS;
- [critical code here]
- ALLOW_INTS;
- ...it doesn't actually promise to keep the critical code within the
- boundries of the DEFER/ALLOW_INTS instructions. It may very well
- schedule it outside of the magic defined in those macros.
-
- However, GCC's volatile asm feature forms a barrier over which code is
- never moved. So if you add...
- asm ("");
- ...to each of the DEFER_INTS and ALLOW_INTS macros, the critical
- code will always remain in place. asm's without inputs or outputs
- are implicitly volatile. */
-#ifdef __GNUC__
-#define SCM_FENCE asm /* volatile */ ("")
-#elif defined (__INTEL_COMPILER) && defined (__ia64)
-#define SCM_FENCE __memory_barrier()
+#define SCM_TICK SCM_ASYNC_TICK
#else
-#define SCM_FENCE
+#define SCM_TICK scm_async_tick ()
#endif
-#define SCM_TICK \
-do { \
- SCM_ASYNC_TICK; \
- SCM_THREAD_SWITCHING_CODE; \
-} while (0)
-
\f
-/** SCM_ASSERT
- **
- **/
-
-
-#ifdef SCM_RECKLESS
-#define SCM_ASSERT(_cond, _arg, _pos, _subr)
-#define SCM_ASSERT_TYPE(_cond, _arg, _pos, _subr, _msg)
-#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
\f
-/* SCM_EXIT_SUCCESS is the default code to return from SCM if no errors
- * were encountered. SCM_EXIT_FAILURE is the default code to return from
- * SCM if errors were encountered. The return code can be explicitly
- * specified in a SCM program with (scm_quit <n>).
- */
-
-#ifndef SCM_EXIT_SUCCESS
-#ifdef vms
-#define SCM_EXIT_SUCCESS 1
-#else
-#define SCM_EXIT_SUCCESS 0
-#endif /* def vms */
-#endif /* ndef SCM_EXIT_SUCCESS */
-#ifndef SCM_EXIT_FAILURE
-#ifdef vms
-#define SCM_EXIT_FAILURE 2
-#else
-#define SCM_EXIT_FAILURE 1
-#endif /* def vms */
-#endif /* ndef SCM_EXIT_FAILURE */
-
/* Define SCM_C_INLINE_KEYWORD so that it can be used as a replacement
for the "inline" keyword, expanding to nothing when "inline" is not
available.
#define scm_from_off64_t scm_from_int64
+\f
+
+#if defined (vms)
+/* VMS: Implement SCM_I_SETJMP in terms of setjump. */
+extern int setjump(scm_i_jmp_buf env);
+extern int longjump(scm_i_jmp_buf env, int ret);
+#define SCM_I_SETJMP setjump
+#define SCM_I_LONGJMP longjump
+
+#elif defined (_CRAY1)
+/* Cray: Implement SCM_I_SETJMP in terms of setjump. */
+extern int setjump(scm_i_jmp_buf env);
+extern int longjump(scm_i_jmp_buf env, int ret);
+#define SCM_I_SETJMP setjump
+#define SCM_I_LONGJMP longjump
+
+#elif defined (__ia64__)
+/* IA64: Implement SCM_I_SETJMP in terms of getcontext. */
+# define SCM_I_SETJMP(JB) \
+ ( (JB).fresh = 1, \
+ getcontext (&((JB).ctx)), \
+ ((JB).fresh ? ((JB).fresh = 0, 0) : 1) )
+# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL)
+void scm_ia64_longjmp (scm_i_jmp_buf *, int);
+
+#else
+/* All other systems just use setjmp and longjmp. */
+
+#define SCM_I_SETJMP setjmp
+#define SCM_I_LONGJMP longjmp
+#endif
+
+\f
+
+#define SCM_ASYNC_TICK \
+ 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)
+
+
+\f
+
/* The endianness marker in objcode. */
#ifdef WORDS_BIGENDIAN
# define SCM_OBJCODE_ENDIANNESS "BE"
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
# include <config.h>
#endif
-#define SCM_BUILDING_DEPRECATED_CODE
-
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/throw.h"
/* System asyncs. */
void
-scm_async_click ()
+scm_async_tick (void)
{
scm_i_thread *t = SCM_I_CURRENT_THREAD;
SCM asyncs;
}
}
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
- (SCM thunk),
- "This function is deprecated. You can use @var{thunk} directly\n"
- "instead of explicitly creating an async object.\n")
-#define FUNC_NAME s_scm_system_async
-{
- scm_c_issue_deprecation_warning
- ("'system-async' is deprecated. "
- "Use the procedure directly with 'system-async-mark'.");
- return thunk;
-}
-#undef FUNC_NAME
-
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
-
void
scm_i_queue_async_cell (SCM c, scm_i_thread *t)
{
\f
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-SCM_DEFINE (scm_unmask_signals, "unmask-signals", 0, 0, 0,
- (),
- "Unmask signals. The returned value is not specified.")
-#define FUNC_NAME s_scm_unmask_signals
-{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
-
- scm_c_issue_deprecation_warning
- ("'unmask-signals' is deprecated. "
- "Use 'call-with-blocked-asyncs' instead.");
-
- if (t->block_asyncs == 0)
- SCM_MISC_ERROR ("signals already unmasked", SCM_EOL);
- t->block_asyncs = 0;
- scm_async_click ();
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_mask_signals, "mask-signals", 0, 0, 0,
- (),
- "Mask signals. The returned value is not specified.")
-#define FUNC_NAME s_scm_mask_signals
-{
- scm_i_thread *t = SCM_I_CURRENT_THREAD;
-
- scm_c_issue_deprecation_warning
- ("'mask-signals' is deprecated. Use 'call-with-blocked-asyncs' instead.");
-
- if (t->block_asyncs > 0)
- SCM_MISC_ERROR ("signals already masked", SCM_EOL);
- t->block_asyncs = 1;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
-
static void
increase_block (void *data)
{
{
scm_i_thread *t = data;
if (--t->block_asyncs == 0)
- scm_async_click ();
+ scm_async_tick ();
}
void
SCM_CRITICAL_SECTION_END;
}
-void
-scm_async_tick (void)
-{
- SCM_ASYNC_TICK;
-}
-
\f
void
#ifndef SCM_ASYNC_H
#define SCM_ASYNC_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
\f
-SCM_API void scm_async_click (void);
+SCM_API void scm_async_tick (void);
SCM_API void scm_switch (void);
SCM_API SCM scm_async (SCM thunk);
SCM_API SCM scm_async_mark (SCM a);
SCM_I_CURRENT_THREAD->critical_section_level--; \
SCM_I_CURRENT_THREAD->block_asyncs--; \
scm_i_pthread_mutex_unlock (&scm_i_critical_section_mutex); \
- scm_async_click (); \
+ scm_async_tick (); \
} while (0)
#else /* !BUILDING_LIBGUILE */
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 */
/*
SCM_SET_BYTEVECTOR_FLAGS ((bv), \
(hint) \
| (SCM_BYTEVECTOR_CONTIGUOUS_P (bv) << 8UL))
+#define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \
+ SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
+
#define SCM_BYTEVECTOR_TYPE_SIZE(var) \
(scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8)
#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \
if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST
|| scm_i_array_element_type_sizes[element_type] < 8
- || len >= (SCM_I_SIZE_MAX
+ || len >= (((size_t) -1)
/ (scm_i_array_element_type_sizes[element_type]/8))))
/* This would be an internal Guile programming error */
abort ();
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;
SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 0);
SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
+ SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F);
}
return ret;
return make_bytevector (len, element_type);
}
-/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
- by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
+/* Return a bytevector of size LEN made up of CONTENTS. The area
+ pointed to by CONTENTS must be protected from GC somehow: either
+ because it was allocated using `scm_gc_malloc ()', or because it is
+ part of PARENT. */
SCM
-scm_c_take_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
#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
/* 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;
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 *);
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). */
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;
#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
SCM_API SCM scm_debug_hang (SCM obj);
#endif /*GUILE_DEBUG*/
-#if SCM_ENABLE_DEPRECATED == 1
-
-#define CHECK_ENTRY scm_check_entry_p
-#define CHECK_APPLY scm_check_apply_p
-#define CHECK_EXIT scm_check_exit_p
-
-/* Deprecated in guile 1.7.0 on 2004-03-29. */
-#define SCM_DEBUGGINGP scm_debug_mode_p
-#define scm_debug_mode scm_debug_mode_p
-
-#endif
-
#endif /* SCM_DEBUG_H */
/*
-/* This file contains definitions for deprecated features. When you
- deprecate something, move it here when that is feasible.
-*/
-
-/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#define SCM_BUILDING_DEPRECATED_CODE
-
-#include "libguile/_scm.h"
-#include "libguile/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);
-}
-
-\f
-/* Networking. */
-
-#ifdef HAVE_NETWORKING
-
-SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0,
- (SCM address),
- "Convert an IPv4 Internet address from printable string\n"
- "(dotted decimal notation) to an integer. E.g.,\n\n"
- "@lisp\n"
- "(inet-aton \"127.0.0.1\") @result{} 2130706433\n"
- "@end lisp")
-#define FUNC_NAME s_scm_inet_aton
-{
- scm_c_issue_deprecation_warning
- ("`inet-aton' is deprecated. Use `inet-pton' instead.");
-
- return scm_inet_pton (scm_from_int (AF_INET), address);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0,
- (SCM inetid),
- "Convert an IPv4 Internet address to a printable\n"
- "(dotted decimal notation) string. E.g.,\n\n"
- "@lisp\n"
- "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n"
- "@end lisp")
-#define FUNC_NAME s_scm_inet_ntoa
-{
- scm_c_issue_deprecation_warning
- ("`inet-ntoa' is deprecated. Use `inet-ntop' instead.");
-
- return scm_inet_ntop (scm_from_int (AF_INET), inetid);
-}
-#undef FUNC_NAME
-
-#endif /* HAVE_NETWORKING */
-
-\f
-void
-scm_i_defer_ints_etc ()
-{
- scm_c_issue_deprecation_warning
- ("SCM_DEFER_INTS etc are deprecated. "
- "Use a mutex instead if appropriate.");
-}
-
-int
-scm_i_mask_ints (void)
-{
- scm_c_issue_deprecation_warning ("`scm_mask_ints' is deprecated.");
- return (SCM_I_CURRENT_THREAD->block_asyncs != 0);
-}
-
-\f
-SCM
-scm_guard (SCM guardian, SCM obj, int throw_p)
-{
- scm_c_issue_deprecation_warning
- ("scm_guard is deprecated. Use scm_call_1 instead.");
-
- return scm_call_1 (guardian, obj);
-}
-
-SCM
-scm_get_one_zombie (SCM guardian)
-{
- scm_c_issue_deprecation_warning
- ("scm_guard is deprecated. Use scm_call_0 instead.");
-
- return scm_call_0 (guardian);
-}
-
-SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0,
- (SCM guardian),
- "Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.")
-#define FUNC_NAME s_scm_guardian_destroyed_p
-{
- scm_c_issue_deprecation_warning
- ("'guardian-destroyed?' is deprecated.");
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_guardian_greedy_p, "guardian-greedy?", 1, 0, 0,
- (SCM guardian),
- "Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.")
-#define FUNC_NAME s_scm_guardian_greedy_p
-{
- scm_c_issue_deprecation_warning
- ("'guardian-greedy?' is deprecated.");
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0,
- (SCM guardian),
- "Destroys @var{guardian}, by making it impossible to put any more\n"
- "objects in it or get any objects from it. It also unguards any\n"
- "objects guarded by @var{guardian}.")
-#define FUNC_NAME s_scm_destroy_guardian_x
-{
- scm_c_issue_deprecation_warning
- ("'destroy-guardian!' is deprecated and ineffective.");
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-\f
-/* GC-related things. */
-
-unsigned long scm_mallocated, scm_mtrigger;
-size_t scm_max_segment_size;
-
-#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
-SCM
-scm_map_free_list (void)
-{
- return SCM_EOL;
-}
-#endif
-
-#if defined (GUILE_DEBUG_FREELIST)
-SCM
-scm_gc_set_debug_check_freelist_x (SCM flag)
-{
- return SCM_UNSPECIFIED;
-}
-#endif
-
-\f
-/* Trampolines
- *
- * Trampolines were an intent to speed up calling the same Scheme procedure many
- * times from C.
- *
- * However, this was the wrong thing to optimize; if you really know what you're
- * calling, call its function directly, otherwise you're in Scheme-land, and we
- * have many better tricks there (inlining, for example, which can remove the
- * need for closures and free variables).
- *
- * Also, in the normal debugging case, trampolines were being computed but not
- * used. Silliness.
- */
-
-scm_t_trampoline_0
-scm_trampoline_0 (SCM proc)
-{
- scm_c_issue_deprecation_warning
- ("`scm_trampoline_0' is deprecated. Just use `scm_call_0' instead.");
- return scm_call_0;
-}
-
-scm_t_trampoline_1
-scm_trampoline_1 (SCM proc)
-{
- scm_c_issue_deprecation_warning
- ("`scm_trampoline_1' is deprecated. Just use `scm_call_1' instead.");
- return scm_call_1;
-}
-
-scm_t_trampoline_2
-scm_trampoline_2 (SCM proc)
-{
- scm_c_issue_deprecation_warning
- ("`scm_trampoline_2' is deprecated. Just use `scm_call_2' instead.");
- return scm_call_2;
-}
-
-int
-scm_i_subr_p (SCM x)
-{
- scm_c_issue_deprecation_warning ("`scm_subr_p' is deprecated. Use SCM_PRIMITIVE_P instead.");
- return SCM_PRIMITIVE_P (x);
-}
-
-\f
-
-SCM
-scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
-{
- scm_c_issue_deprecation_warning
- ("`scm_internal_lazy_catch' is no longer supported. Instead this call will\n"
- "dispatch to `scm_c_with_throw_handler'. Your handler will be invoked from\n"
- "within the dynamic context of the corresponding `throw'.\n"
- "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
- "Please modify your program to use `scm_c_with_throw_handler' directly,\n"
- "and adapt it (if necessary) to expect to be within the dynamic context\n"
- "of the throw.");
- return scm_c_with_throw_handler (tag, body, body_data, handler, handler_data, 0);
-}
-
-SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
- (SCM key, SCM thunk, SCM handler),
- "This behaves exactly like @code{catch}, except that it does\n"
- "not unwind the stack before invoking @var{handler}.\n"
- "If the @var{handler} procedure returns normally, Guile\n"
- "rethrows the same exception again to the next innermost catch,\n"
- "lazy-catch or throw handler. If the @var{handler} exits\n"
- "non-locally, that exit determines the continuation.")
-#define FUNC_NAME s_scm_lazy_catch
-{
- struct scm_body_thunk_data c;
-
- SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
- key, SCM_ARG1, FUNC_NAME);
-
- c.tag = key;
- c.body_proc = thunk;
-
- scm_c_issue_deprecation_warning
- ("`lazy-catch' is no longer supported. Instead this call will dispatch\n"
- "to `with-throw-handler'. Your handler will be invoked from within the\n"
- "dynamic context of the corresponding `throw'.\n"
- "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
- "Please modify your program to use `with-throw-handler' directly, and\n"
- "adapt it (if necessary) to expect to be within the dynamic context of\n"
- "the throw.");
-
- return scm_c_with_throw_handler (key,
- scm_body_thunk, &c,
- scm_handle_by_proc, &handler, 0);
-}
-#undef FUNC_NAME
-
-
-\f
-
-
-SCM
-scm_raequal (SCM ra0, SCM ra1)
-{
- return scm_array_equal_p (ra0, ra1);
-}
-
-
-\f
-
-
-SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
- (SCM func, SCM dobj, SCM args),
- "Call the C function indicated by @var{func} and @var{dobj},\n"
- "just like @code{dynamic-call}, but pass it some arguments and\n"
- "return its return value. The C function is expected to take\n"
- "two arguments and return an @code{int}, just like @code{main}:\n"
- "@smallexample\n"
- "int c_func (int argc, char **argv);\n"
- "@end smallexample\n\n"
- "The parameter @var{args} must be a list of strings and is\n"
- "converted into an array of @code{char *}. The array is passed\n"
- "in @var{argv} and its size in @var{argc}. The return value is\n"
- "converted to a Scheme number and returned from the call to\n"
- "@code{dynamic-args-call}.")
-#define FUNC_NAME s_scm_dynamic_args_call
-{
- int (*fptr) (int argc, char **argv);
- int result, argc;
- char **argv;
-
- if (scm_is_string (func))
- 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
-
-
-\f
-
-
-int
-scm_badargsp (SCM formals, SCM args)
-{
- scm_c_issue_deprecation_warning
- ("`scm_badargsp' is deprecated. Copy it into your project if you need it.");
-
- while (!scm_is_null (formals))
- {
- if (!scm_is_pair (formals))
- return 0;
- if (scm_is_null (args))
- return 1;
- formals = scm_cdr (formals);
- args = scm_cdr (args);
- }
- return !scm_is_null (args) ? 1 : 0;
-}
-
-\f
-
-/* scm_internal_stack_catch
- Use this one if you want debugging information to be stored in
- the-last-stack on error. */
-
-static SCM
-ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args)
-{
- /* In the stack */
- scm_fluid_set_x (scm_variable_ref
- (scm_c_module_lookup
- (scm_c_resolve_module ("ice-9 save-stack"),
- "the-last-stack")),
- scm_make_stack (SCM_BOOL_T, SCM_EOL));
- /* Throw the error */
- return scm_throw (tag, throw_args);
-}
-
-struct cwss_data
-{
- SCM tag;
- scm_t_catch_body body;
- void *data;
-};
-
-static SCM
-cwss_body (void *data)
-{
- struct cwss_data *d = data;
- return scm_c_with_throw_handler (d->tag, d->body, d->data, ss_handler, NULL, 0);
-}
-
-SCM
-scm_internal_stack_catch (SCM tag,
- scm_t_catch_body body,
- void *body_data,
- scm_t_catch_handler handler,
- void *handler_data)
-{
- struct cwss_data d;
- d.tag = tag;
- d.body = body;
- d.data = body_data;
- scm_c_issue_deprecation_warning
- ("`scm_internal_stack_catch' is deprecated. Talk to guile-devel if you see this message.");
- return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
-}
-
-\f
-
-SCM
-scm_short2num (short x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_short2num' is deprecated. Use scm_from_short instead.");
- return scm_from_short (x);
-}
-
-SCM
-scm_ushort2num (unsigned short x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_ushort2num' is deprecated. Use scm_from_ushort instead.");
- return scm_from_ushort (x);
-}
-
-SCM
-scm_int2num (int x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_int2num' is deprecated. Use scm_from_int instead.");
- return scm_from_int (x);
-}
-
-SCM
-scm_uint2num (unsigned int x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_uint2num' is deprecated. Use scm_from_uint instead.");
- return scm_from_uint (x);
-}
-
-SCM
-scm_long2num (long x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_long2num' is deprecated. Use scm_from_long instead.");
- return scm_from_long (x);
-}
-
-SCM
-scm_ulong2num (unsigned long x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_ulong2num' is deprecated. Use scm_from_ulong instead.");
- return scm_from_ulong (x);
-}
-
-SCM
-scm_size2num (size_t x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_size2num' is deprecated. Use scm_from_size_t instead.");
- return scm_from_size_t (x);
-}
-
-SCM
-scm_ptrdiff2num (ptrdiff_t x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_ptrdiff2num' is deprecated. Use scm_from_ssize_t instead.");
- return scm_from_ssize_t (x);
-}
-
-short
-scm_num2short (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2short' is deprecated. Use scm_to_short instead.");
- return scm_to_short (x);
-}
-
-unsigned short
-scm_num2ushort (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2ushort' is deprecated. Use scm_to_ushort instead.");
- return scm_to_ushort (x);
-}
-
-int
-scm_num2int (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2int' is deprecated. Use scm_to_int instead.");
- return scm_to_int (x);
-}
-
-unsigned int
-scm_num2uint (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2uint' is deprecated. Use scm_to_uint instead.");
- return scm_to_uint (x);
-}
-
-long
-scm_num2long (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2long' is deprecated. Use scm_to_long instead.");
- return scm_to_long (x);
-}
-
-unsigned long
-scm_num2ulong (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2ulong' is deprecated. Use scm_to_ulong instead.");
- return scm_to_ulong (x);
-}
-
-size_t
-scm_num2size (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2size' is deprecated. Use scm_to_size_t instead.");
- return scm_to_size_t (x);
-}
-
-ptrdiff_t
-scm_num2ptrdiff (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2ptrdiff' is deprecated. Use scm_to_ssize_t instead.");
- return scm_to_ssize_t (x);
-}
-
-#if SCM_SIZEOF_LONG_LONG != 0
-
-SCM
-scm_long_long2num (long long x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_long_long2num' is deprecated. Use scm_from_long_long instead.");
- return scm_from_long_long (x);
-}
-
-SCM
-scm_ulong_long2num (unsigned long long x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_ulong_long2num' is deprecated. Use scm_from_ulong_long instead.");
- return scm_from_ulong_long (x);
-}
-
-long long
-scm_num2long_long (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2long_long' is deprecated. Use scm_to_long_long instead.");
- return scm_to_long_long (x);
-}
-
-unsigned long long
-scm_num2ulong_long (SCM x, unsigned long pos, const char *s_caller)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2ulong_long' is deprecated. Use scm_from_ulong_long instead.");
- return scm_to_ulong_long (x);
-}
-
-#endif
-
-SCM
-scm_make_real (double x)
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_real' is deprecated. Use scm_from_double instead.");
- return scm_from_double (x);
-}
-
-double
-scm_num2dbl (SCM a, const char *why)
-{
- scm_c_issue_deprecation_warning
- ("`scm_num2dbl' is deprecated. Use scm_to_double instead.");
- return scm_to_double (a);
-}
-
-SCM
-scm_float2num (float n)
-{
- scm_c_issue_deprecation_warning
- ("`scm_float2num' is deprecated. Use scm_from_double instead.");
- return scm_from_double ((double) n);
-}
-
-SCM
-scm_double2num (double n)
-{
- scm_c_issue_deprecation_warning
- ("`scm_double2num' is deprecated. Use scm_from_double instead.");
- return scm_from_double (n);
-}
-
-SCM
-scm_make_complex (double x, double y)
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_complex' is deprecated. Use scm_c_make_rectangular instead.");
- return scm_c_make_rectangular (x, y);
-}
-
-SCM
-scm_mem2symbol (const char *mem, size_t len)
-{
- scm_c_issue_deprecation_warning
- ("`scm_mem2symbol' is deprecated. Use scm_from_locale_symboln instead.");
- return scm_from_locale_symboln (mem, len);
-}
-
-SCM
-scm_mem2uninterned_symbol (const char *mem, size_t len)
-{
- scm_c_issue_deprecation_warning
- ("`scm_mem2uninterned_symbol' is deprecated. "
- "Use scm_make_symbol and scm_from_locale_symboln instead.");
- return scm_make_symbol (scm_from_locale_stringn (mem, len));
-}
-
-SCM
-scm_str2symbol (const char *str)
-{
- scm_c_issue_deprecation_warning
- ("`scm_str2symbol' is deprecated. Use scm_from_locale_symbol instead.");
- return scm_from_locale_symbol (str);
-}
-
-
-/* This function must only be applied to memory obtained via malloc,
- since the GC is going to apply `free' to it when the string is
- dropped.
-
- Also, s[len] must be `\0', since we promise that strings are
- null-terminated. Perhaps we could handle non-null-terminated
- strings by claiming they're shared substrings of a string we just
- made up. */
-SCM
-scm_take_str (char *s, size_t len)
-{
- scm_c_issue_deprecation_warning
- ("`scm_take_str' is deprecated. Use scm_take_locale_stringn instead.");
- return scm_take_locale_stringn (s, len);
-}
-
-/* `s' must be a malloc'd string. See scm_take_str. */
-SCM
-scm_take0str (char *s)
-{
- scm_c_issue_deprecation_warning
- ("`scm_take0str' is deprecated. Use scm_take_locale_string instead.");
- return scm_take_locale_string (s);
-}
-
-SCM
-scm_mem2string (const char *src, size_t len)
-{
- scm_c_issue_deprecation_warning
- ("`scm_mem2string' is deprecated. Use scm_from_locale_stringn instead.");
- return scm_from_locale_stringn (src, len);
-}
-
-SCM
-scm_str2string (const char *src)
-{
- scm_c_issue_deprecation_warning
- ("`scm_str2string' is deprecated. Use scm_from_locale_string instead.");
- return scm_from_locale_string (src);
-}
-
-SCM
-scm_makfrom0str (const char *src)
-{
- scm_c_issue_deprecation_warning
- ("`scm_makfrom0str' is deprecated."
- "Use scm_from_locale_string instead, but check for NULL first.");
- if (!src) return SCM_BOOL_F;
- return scm_from_locale_string (src);
-}
-
-SCM
-scm_makfrom0str_opt (const char *src)
-{
- scm_c_issue_deprecation_warning
- ("`scm_makfrom0str_opt' is deprecated."
- "Use scm_from_locale_string instead, but check for NULL first.");
- return scm_makfrom0str (src);
-}
-
-
-SCM
-scm_allocate_string (size_t len)
-{
- scm_c_issue_deprecation_warning
- ("`scm_allocate_string' is deprecated. Use scm_c_make_string instead.");
- return scm_i_make_string (len, NULL, 0);
-}
-
-SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0,
- (SCM symbol),
- "Make a keyword object from a @var{symbol} that starts with a dash.")
-#define FUNC_NAME s_scm_make_keyword_from_dash_symbol
-{
- SCM dash_string, non_dash_symbol;
-
- scm_c_issue_deprecation_warning
- ("`scm_make_keyword_from_dash_symbol' is deprecated. Don't use dash symbols.");
-
- SCM_ASSERT (scm_is_symbol (symbol)
- && (scm_i_symbol_ref (symbol, 0) == '-'),
- symbol, SCM_ARG1, FUNC_NAME);
-
- dash_string = scm_symbol_to_string (symbol);
- non_dash_symbol =
- scm_string_to_symbol (scm_c_substring (dash_string,
- 1,
- scm_c_string_length (dash_string)));
-
- return scm_symbol_to_keyword (non_dash_symbol);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0,
- (SCM keyword),
- "Return the dash symbol for @var{keyword}.\n"
- "This is the inverse of @code{make-keyword-from-dash-symbol}.")
-#define FUNC_NAME s_scm_keyword_dash_symbol
-{
- SCM symbol = scm_keyword_to_symbol (keyword);
- SCM parts = scm_list_2 (scm_from_locale_string ("-"),
- scm_symbol_to_string (symbol));
- scm_c_issue_deprecation_warning
- ("`scm_keyword_dash_symbol' is deprecated. Don't use dash symbols.");
-
- return scm_string_to_symbol (scm_string_append (parts));
-}
-#undef FUNC_NAME
-
-SCM
-scm_c_make_keyword (const char *s)
-{
- scm_c_issue_deprecation_warning
- ("`scm_c_make_keyword' is deprecated. Use scm_from_locale_keyword instead.");
- return scm_from_locale_keyword (s);
-}
-
-unsigned int
-scm_thread_sleep (unsigned int t)
-{
- scm_c_issue_deprecation_warning
- ("`scm_thread_sleep' is deprecated. Use scm_std_sleep instead.");
- return scm_std_sleep (t);
-}
-
-unsigned long
-scm_thread_usleep (unsigned long t)
-{
- scm_c_issue_deprecation_warning
- ("`scm_thread_usleep' is deprecated. Use scm_std_usleep instead.");
- return scm_std_usleep (t);
-}
-
-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);
-}
-
-\f
-
-#ifdef HAVE_CUSERID
-
-# if !HAVE_DECL_CUSERID
-extern char *cuserid (char *);
-# endif
-
-SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
- (void),
- "Return a string containing a user name associated with the\n"
- "effective user id of the process. Return @code{#f} if this\n"
- "information cannot be obtained.")
-#define FUNC_NAME s_scm_cuserid
-{
- char buf[L_cuserid];
- char * p;
-
- scm_c_issue_deprecation_warning
- ("`cuserid' is deprecated. Use `(passwd:name (getpwuid (geteuid)))' instead.");
-
- p = cuserid (buf);
- if (!p || !*p)
- return SCM_BOOL_F;
- return scm_from_locale_string (p);
-}
-#undef FUNC_NAME
-#endif /* HAVE_CUSERID */
-
-\f
-
-/* {Properties}
- */
-
-static SCM properties_whash;
-
-SCM_DEFINE (scm_primitive_make_property, "primitive-make-property", 1, 0, 0,
- (SCM not_found_proc),
- "Create a @dfn{property token} that can be used with\n"
- "@code{primitive-property-ref} and @code{primitive-property-set!}.\n"
- "See @code{primitive-property-ref} for the significance of\n"
- "@var{not_found_proc}.")
-#define FUNC_NAME s_scm_primitive_make_property
-{
- scm_c_issue_deprecation_warning
- ("`primitive-make-property' is deprecated. Use object properties.");
-
- if (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
-
-\f
-
-SCM
-scm_whash_get_handle (SCM whash, SCM key)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- return scm_hashq_get_handle (whash, key);
-}
-
-int
-SCM_WHASHFOUNDP (SCM h)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- return scm_is_true (h);
-}
-
-SCM
-SCM_WHASHREF (SCM whash, SCM handle)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- return SCM_CDR (handle);
-}
-
-void
-SCM_WHASHSET (SCM whash, SCM handle, SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- SCM_SETCDR (handle, obj);
-}
-
-SCM
-scm_whash_create_handle (SCM whash, SCM key)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- return scm_hashq_create_handle_x (whash, key, SCM_UNSPECIFIED);
-}
-
-SCM
-scm_whash_lookup (SCM whash, SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- return scm_hashq_ref (whash, obj, SCM_BOOL_F);
-}
-
-void
-scm_whash_insert (SCM whash, SCM key, SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("The `scm_whash' API is deprecated. Use the `scm_hashq' API instead.");
-
- scm_hashq_set_x (whash, key, obj);
-}
-
-\f
-
-SCM scm_struct_table = SCM_BOOL_F;
-
-SCM
-scm_struct_create_handle (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("`scm_struct_create_handle' is deprecated, and has no effect.");
-
- return scm_cons (obj, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
-}
-
-\f
-
-SCM
-scm_internal_dynamic_wind (scm_t_guard before,
- scm_t_inner inner,
- scm_t_guard after,
- void *inner_data,
- void *guard_data)
-{
- SCM ans;
-
- scm_c_issue_deprecation_warning
- ("`scm_internal_dynamic_wind' is deprecated. "
- "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
-
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
- ans = inner (inner_data);
- scm_dynwind_end ();
- return ans;
-}
-
-\f
-
-SCM
-scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
-{
- scm_c_issue_deprecation_warning
- ("scm_immutable_cell is deprecated. Use scm_cell instead.");
-
- return scm_cell (car, cdr);
-}
-
-SCM
-scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
- scm_t_bits ccr, scm_t_bits cdr)
-{
- scm_c_issue_deprecation_warning
- ("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
-
- return scm_double_cell (car, cbr, ccr, cdr);
-}
-
-
-\f
-
-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"
-}
-
-#endif
+/* This file contains definitions for deprecated features. When you
+ deprecate something, move it here when that is feasible.
+*/
+
+/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#define SCM_BUILDING_DEPRECATED_CODE
+
+#include "libguile/_scm.h"
+#include "libguile/deprecation.h"
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+\f
+
+SCM
+scm_internal_dynamic_wind (scm_t_guard before,
+ scm_t_inner inner,
+ scm_t_guard after,
+ void *inner_data,
+ void *guard_data)
+{
+ SCM ans;
+
+ scm_c_issue_deprecation_warning
+ ("`scm_internal_dynamic_wind' is deprecated. "
+ "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
+ ans = inner (inner_data);
+ scm_dynwind_end ();
+ return ans;
+}
+
+\f
+
+SCM
+scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_immutable_cell is deprecated. Use scm_cell instead.");
+
+ return scm_cell (car, cdr);
+}
+
+SCM
+scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
+
+ return scm_double_cell (car, cbr, ccr, cdr);
+}
+
+
+\f
+
+void
+scm_i_init_deprecated ()
+{
+#include "libguile/deprecated.x"
+}
+
+#endif
-/* This file contains definitions for deprecated features. When you
- deprecate something, move it here when that is feasible.
-*/
-
-#ifndef SCM_DEPRECATED_H
-#define SCM_DEPRECATED_H
-
-/* Copyright (C) 2003,2004, 2005, 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#include "libguile/__scm.h"
-#include "libguile/strings.h"
-#include "libguile/eval.h"
-#include "libguile/throw.h"
-#include "libguile/iselect.h"
-
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-/* From eval.h: Macros for handling ilocs. These were deprecated in guile
- * 1.7.0 on 2004-04-22. */
-#define SCM_IFRINC (0x00000100L)
-#define SCM_ICDR (0x00080000L)
-#define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
- & (SCM_UNPACK (n) >> 8))
-#define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
-#define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
-
-
-/* From tags.h: Macros to access internal symbol names of isyms. Deprecated
- * in guile 1.7.0 on 2004-04-22. */
-SCM_API char *scm_isymnames[];
-#define SCM_ISYMNUM(n) 0
-#define SCM_ISYMCHARS(n) "#@<deprecated>"
-
-
-/* From tags.h: Macro checking for two tc16 types that are allocated to differ
- * only in the 's'-bit. Deprecated in guile 1.7.0 on 2003-09-21. */
-#define SCM_TYP16S(x) (0xfeff & SCM_CELL_TYPE (x))
-
-
-/* From numbers.h: Macros checking for types, but avoiding a redundant check
- * for !SCM_IMP. These were deprecated in guile 1.7.0 on 2003-09-06. */
-#define SCM_SLOPPY_INEXACTP(x) (SCM_TYP16S (x) == scm_tc16_real)
-#define SCM_SLOPPY_REALP(x) (SCM_TYP16 (x) == scm_tc16_real)
-#define SCM_SLOPPY_COMPLEXP(x) (SCM_TYP16 (x) == scm_tc16_complex)
-
-
-/* From structs.h:
- Deprecated in Guile 1.9.5 on 2009-11-03. */
-#define scm_vtable_index_vtable scm_vtable_index_self
-#define scm_vtable_index_printer scm_vtable_index_instance_printer
-#define scm_struct_i_free scm_vtable_index_instance_finalize
-#define scm_struct_i_flags scm_vtable_index_flags
-#define SCM_STRUCTF_MASK ((scm_t_bits)-1)
-#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA(x)[scm_struct_i_free]=(scm_t_bits)(D))
-
-#define scm_substring_move_left_x scm_substring_move_x
-#define scm_substring_move_right_x scm_substring_move_x
-
-#define scm_sizet size_t
-
-SCM_DEPRECATED SCM scm_wta (SCM arg, const char *pos, const char *s_subr);
-
-#define SCM_WNA 8
-#define SCM_OUTOFRANGE 10
-#define SCM_NALLOC 11
-
-SCM_DEPRECATED void scm_register_module_xxx (char *module_name, void *init_func);
-SCM_DEPRECATED SCM scm_registered_modules (void);
-SCM_DEPRECATED SCM scm_clear_registered_modules (void);
-
-SCM_DEPRECATED SCM scm_protect_object (SCM obj);
-SCM_DEPRECATED SCM scm_unprotect_object (SCM obj);
-
-#define SCM_SETAND_CAR(x, y) \
- (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) & (y))))
-#define SCM_SETOR_CAR(x, y)\
- (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) | (y))))
-#define SCM_SETAND_CDR(x, y)\
- (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) & (y))))
-#define SCM_SETOR_CDR(x, y)\
- (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) | (y))))
-#define SCM_FREEP(x) (0)
-#define SCM_NFREEP(x) (1)
-#define SCM_GCTYP16(x) SCM_TYP16 (x)
-#define SCM_GCCDR(x) SCM_CDR (x)
-SCM_DEPRECATED void scm_remember (SCM * ptr);
-
-SCM_DEPRECATED SCM scm_make_module (SCM name);
-SCM_DEPRECATED SCM scm_ensure_user_module (SCM name);
-SCM_DEPRECATED SCM scm_load_scheme_module (SCM name);
-
-#define scm_port scm_t_port
-#define scm_ptob_descriptor scm_t_ptob_descriptor
-#define scm_port_rw_active scm_t_port_rw_active
-
-SCM_DEPRECATED SCM scm_close_all_ports_except (SCM ports);
-
-#define scm_rstate scm_t_rstate
-#define scm_rng scm_t_rng
-
-#define SCM_SLOPPY_CONSP(x) ((1 & SCM_CELL_TYPE (x)) == 0)
-#define SCM_SLOPPY_NCONSP(x) (!SCM_SLOPPY_CONSP(x))
-
-#define scm_tc7_ssymbol scm_tc7_symbol
-#define scm_tc7_msymbol scm_tc7_symbol
-#define scm_tcs_symbols scm_tc7_symbol
-
-SCM_DEPRECATED SCM scm_makstr (size_t len, int);
-SCM_DEPRECATED SCM scm_makfromstr (const char *src, size_t len, int);
-
-SCM_DEPRECATED SCM scm_variable_set_name_hint (SCM var, SCM hint);
-SCM_DEPRECATED SCM scm_builtin_variable (SCM name);
-
-SCM_DEPRECATED SCM scm_internal_with_fluids (SCM fluids, SCM vals,
- SCM (*cproc)(void *),
- void *cdata);
-
-SCM_DEPRECATED SCM scm_make_gsubr (const char *name,
- int req, int opt, int rst,
- scm_t_subr fcn);
-SCM_DEPRECATED SCM scm_make_gsubr_with_generic (const char *name,
- int req,
- int opt,
- int rst,
- scm_t_subr fcn,
- SCM *gf);
-
-SCM_DEPRECATED SCM scm_create_hook (const char* name, int n_args);
-
-
-/* Deprecated 13-05-2011 because it's better just to scm_dynwind_begin.
- That also avoids the temptation to stuff pointers in an SCM. */
-
-typedef SCM (*scm_t_inner) (void *);
-SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before,
- scm_t_inner inner,
- scm_t_guard after,
- void *inner_data,
- void *guard_data);
-
-#define SCM_LIST0 SCM_EOL
-#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)
-#define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL)
-#define SCM_LIST3(e0, e1, e2) scm_cons ((e0), SCM_LIST2 ((e1), (e2)))
-#define SCM_LIST4(e0, e1, e2, e3)\
- scm_cons2 ((e0), (e1), SCM_LIST2 ((e2), (e3)))
-#define SCM_LIST5(e0, e1, e2, e3, e4)\
- scm_cons ((e0), SCM_LIST4 ((e1), (e2), (e3), (e4)))
-#define SCM_LIST6(e0, e1, e2, e3, e4, e5)\
- scm_cons2 ((e0), (e1), SCM_LIST4 ((e2), (e3), (e4), (e5)))
-#define SCM_LIST7(e0, e1, e2, e3, e4, e5, e6)\
- scm_cons ((e0), SCM_LIST6 ((e1), (e2), (e3), (e4), (e5), (e6)))
-#define SCM_LIST8(e0, e1, e2, e3, e4, e5, e6, e7)\
- scm_cons2 ((e0), (e1), SCM_LIST6 ((e2), (e3), (e4), (e5), (e6), (e7)))
-#define SCM_LIST9(e0, e1, e2, e3, e4, e5, e6, e7, e8)\
- scm_cons ((e0),\
- SCM_LIST8 ((e1), (e2), (e3), (e4), (e5), (e6), (e7), (e8)))
-
-#define scm_listify scm_list_n
-
-SCM_DEPRECATED SCM scm_sloppy_memq (SCM x, SCM lst);
-SCM_DEPRECATED SCM scm_sloppy_memv (SCM x, SCM lst);
-SCM_DEPRECATED SCM scm_sloppy_member (SCM x, SCM lst);
-
-SCM_DEPRECATED SCM scm_read_and_eval_x (SCM port);
-
-#define scm_subr_entry scm_t_subr_entry
-
-#define SCM_SUBR_DOC(x) SCM_BOOL_F
-
-SCM_DEPRECATED SCM scm_call_catching_errors (scm_t_subr thunk,
- scm_t_subr err_filter,
- void * closure);
-
-SCM_DEPRECATED long scm_make_smob_type_mfpe (char *name, size_t size,
- SCM (*mark) (SCM),
- size_t (*free) (SCM),
- int (*print) (SCM, SCM,
- scm_print_state*),
- SCM (*equalp) (SCM, SCM));
-
-SCM_DEPRECATED void scm_set_smob_mfpe (long tc,
- SCM (*mark) (SCM),
- size_t (*free) (SCM),
- int (*print) (SCM, SCM, scm_print_state*),
- SCM (*equalp) (SCM, SCM));
-
-SCM_DEPRECATED size_t scm_smob_free (SCM obj);
-
-SCM_DEPRECATED SCM scm_strprint_obj (SCM obj);
-SCM_DEPRECATED SCM scm_read_0str (char *expr);
-SCM_DEPRECATED SCM scm_eval_0str (const char *expr);
-
-SCM_DEPRECATED char *scm_i_object_chars (SCM);
-
-#define SCM_CHARS(x) scm_i_object_chars(x)
-#define SCM_UCHARS(x) ((unsigned char *)SCM_CHARS(x))
-
-SCM_DEPRECATED long scm_i_object_length (SCM);
-
-#define SCM_LENGTH(x) scm_i_object_length(x)
-
-#define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n))
-
-SCM_DEPRECATED SCM scm_sym2ovcell_soft (SCM sym, SCM obarray);
-SCM_DEPRECATED SCM scm_sym2ovcell (SCM sym, SCM obarray);
-SCM_DEPRECATED SCM scm_intern_obarray_soft (const char *name, size_t len,
- SCM obarray, unsigned int softness);
-SCM_DEPRECATED SCM scm_intern_obarray (const char *name, size_t len, SCM obarray);
-SCM_DEPRECATED SCM scm_symbol_value0 (const char *name);
-
-SCM_DEPRECATED SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp);
-SCM_DEPRECATED SCM scm_intern_symbol (SCM o, SCM s);
-SCM_DEPRECATED SCM scm_unintern_symbol (SCM o, SCM s);
-SCM_DEPRECATED SCM scm_symbol_binding (SCM o, SCM s);
-#if 0
-/* This name has been reused for real uninterned symbols. */
-SCM_DEPRECATED SCM scm_symbol_interned_p (SCM o, SCM s);
-#endif
-SCM_DEPRECATED SCM scm_symbol_bound_p (SCM o, SCM s);
-SCM_DEPRECATED SCM scm_symbol_set_x (SCM o, SCM s, SCM v);
-
-SCM_DEPRECATED SCM scm_gentemp (SCM prefix, SCM obarray);
-
-#define SCM_OPDIRP(x) (SCM_DIRP (x) && (SCM_DIR_OPEN_P (x)))
-#define scm_fport scm_t_fport
-#define scm_option scm_t_option
-#define scm_srcprops scm_t_srcprops
-#define scm_srcprops_chunk scm_t_srcprops_chunk
-#define scm_array scm_t_array
-#define scm_array_dim scm_t_array_dim
-#define SCM_FUNC_NAME (scm_makfrom0str (FUNC_NAME))
-
-#define SCM_WTA(pos, scm) \
- do { scm_wta (scm, (char *) pos, FUNC_NAME); } while (0)
-
-#define RETURN_SCM_WTA(pos, scm) \
- do { return scm_wta (scm, (char *) pos, FUNC_NAME); } while (0)
-
-#define SCM_VALIDATE_NUMBER_COPY(pos, z, cvar) \
- do { \
- if (SCM_I_INUMP (z)) \
- cvar = (double) SCM_I_INUM (z); \
- else if (SCM_REALP (z)) \
- cvar = SCM_REAL_VALUE (z); \
- else if (SCM_BIGP (z)) \
- cvar = scm_i_big2dbl (z); \
- else \
- { \
- cvar = 0.0; \
- SCM_WRONG_TYPE_ARG (pos, z); \
- } \
- } while (0)
-
-#define SCM_VALIDATE_NUMBER_DEF_COPY(pos, number, def, cvar) \
- do { \
- if (SCM_UNBNDP (number)) \
- cvar = def; \
- else \
- SCM_VALIDATE_NUMBER_COPY(pos, number, cvar); \
- } while (0)
-
-#define SCM_VALIDATE_OPDIR(pos, port) SCM_MAKE_VALIDATE (pos, port, OPDIRP)
-
-/* Deprecated because we can not safely cast a SCM* to a scm_t_bits*
- */
-
-#define SCM_CELL_WORD_LOC(x, n) ((scm_t_bits*)SCM_CELL_OBJECT_LOC((x),(n)))
-
-/* Users shouldn't know about INUMs.
- */
-
-SCM_DEPRECATED SCM scm_i_makinum (scm_t_signed_bits val);
-SCM_DEPRECATED int scm_i_inump (SCM obj);
-SCM_DEPRECATED scm_t_signed_bits scm_i_inum (SCM obj);
-
-#define SCM_MAKINUM(x) scm_i_makinum(x)
-#define SCM_INUM(x) scm_i_inum(x)
-#define SCM_INUMP(x) scm_i_inump(x)
-#define SCM_NINUMP(x) (!SCM_INUMP(x))
-
-#define SCM_VALIDATE_INUM(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, INUMP, "exact integer")
-
-#define SCM_VALIDATE_INUM_COPY(pos, k, cvar) \
- do { \
- SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
- cvar = SCM_I_INUM (k); \
- } while (0)
-
-#define SCM_VALIDATE_BIGINT(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, BIGP, "bignum")
-
-#define SCM_VALIDATE_INUM_MIN(pos, k, min) \
- do { \
- SCM_ASSERT (SCM_I_INUMP(k), k, pos, FUNC_NAME); \
- SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \
- } while (0)
-
-#define SCM_VALIDATE_INUM_MIN_COPY(pos, k, min, cvar) \
- do { \
- SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
- SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \
- cvar = SCM_INUM (k); \
- } while (0)
-
-#define SCM_VALIDATE_INUM_MIN_DEF_COPY(pos, k, min, default, cvar) \
- do { \
- if (SCM_UNBNDP (k)) \
- k = SCM_I_MAKINUM (default); \
- SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
- SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \
- cvar = SCM_INUM (k); \
- } while (0)
-
-#define SCM_VALIDATE_INUM_DEF(pos, k, default) \
- do { \
- if (SCM_UNBNDP (k)) \
- k = SCM_I_MAKINUM (default); \
- else SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
- } while (0)
-
-#define SCM_VALIDATE_INUM_DEF_COPY(pos, k, default, cvar) \
- do { \
- if (SCM_UNBNDP (k)) \
- { \
- k = SCM_I_MAKINUM (default); \
- cvar = default; \
- } \
- else \
- { \
- SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
- cvar = SCM_INUM (k); \
- } \
- } while (0)
-
-/* [low, high) */
-#define SCM_VALIDATE_INUM_RANGE(pos, k, low, high) \
- do { SCM_ASSERT(SCM_I_INUMP(k), k, pos, FUNC_NAME); \
- SCM_ASSERT_RANGE(pos, k, \
- (SCM_I_INUM (k) >= low && \
- SCM_I_INUM (k) < high)); \
- } while (0)
-
-#define SCM_VALIDATE_INUM_RANGE_COPY(pos, k, low, high, cvar) \
- do { \
- SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \
- SCM_ASSERT_RANGE (pos, k, low <= SCM_INUM (k) && SCM_INUM (k) < high); \
- cvar = SCM_INUM (k); \
- } while (0)
-
-#define SCM_STRING_COERCE_0TERMINATION_X(x) (x)
-
-/* XXX - buggy interface, STR might not be large enough.
-
- Converts the given Scheme string OBJ into a C string, containing a copy
- of OBJ's content with a trailing null byte. If LENP is non-NULL, set
- *LENP to the string's length.
-
- When STR is non-NULL it receives the copy and is returned by the function,
- otherwise new memory is allocated and the caller is responsible for
- freeing it via free(). If out of memory, NULL is returned.
-
- Note that Scheme strings may contain arbitrary data, including null
- characters. This means that null termination is not a reliable way to
- determine the length of the returned value. However, the function always
- copies the complete contents of OBJ, and sets *LENP to the length of the
- scheme string (if LENP is non-null).
-*/
-SCM_DEPRECATED char *scm_c_string2str (SCM obj, char *str, size_t *lenp);
-
-/* XXX - buggy interface, you don't know how many bytes have been copied.
-
- Copy LEN characters at START from the Scheme string OBJ to memory
- at STR. START is an index into OBJ; zero means the beginning of
- the string. STR has already been allocated by the caller.
-
- If START + LEN is off the end of OBJ, silently truncate the source
- region to fit the string. If truncation occurs, the corresponding
- area of STR is left unchanged.
-*/
-SCM_DEPRECATED char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len);
-
-SCM_DEPRECATED char *scm_c_symbol2str (SCM obj, char *str, size_t *lenp);
-
-/* Deprecated because the names belong to what is now
- scm_truncate_number and scm_round_number.
-*/
-SCM_DEPRECATED double scm_truncate (double x);
-SCM_DEPRECATED double scm_round (double x);
-/* Deprecated, use scm_expt */
-SCM_DEPRECATED SCM scm_sys_expt (SCM x, SCM y);
-
-/* if your platform doesn't have asinh et al */
-SCM_DEPRECATED double scm_asinh (double x);
-SCM_DEPRECATED double scm_acosh (double x);
-SCM_DEPRECATED double scm_atanh (double x);
-SCM_DEPRECATED SCM scm_sys_atan2 (SCM z1, SCM z2);
-
-/* Deprecated because we don't want people to access the internal
- representation of strings directly.
-*/
-
-#define SCM_VALIDATE_STRING_COPY(pos, str, cvar) \
- do { \
- SCM_ASSERT (SCM_STRINGP (str), str, pos, FUNC_NAME); \
- cvar = SCM_STRING_CHARS(str); \
- } while (0)
-
-/* validate a string and optional start/end arguments which default to
- 0/string-len. this is unrelated to the old shared substring
- support, so please do not deprecate it :) */
-#define SCM_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
- pos_start, start, c_start,\
- pos_end, end, c_end) \
- do {\
- SCM_VALIDATE_STRING_COPY (pos_str, str, c_str);\
- c_start = SCM_UNBNDP(start)? 0 : scm_to_size_t (start);\
- c_end = SCM_UNBNDP(end)? SCM_STRING_LENGTH(str) : scm_to_size_t (end);\
- SCM_ASSERT_RANGE (pos_start, start,\
- 0 <= c_start \
- && (size_t) c_start <= SCM_STRING_LENGTH (str));\
- SCM_ASSERT_RANGE (pos_end, end,\
- c_start <= c_end \
- && (size_t) c_end <= SCM_STRING_LENGTH (str));\
- } while (0)
-
-/* Deprecated because we don't want people to access the internals of
- symbols directly.
-*/
-
-SCM_DEPRECATED char *scm_i_deprecated_symbol_chars (SCM sym);
-SCM_DEPRECATED size_t scm_i_deprecated_symbol_length (SCM sym);
-
-#define SCM_SYMBOL_CHARS(x) scm_i_deprecated_symbol_chars(x)
-#define SCM_SYMBOL_LENGTH(x) scm_i_deprecated_symbol_length(x)
-
-/* Deprecated because the macros used to evaluate the arguments more
- than once and because the symbol of a keyword now has no dash.
-*/
-
-SCM_DEPRECATED int scm_i_keywordp (SCM obj);
-SCM_DEPRECATED SCM scm_i_keywordsym (SCM keyword);
-
-#define SCM_KEYWORDP(x) scm_i_keywordp(x)
-#define SCM_KEYWORDSYM(x) scm_i_keywordsym(x)
-
-/* Deprecated because we don't want to hand out unprotected pointers
- to arrays, vectors, etc. */
-
-#define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1)
-
-SCM_DEPRECATED int scm_i_vectorp (SCM x);
-SCM_DEPRECATED unsigned long scm_i_vector_length (SCM x);
-SCM_DEPRECATED const SCM *scm_i_velts (SCM x);
-SCM_DEPRECATED SCM *scm_i_writable_velts (SCM x);
-SCM_DEPRECATED SCM scm_i_vector_ref (SCM x, size_t idx);
-SCM_DEPRECATED void scm_i_vector_set (SCM x, size_t idx, SCM val);
-SCM_DEPRECATED SCM scm_vector_equal_p (SCM x, SCM y);
-
-#define SCM_VECTORP(x) scm_i_vectorp(x)
-#define SCM_VECTOR_LENGTH(x) scm_i_vector_length(x)
-#define SCM_VELTS(x) scm_i_velts(x)
-#define SCM_WRITABLE_VELTS(x) scm_i_writable_velts(x)
-#define SCM_VECTOR_REF(x,y) scm_i_vector_ref(x,y)
-#define SCM_VECTOR_SET(x,y,z) scm_i_vector_set(x,y,z)
-
-typedef scm_i_t_array scm_t_array;
-
-SCM_DEPRECATED int scm_i_arrayp (SCM a);
-SCM_DEPRECATED size_t scm_i_array_ndim (SCM a);
-SCM_DEPRECATED int scm_i_array_contp (SCM a);
-SCM_DEPRECATED scm_t_array *scm_i_array_mem (SCM a);
-SCM_DEPRECATED SCM scm_i_array_v (SCM a);
-SCM_DEPRECATED size_t scm_i_array_base (SCM a);
-SCM_DEPRECATED scm_t_array_dim *scm_i_array_dims (SCM a);
-
-#define SCM_ARRAYP(a) scm_i_arrayp(a)
-#define SCM_ARRAY_NDIM(a) scm_i_array_ndim(a)
-#define SCM_ARRAY_CONTP(a) scm_i_array_contp(a)
-#define SCM_ARRAY_MEM(a) scm_i_array_mem(a)
-#define SCM_ARRAY_V(a) scm_i_array_v(a)
-#define SCM_ARRAY_BASE(a) scm_i_array_base(a)
-#define SCM_ARRAY_DIMS(a) scm_i_array_dims(a)
-
-SCM_DEPRECATED SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd,
- SCM start, SCM end);
-SCM_DEPRECATED SCM scm_uniform_vector_write (SCM v, SCM port_or_fd,
- SCM start, SCM end);
-SCM_DEPRECATED SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
- SCM start, SCM end);
-SCM_DEPRECATED SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
- SCM start, SCM end);
-
-/* Deprecated because they should not be lvalues and we want people to
- use the official interfaces.
- */
-
-#define scm_cur_inp scm_i_cur_inp ()
-#define scm_cur_outp scm_i_cur_outp ()
-#define scm_cur_errp scm_i_cur_errp ()
-#define scm_cur_loadp scm_i_cur_loadp ()
-#define scm_progargs scm_i_progargs ()
-#define scm_dynwinds scm_i_deprecated_dynwinds ()
-#define scm_stack_base scm_i_stack_base ()
-
-SCM_DEPRECATED SCM scm_i_cur_inp (void);
-SCM_DEPRECATED SCM scm_i_cur_outp (void);
-SCM_DEPRECATED SCM scm_i_cur_errp (void);
-SCM_DEPRECATED SCM scm_i_cur_loadp (void);
-SCM_DEPRECATED SCM scm_i_progargs (void);
-SCM_DEPRECATED SCM scm_i_deprecated_dynwinds (void);
-SCM_DEPRECATED SCM_STACKITEM *scm_i_stack_base (void);
-
-/* Deprecated because it evaluates its argument twice.
- */
-#define SCM_FLUIDP(x) scm_i_fluidp (x)
-SCM_DEPRECATED int scm_i_fluidp (SCM x);
-
-/* Deprecated in Guile 1.9.5 on 2009-11-15 because these are IPv4-only
- functions which are deprecated upstream. */
-
-SCM_DEPRECATED SCM scm_inet_aton (SCM address);
-SCM_DEPRECATED SCM scm_inet_ntoa (SCM inetid);
-
-/* In the old days, SCM_CRITICAL_SECTION_START stopped signal handlers
- from running, since in those days the handler directly ran scheme
- code, and that had to be avoided when the heap was not in a
- consistent state etc. And since the scheme code could do a stack
- swapping new continuation etc, signals had to be deferred around
- various C library functions which were not safe or not known to be
- safe to swap away, which was a lot of stuff.
-
- These days signals are implemented with asyncs and don't directly
- run scheme code in the handler, but hold it until an SCM_TICK etc
- where it will be safe. This means interrupt protection is not
- needed and SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END is
- something of an anachronism.
-
- What past SCM_CRITICAL_SECTION_START usage also did though was
- indicate code that was not reentrant, ie. could not be reentered by
- signal handler code. The present definitions are a mutex lock,
- affording that reentrancy protection against the new guile 1.8
- free-running posix threads.
-
- One big problem with the present defintions though is that code which
- throws an error from within a DEFER/ALLOW region will leave the
- defer_mutex locked and hence hang other threads that attempt to enter a
- similar DEFER/ALLOW region.
-*/
-
-SCM_DEPRECATED void scm_i_defer_ints_etc (void);
-#define SCM_DEFER_INTS scm_i_defer_ints_etc ()
-#define SCM_ALLOW_INTS scm_i_defer_ints_etc ()
-#define SCM_REDEFER_INTS scm_i_defer_ints_etc ()
-#define SCM_REALLOW_INTS scm_i_defer_ints_etc ()
-
-/* In the old days (pre-1.8), this macro was sometimes used as an lvalue as
- in "scm_mask_ints = 1" to block async execution. It no longer works. */
-#define scm_mask_ints (scm_i_mask_ints ())
-
-SCM_DEPRECATED int scm_i_mask_ints (void);
-
-/* Deprecated since they are unnecessary and had not been documented.
- */
-SCM_DEPRECATED SCM scm_guard (SCM guardian, SCM obj, int throw_p);
-SCM_DEPRECATED SCM scm_get_one_zombie (SCM guardian);
-
-/* Deprecated since guardians no longer have these special features.
- */
-SCM_DEPRECATED SCM scm_destroy_guardian_x (SCM guardian);
-SCM_DEPRECATED SCM scm_guardian_greedy_p (SCM guardian);
-SCM_DEPRECATED SCM scm_guardian_destroyed_p (SCM guardian);
-
-\f
-/* GC-related things deprecated with the move to BDW-GC starting from 1.9.3
- (2009-09-15). */
-
-SCM_DEPRECATED unsigned long scm_mallocated;
-SCM_DEPRECATED unsigned long scm_mtrigger;
-
-SCM_DEPRECATED size_t scm_max_segment_size;
-
-#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
-SCM_DEPRECATED SCM scm_map_free_list (void);
-#endif
-
-#if defined (GUILE_DEBUG_FREELIST)
-SCM_DEPRECATED SCM scm_gc_set_debug_check_freelist_x (SCM flag);
-#endif
-
-\f
-
-/* Deprecated 2009-11-27, scm_call_N is sufficient */
-SCM_DEPRECATED scm_t_trampoline_0 scm_trampoline_0 (SCM proc);
-SCM_DEPRECATED scm_t_trampoline_1 scm_trampoline_1 (SCM proc);
-SCM_DEPRECATED scm_t_trampoline_2 scm_trampoline_2 (SCM proc);
-
-\f
-
-/* Deprecated 2009-12-06, use the procedures instead */
-#define SCM_PROCEDURE_WITH_SETTER_P(obj) (scm_is_true (scm_procedure_with_setter_p (obj)))
-#define SCM_PROCEDURE(obj) SCM_STRUCT_PROCEDURE (obj, 0)
-#define SCM_SETTER(obj) SCM_STRUCT_SETTER (obj, 1)
-
-\f
-
-/* Deprecated 2010-01-05, use SCM_PRIMITIVE_P instead */
-SCM_DEPRECATED int scm_i_subr_p (SCM x);
-#define scm_subr_p(x) (scm_i_subr_p (x))
-
-\f
-
-/* Deprecated 2010-01-31, use with-throw-handler instead */
-SCM_DEPRECATED SCM scm_lazy_catch (SCM tag, SCM thunk, SCM handler);
-SCM_DEPRECATED SCM scm_internal_lazy_catch (SCM tag,
- scm_t_catch_body body,
- void *body_data,
- scm_t_catch_handler handler,
- void *handler_data);
-
-\f
-
-/* Deprecated 2010-03-31, use array-equal? instead */
-SCM_DEPRECATED SCM scm_raequal (SCM ra0, SCM ra1);
-
-/* Deprecated 2010-04-01, use the dynamic FFI instead */
-SCM_DEPRECATED SCM scm_dynamic_args_call (SCM symb, SCM dobj, SCM args);
-
-/* Deprecated 2010-05-12, no replacement */
-SCM_DEPRECATED int scm_badargsp (SCM formals, SCM args);
-
-/* Deprecated 2010-06-19, use call-with-error-handling instead */
-SCM_DEPRECATED SCM scm_internal_stack_catch (SCM tag,
- scm_t_catch_body body,
- void *body_data,
- scm_t_catch_handler handler,
- void *handler_data);
-
-\f
-
-/* These functions were "discouraged" in 1.8, and now are deprecated. */
-
-/* scm_to_int, scm_from_int are the official functions to do the job,
- but there is nothing wrong with using scm_num2int, etc.
-
- These could be trivially defined via macros, but we leave them as
- functions since existing code may take their addresses.
-*/
-
-SCM_DEPRECATED SCM scm_short2num (short n);
-SCM_DEPRECATED SCM scm_ushort2num (unsigned short n);
-SCM_DEPRECATED SCM scm_int2num (int n);
-SCM_DEPRECATED SCM scm_uint2num (unsigned int n);
-SCM_DEPRECATED SCM scm_long2num (long n);
-SCM_DEPRECATED SCM scm_ulong2num (unsigned long n);
-SCM_DEPRECATED SCM scm_size2num (size_t n);
-SCM_DEPRECATED SCM scm_ptrdiff2num (scm_t_ptrdiff n);
-SCM_DEPRECATED short scm_num2short (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED unsigned short scm_num2ushort (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED int scm_num2int (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED unsigned int scm_num2uint (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED long scm_num2long (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED unsigned long scm_num2ulong (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED scm_t_ptrdiff scm_num2ptrdiff (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED size_t scm_num2size (SCM num, unsigned long int pos,
- const char *s_caller);
-#if SCM_SIZEOF_LONG_LONG != 0
-SCM_DEPRECATED SCM scm_long_long2num (long long sl);
-SCM_DEPRECATED SCM scm_ulong_long2num (unsigned long long sl);
-SCM_DEPRECATED long long scm_num2long_long (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED unsigned long long scm_num2ulong_long (SCM num, unsigned long int pos,
- const char *s_caller);
-#endif
-
-SCM_DEPRECATED SCM scm_make_real (double x);
-SCM_DEPRECATED double scm_num2dbl (SCM a, const char * why);
-SCM_DEPRECATED SCM scm_float2num (float n);
-SCM_DEPRECATED SCM scm_double2num (double n);
-
-/* The next two are implemented in numbers.c since they use features
- only available there.
-*/
-SCM_DEPRECATED float scm_num2float (SCM num, unsigned long int pos,
- const char *s_caller);
-SCM_DEPRECATED double scm_num2double (SCM num, unsigned long int pos,
- const char *s_caller);
-
-SCM_DEPRECATED SCM scm_make_complex (double x, double y);
-
-/* Discouraged because they don't make the encoding explicit.
- */
-
-SCM_DEPRECATED SCM scm_mem2symbol (const char *mem, size_t len);
-SCM_DEPRECATED SCM scm_mem2uninterned_symbol (const char *mem, size_t len);
-SCM_DEPRECATED SCM scm_str2symbol (const char *str);
-
-SCM_DEPRECATED SCM scm_take_str (char *s, size_t len);
-SCM_DEPRECATED SCM scm_take0str (char *s);
-SCM_DEPRECATED SCM scm_mem2string (const char *src, size_t len);
-SCM_DEPRECATED SCM scm_str2string (const char *src);
-SCM_DEPRECATED SCM scm_makfrom0str (const char *src);
-SCM_DEPRECATED SCM scm_makfrom0str_opt (const char *src);
-
-/* Discouraged because scm_c_make_string has a better name and is more
- consistent with make-string.
- */
-SCM_DEPRECATED SCM scm_allocate_string (size_t len);
-
-/* Discouraged because they are just strange.
- */
-
-SCM_DEPRECATED SCM scm_make_keyword_from_dash_symbol (SCM symbol);
-SCM_DEPRECATED SCM scm_keyword_dash_symbol (SCM keyword);
-
-/* Discouraged because it does not state what encoding S is in.
- */
-
-SCM_DEPRECATED SCM scm_c_make_keyword (const char *s);
-
-SCM_DEPRECATED unsigned int scm_thread_sleep (unsigned int);
-SCM_DEPRECATED unsigned long scm_thread_usleep (unsigned long);
-SCM_DEPRECATED int scm_internal_select (int fds,
- SELECT_TYPE *rfds,
- SELECT_TYPE *wfds,
- SELECT_TYPE *efds,
- struct timeval *timeout);
-\f
-/* Deprecated because the cuserid call is deprecated.
- */
-SCM_DEPRECATED SCM scm_cuserid (void);
-
-\f
-
-/* Deprecated because it's yet another property interface.
- */
-SCM_DEPRECATED SCM scm_primitive_make_property (SCM not_found_proc);
-SCM_DEPRECATED SCM scm_primitive_property_ref (SCM prop, SCM obj);
-SCM_DEPRECATED SCM scm_primitive_property_set_x (SCM prop, SCM obj, SCM val);
-SCM_DEPRECATED SCM scm_primitive_property_del_x (SCM prop, SCM obj);
-
-\f
-
-/* {The old whash table interface}
- * Deprecated, as the hash table interface is sufficient, and accessing
- * handles of weak hash tables is no longer supported.
- */
-
-#define scm_whash_handle SCM
-
-SCM_DEPRECATED SCM scm_whash_get_handle (SCM whash, SCM key);
-SCM_DEPRECATED int SCM_WHASHFOUNDP (SCM h);
-SCM_DEPRECATED SCM SCM_WHASHREF (SCM whash, SCM handle);
-SCM_DEPRECATED void SCM_WHASHSET (SCM whash, SCM handle, SCM obj);
-SCM_DEPRECATED SCM scm_whash_create_handle (SCM whash, SCM key);
-SCM_DEPRECATED SCM scm_whash_lookup (SCM whash, SCM obj);
-SCM_DEPRECATED void scm_whash_insert (SCM whash, SCM key, SCM obj);
-
-
-\f
-
-/* No need for a table for names, and the struct->class mapping is
- maintained by GOOPS now. */
-#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
-#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
-#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X)
-#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
-
-SCM_DEPRECATED SCM scm_struct_table;
-SCM_DEPRECATED SCM scm_struct_create_handle (SCM obj);
-
-
-\f
-
-/* Deprecated 26-05-2011, as the GC_STUBBORN API doesn't do anything any
- more. */
-SCM_API SCM scm_immutable_cell (scm_t_bits car, scm_t_bits cdr);
-SCM_API SCM scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
- scm_t_bits ccr, scm_t_bits cdr);
-
-\f
-
-void scm_i_init_deprecated (void);
-
-#endif
-
-#endif /* SCM_DEPRECATED_H */
+/* This file contains definitions for deprecated features. When you
+ deprecate something, move it here when that is feasible.
+*/
+
+#ifndef SCM_DEPRECATED_H
+#define SCM_DEPRECATED_H
+
+/* Copyright (C) 2003,2004, 2005, 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#include "libguile/__scm.h"
+#include "libguile/strings.h"
+#include "libguile/eval.h"
+#include "libguile/throw.h"
+#include "libguile/iselect.h"
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+/* Deprecated 13-05-2011 because it's better just to scm_dynwind_begin.
+ That also avoids the temptation to stuff pointers in an SCM. */
+
+typedef SCM (*scm_t_inner) (void *);
+SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before,
+ scm_t_inner inner,
+ scm_t_guard after,
+ void *inner_data,
+ void *guard_data);
+
+
+/* Deprecated 15-05-2011 because it's better to be explicit with the
+ `return'. Code is more readable that way. */
+#define SCM_WTA_DISPATCH_0(gf, subr) \
+ return scm_wta_dispatch_0 ((gf), (subr))
+#define SCM_WTA_DISPATCH_1(gf, a1, pos, subr) \
+ return scm_wta_dispatch_1 ((gf), (a1), (pos), (subr))
+#define SCM_WTA_DISPATCH_2(gf, a1, a2, pos, subr) \
+ return scm_wta_dispatch_2 ((gf), (a1), (a2), (pos), (subr))
+#define SCM_WTA_DISPATCH_N(gf, args, pos, subr) \
+ return scm_wta_dispatch_n ((gf), (args), (pos), (subr))
+
+/* Deprecated 15-05-2011 because this idiom is not very readable. */
+#define SCM_GASSERT0(cond, gf, subr) \
+ if (SCM_UNLIKELY (!(cond))) \
+ return scm_wta_dispatch_0 ((gf), (subr))
+#define SCM_GASSERT1(cond, gf, a1, pos, subr) \
+ if (SCM_UNLIKELY (!(cond))) \
+ return scm_wta_dispatch_1 ((gf), (a1), (pos), (subr))
+#define SCM_GASSERT2(cond, gf, a1, a2, pos, subr) \
+ if (SCM_UNLIKELY (!(cond))) \
+ return scm_wta_dispatch_2 ((gf), (a1), (a2), (pos), (subr))
+#define SCM_GASSERTn(cond, gf, args, pos, subr) \
+ if (SCM_UNLIKELY (!(cond))) \
+ return scm_wta_dispatch_n ((gf), (args), (pos), (subr))
+
+/* Deprecated 15-05-2011 because this is a one-off macro that does
+ strange things. */
+#define SCM_WTA_DISPATCH_1_SUBR(subr, a1, pos) \
+ return (SCM_UNPACK ((*SCM_SUBR_GENERIC (subr))) \
+ ? scm_call_1 ((*SCM_SUBR_GENERIC (subr)), (a1)) \
+ : (scm_i_wrong_type_arg_symbol (SCM_SUBR_NAME (subr), (pos), (a1)), SCM_UNSPECIFIED))
+
+#define SCM_LIST0 SCM_EOL
+#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)
+#define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL)
+#define SCM_LIST3(e0, e1, e2) scm_cons ((e0), SCM_LIST2 ((e1), (e2)))
+#define SCM_LIST4(e0, e1, e2, e3)\
+ scm_cons2 ((e0), (e1), SCM_LIST2 ((e2), (e3)))
+#define SCM_LIST5(e0, e1, e2, e3, e4)\
+ scm_cons ((e0), SCM_LIST4 ((e1), (e2), (e3), (e4)))
+#define SCM_LIST6(e0, e1, e2, e3, e4, e5)\
+ scm_cons2 ((e0), (e1), SCM_LIST4 ((e2), (e3), (e4), (e5)))
+#define SCM_LIST7(e0, e1, e2, e3, e4, e5, e6)\
+ scm_cons ((e0), SCM_LIST6 ((e1), (e2), (e3), (e4), (e5), (e6)))
+#define SCM_LIST8(e0, e1, e2, e3, e4, e5, e6, e7)\
+ scm_cons2 ((e0), (e1), SCM_LIST6 ((e2), (e3), (e4), (e5), (e6), (e7)))
+#define SCM_LIST9(e0, e1, e2, e3, e4, e5, e6, e7, e8)\
+ scm_cons ((e0),\
+ SCM_LIST8 ((e1), (e2), (e3), (e4), (e5), (e6), (e7), (e8)))
+
+#define SCM_OPDIRP SCM_OPDIRP__GONE__REPLACE_WITH__SCM_DIRP_and_SCM_DIR_OPEN_P
+#define SCM_PROCEDURE SCM_PROCEDURE__GONE__REPLACE_WITH__scm_procedure
+#define SCM_PROCEDURE_WITH_SETTER_P SCM_PROCEDURE_WITH_SETTER_P__GONE__REPLACE_WITH__scm_is_true__scm_procedure_with_setter_p
+#define SCM_SETTER SCM_SETTER__GONE__REPLACE_WITH__scm_setter
+#define SCM_THREAD_SWITCHING_CODE SCM_THREAD_SWITCHING_CODE__GONE__REMOVE_FROM_YOUR_CODE
+#define SCM_VALIDATE_NUMBER_COPY SCM_VALIDATE_NUMBER_COPY__GONE__REPLACE_WITH__SCM_VALIDATE_DOUBLE_COPY
+#define SCM_VALIDATE_NUMBER_DEF_COPY SCM_VALIDATE_NUMBER_DEF_COPY__GONE__REPLACE_WITH__SCM_UNBNDP_and_SCM_VALIDATE_DOUBLE_COPY
+#define SCM_VALIDATE_OPDIR SCM_VALIDATE_OPDIR__GONE
+#define SCM_VALIDATE_STRING_COPY SCM_VALIDATE_STRING_COPY__GONE
+#define SCM_VALIDATE_SUBSTRING_SPEC_COPY SCM_VALIDATE_SUBSTRING_SPEC_COPY__GONE
+#define scm_array scm_array__GONE__REPLACE_WITH__scm_t_array
+#define scm_array_dim scm_array_dim__GONE__REPLACE_WITH__scm_t_array_dim
+#define scm_async_click scm_async_click__GONE__REPLACE_WITH__scm_async_tick
+#define scm_call_generic_0 scm_call_generic_0__GONE__REPLACE_WITH__scm_call_0
+#define scm_call_generic_1 scm_call_generic_1__GONE__REPLACE_WITH__scm_call_1
+#define scm_call_generic_2 scm_call_generic_2__GONE__REPLACE_WITH__scm_call_2
+#define scm_call_generic_3 scm_call_generic_3__GONE__REPLACE_WITH__scm_call_3
+#define scm_apply_generic scm_apply_generic__GONE__REPLACE_WITH__scm_apply_0
+#define scm_fport scm_fport__GONE__REPLACE_WITH__scm_t_fport
+#define scm_listify scm_listify__GONE__REPLACE_WITH__scm_list_n
+#define scm_option scm_option__GONE__REPLACE_WITH__scm_t_option
+#define scm_port scm_port__GONE__REPLACE_WITH__scm_t_port
+#define scm_port_rw_active scm_port_rw_active__GONE__REPLACE_WITH__scm_t_port_rw_active
+#define scm_ptob_descriptor scm_ptob_descriptor__GONE__REPLACE_WITH__scm_t_ptob_descriptor
+#define scm_rng scm_rng__GONE__REPLACE_WITH__scm_t_rng
+#define scm_rstate scm_rstate__GONE__REPLACE_WITH__scm_t_rstate
+#define scm_sizet scm_sizet__GONE__REPLACE_WITH__size_t
+#define scm_srcprops scm_srcprops__GONE__REPLACE_WITH__scm_t_srcprops
+#define scm_srcprops_chunk scm_srcprops_chunk__GONE__REPLACE_WITH__scm_t_srcprops_chunk
+#define scm_struct_i_flags scm_struct_i_flags__GONE__REPLACE_WITH__scm_vtable_index_flags
+#define scm_struct_i_free scm_struct_i_free__GONE__REPLACE_WITH__scm_vtable_index_instance_finalize
+#define scm_subr_entry scm_subr_entry__GONE__REPLACE_WITH__scm_t_subr_entry
+#define scm_substring_move_left_x scm_substring_move_left_x__GONE__REPLACE_WITH__scm_substring_move_x
+#define scm_substring_move_right_x scm_substring_move_right_x__GONE__REPLACE_WITH__scm_substring_move_x
+#define scm_vtable_index_printer scm_vtable_index_printer__GONE__REPLACE_WITH__scm_vtable_index_instance_printer
+#define scm_vtable_index_vtable scm_vtable_index_vtable__GONE__REPLACE_WITH__scm_vtable_index_self
+typedef scm_i_t_array scm_i_t_array__GONE__REPLACE_WITH__scm_t_array;
+
+#ifndef BUILDING_LIBGUILE
+#define SCM_ASYNC_TICK SCM_ASYNC_TICK__GONE__REPLACE_WITH__scm_async_tick
+#endif
+
+
+\f
+
+/* Deprecated 26-05-2011, as the GC_STUBBORN API doesn't do anything any
+ more. */
+SCM_API SCM scm_immutable_cell (scm_t_bits car, scm_t_bits cdr);
+SCM_API SCM scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr);
+
+\f
+
+void scm_i_init_deprecated (void);
+
+#endif
+
+#endif /* SCM_DEPRECATED_H */
generic_equal:
if (SCM_UNPACK (g_scm_i_equal_p))
- return scm_call_generic_2 (g_scm_i_equal_p, x, y);
+ return scm_call_2 (g_scm_i_equal_p, x, y);
else
return SCM_BOOL_F;
}
#ifndef SCM_ERROR_H
#define SCM_ERROR_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
\f
+#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
+ do { if (SCM_UNLIKELY (!(_cond))) \
+ scm_wrong_type_arg (_subr, _pos, _arg); } while (0)
+#define SCM_ASSERT_TYPE(_cond, _arg, _pos, _subr, _msg) \
+ do { if (SCM_UNLIKELY (!(_cond))) \
+ scm_wrong_type_arg_msg(_subr, _pos, _arg, _msg); } while (0)
+
+
+\f
+
SCM_API void scm_error (SCM key, const char *subr, const char *message,
SCM args, SCM rest) SCM_NORETURN;
SCM_API SCM scm_error_scm (SCM key, SCM subr, SCM message,
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:
#ifndef SCM_EVALEXT_H
#define SCM_EVALEXT_H
-/* Copyright (C) 1998,1999,2000, 2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000, 2003, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
SCM_API SCM scm_self_evaluating_p (SCM obj);
SCM_INTERNAL void scm_init_evalext (void);
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-#define scm_definedp scm_defined_p
-
-#endif
-
#endif /* SCM_EVALEXT_H */
/*
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+/* 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
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) \
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);
}
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));
}
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 */
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
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);
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,
#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 \
-/* 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
#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"
}
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
-/* 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
{
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 */
#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
\f
-#if (SCM_ENABLE_DEPRECATED == 1)
-SCM_DEPRECATED size_t scm_default_init_heap_size_1;
-SCM_DEPRECATED int scm_default_min_yield_1;
-SCM_DEPRECATED size_t scm_default_init_heap_size_2;
-SCM_DEPRECATED int scm_default_min_yield_2;
-SCM_DEPRECATED size_t scm_default_max_segment_size;
-#else
-#define scm_default_init_heap_size_1 deprecated
-#define scm_default_min_yield_1 deprecated
-#define scm_default_init_heap_size_2 deprecated
-#define scm_default_min_yield_2 deprecated
-#define scm_default_max_segment_size deprecated
-#endif
-
SCM_API unsigned long scm_gc_ports_collected;
SCM_API SCM scm_after_gc_hook;
SCM_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, ...);
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 */
/*
- use 1 and 0 for public #defines instead of "def and undef",
i.e. use #define SCM_HAVE_FOO rather than just not defining
SCM_HAVE_FOO whenever possible. See GNU Coding Guidelines for
- rationale. The only notable non-deprecated exceptions to this
- rule are GUILE_DEBUG and GUILE_DEBUG_FREELIST which do not follow
- this convention in order to retain backward compatibility.
+ rationale. The only notable non-deprecated exception to this rule
+ is GUILE_DEBUG which does not follow this convention in order to
+ retain backward compatibility.
- in the code below, be *VERY* careful not to use or rely on any
runtime-dynamic information below. For example, you cannot use
#endif
pf ("\n");
- pf ("#if SCM_ENABLE_DEPRECATED == 1\n"
- "# define USE_THREADS 1 /* always true now */\n"
- "# define GUILE_ISELECT 1 /* always true now */\n"
- "# define READER_EXTENSIONS 1 /* always true now */\n"
- "# define DEBUG_EXTENSIONS 1 /* always true now */\n"
- "# define DYNAMIC_LINKING 1 /* always true now */\n"
- "#endif\n");
- printf ("\n");
-
pf ("#define SCM_HAVE_ARRAYS 1 /* always true now */\n");
pf ("\n");
SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
-SCM
-scm_apply_generic (SCM gf, SCM args)
-{
- return scm_apply (SCM_STRUCT_PROCEDURE (gf), args, SCM_EOL);
-}
-
-SCM
-scm_call_generic_0 (SCM gf)
-{
- return scm_call_0 (SCM_STRUCT_PROCEDURE (gf));
-}
-
-SCM
-scm_call_generic_1 (SCM gf, SCM a1)
-{
- return scm_call_1 (SCM_STRUCT_PROCEDURE (gf), a1);
-}
-
-SCM
-scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
-{
- return scm_call_2 (SCM_STRUCT_PROCEDURE (gf), a1, a2);
-}
-
-SCM
-scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
-{
- return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3);
-}
-
SCM_SYMBOL (sym_delayed_compile, "delayed-compile");
static SCM
make_dispatch_procedure (SCM gf)
}
}
+/* Dirk:FIXME:: In all of these scm_wta_dispatch_* routines it is
+ * assumed that 'gf' is zero if uninitialized. It would be cleaner if
+ * some valid SCM value like SCM_BOOL_F or SCM_UNDEFINED were chosen.
+ */
+
+SCM
+scm_wta_dispatch_0 (SCM gf, const char *subr)
+{
+ if (!SCM_UNPACK (gf))
+ scm_error_num_args_subr (subr);
+
+ return scm_call_0 (gf);
+}
+
+SCM
+scm_wta_dispatch_1 (SCM gf, SCM a1, int pos, const char *subr)
+{
+ if (!SCM_UNPACK (gf))
+ scm_wrong_type_arg (subr, pos, a1);
+
+ return scm_call_1 (gf, a1);
+}
+
+SCM
+scm_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos, const char *subr)
+{
+ if (!SCM_UNPACK (gf))
+ scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
+
+ return scm_call_2 (gf, a1, a2);
+}
+
+SCM
+scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr)
+{
+ if (!SCM_UNPACK (gf))
+ scm_wrong_type_arg (subr, pos, scm_list_ref (args, scm_from_int (pos)));
+
+ return scm_apply_0 (gf, args);
+}
+
/******************************************************************************
*
* Protocol for calling a generic fumction
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);
scm_initialized_p = 1;
-#ifdef STACK_CHECKING
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-#endif
scm_init_rdelim ();
scm_init_rw ();
-/* 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
# 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"
*/
/* 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>
#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))
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))
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
return SCM_I_CONSP (x);
}
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
+SCM_INLINE_IMPLEMENTATION int
scm_is_string (SCM x)
{
return SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string);
/* Port I/O. */
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
+SCM_INLINE_IMPLEMENTATION int
scm_get_byte_or_eof (SCM port)
{
int c;
}
/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
+SCM_INLINE_IMPLEMENTATION int
scm_peek_byte_or_eof (SCM port)
{
int c;
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");
#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) \
/* This table must agree with the list of M_ constants in memoize.h */
static const char *const memoized_tags[] =
{
- "begin",
+ "seq",
"if",
"lambda",
"let",
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)
{
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. */
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,
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)));
}
}
{
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:
#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
enum
{
- SCM_M_BEGIN,
+ SCM_M_SEQ,
SCM_M_IF,
SCM_M_LAMBDA,
SCM_M_LET,
else if (SCM_NUMBERP (x))
return SCM_BOOL_T;
else
- SCM_WTA_DISPATCH_1 (g_scm_exact_p, x, 1, s_scm_exact_p);
+ return scm_wta_dispatch_1 (g_scm_exact_p, x, 1, s_scm_exact_p);
}
#undef FUNC_NAME
else if (SCM_NUMBERP (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p);
+ return scm_wta_dispatch_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p);
}
#undef FUNC_NAME
return SCM_BOOL_F;
}
}
- SCM_WTA_DISPATCH_1 (g_scm_odd_p, n, 1, s_scm_odd_p);
+ return scm_wta_dispatch_1 (g_scm_odd_p, n, 1, s_scm_odd_p);
}
#undef FUNC_NAME
return SCM_BOOL_T;
}
}
- SCM_WTA_DISPATCH_1 (g_scm_even_p, n, 1, s_scm_even_p);
+ return scm_wta_dispatch_1 (g_scm_even_p, n, 1, s_scm_even_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_T;
else
- SCM_WTA_DISPATCH_1 (g_scm_finite_p, x, 1, s_scm_finite_p);
+ return scm_wta_dispatch_1 (g_scm_finite_p, x, 1, s_scm_finite_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_inf_p, x, 1, s_scm_inf_p);
+ return scm_wta_dispatch_1 (g_scm_inf_p, x, 1, s_scm_inf_p);
}
#undef FUNC_NAME
else if (scm_is_real (x))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_nan_p, x, 1, s_scm_nan_p);
+ return scm_wta_dispatch_1 (g_scm_nan_p, x, 1, s_scm_nan_p);
}
#undef FUNC_NAME
SCM_FRACTION_DENOMINATOR (x));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs);
+ return scm_wta_dispatch_1 (g_scm_abs, x, 1, s_scm_abs);
}
#undef FUNC_NAME
if (SCM_LIKELY (scm_is_integer (y)))
return scm_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
+ return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient);
+ return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient);
}
#undef FUNC_NAME
if (SCM_LIKELY (scm_is_integer (y)))
return scm_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
+ return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder);
+ return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder);
}
#undef FUNC_NAME
if (SCM_LIKELY (scm_is_integer (y)))
return scm_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
+ return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo);
+ return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo);
}
#undef FUNC_NAME
two_valued_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos,
const char *subr, SCM *rp1, SCM *rp2)
{
- if (SCM_UNPACK (gf))
- scm_i_extract_values_2 (scm_call_generic_2 (gf, a1, a2), rp1, rp2);
- else
- scm_wrong_type_arg (subr, pos, (pos == SCM_ARG1) ? a1 : a2);
+ SCM vals = scm_wta_dispatch_2 (gf, a1, a2, pos, subr);
+
+ scm_i_extract_values_2 (vals, rp1, rp2);
}
SCM_DEFINE (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_floor_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
+ s_scm_floor_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
- s_scm_floor_quotient);
+ return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
+ s_scm_floor_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_floor_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_floor_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
+ s_scm_floor_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
- s_scm_floor_remainder);
+ return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
+ s_scm_floor_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_ceiling_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
+ s_scm_ceiling_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
- s_scm_ceiling_quotient);
+ return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
+ s_scm_ceiling_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_ceiling_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_ceiling_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
+ s_scm_ceiling_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
- s_scm_ceiling_remainder);
+ return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
+ s_scm_ceiling_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_truncate_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
+ s_scm_truncate_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
- s_scm_truncate_quotient);
+ return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
+ s_scm_truncate_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_truncate_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_truncate_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
+ s_scm_truncate_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
- s_scm_truncate_remainder);
+ return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
+ s_scm_truncate_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_centered_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
+ s_scm_centered_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
- s_scm_centered_quotient);
+ return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
+ s_scm_centered_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_centered_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_centered_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
+ s_scm_centered_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
- s_scm_centered_remainder);
+ return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
+ s_scm_centered_remainder);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_round_quotient
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_round_quotient (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG2,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
+ s_scm_round_quotient);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_round_quotient, x, y, SCM_ARG1,
- s_scm_round_quotient);
+ return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG1,
+ s_scm_round_quotient);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_REALP (x))
{
return scm_i_inexact_round_remainder
(SCM_REAL_VALUE (x), scm_to_double (y));
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
return scm_i_exact_rational_round_remainder (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG2,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
+ s_scm_round_remainder);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_round_remainder, x, y, SCM_ARG1,
- s_scm_round_remainder);
+ return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG1,
+ s_scm_round_remainder);
}
#undef FUNC_NAME
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))
{
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,
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))
{
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)
{
}
else
dpt = 1;
-#endif
do
{
if (dpt > 0)
{
-#ifndef ENGNOT
if ((dpt > 4) && (exp > 6))
{
d = (a[0] == '-' ? 2 : 1);
efmt = 1;
}
else
-#endif
{
while (--dpt)
a[ch++] = '0';
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else if (SCM_REALP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else if (SCM_COMPLEXP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else if (SCM_FRACTIONP (x))
{
else if (SCM_FRACTIONP (y))
return scm_i_fraction_equalp (x, y);
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
+ s_scm_i_num_eq_p);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1, s_scm_i_num_eq_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1,
+ s_scm_i_num_eq_p);
}
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
else if (SCM_BIGP (x))
{
else if (SCM_FRACTIONP (y))
goto int_frac;
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
else if (SCM_REALP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
else if (SCM_FRACTIONP (x))
{
goto again;
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARGn, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
+ s_scm_i_num_less_p);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_i_num_less_p, x, y, SCM_ARG1, s_scm_i_num_less_p);
+ return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARG1,
+ s_scm_i_num_less_p);
}
scm_gr_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
else
return scm_less_p (y, x);
}
scm_leq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
scm_geq_p (SCM x, SCM y)
{
if (!SCM_NUMBERP (x))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
else if (!SCM_NUMBERP (y))
- SCM_WTA_DISPATCH_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
+ return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
return SCM_BOOL_F;
else
else if (SCM_FRACTIONP (z))
return SCM_BOOL_F;
else
- SCM_WTA_DISPATCH_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p);
+ return scm_wta_dispatch_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (x))
return scm_positive_p (SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p);
+ return scm_wta_dispatch_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p);
}
#undef FUNC_NAME
else if (SCM_FRACTIONP (x))
return scm_negative_p (SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p);
+ return scm_wta_dispatch_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p);
}
#undef FUNC_NAME
if (SCM_UNBNDP (y))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_max, s_max);
+ return scm_wta_dispatch_0 (g_max, s_max);
else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);
+ return scm_wta_dispatch_1 (g_max, x, SCM_ARG1, s_max);
}
if (SCM_I_INUMP (x))
return (scm_is_false (scm_less_p (x, y)) ? x : y);
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_BIGP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_REALP (x))
{
return (xx < yy) ? scm_from_double (yy) : x;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else if (SCM_FRACTIONP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
}
else
- SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
+ return scm_wta_dispatch_2 (g_max, x, y, SCM_ARG1, s_max);
}
if (SCM_UNBNDP (y))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_min, s_min);
+ return scm_wta_dispatch_0 (g_min, s_min);
else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);
+ return scm_wta_dispatch_1 (g_min, x, SCM_ARG1, s_min);
}
if (SCM_I_INUMP (x))
return (scm_is_false (scm_less_p (x, y)) ? y : x);
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_BIGP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_REALP (x))
{
return (yy < xx) ? scm_from_double (yy) : x;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else if (SCM_FRACTIONP (x))
{
goto use_less;
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
}
else
- SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
+ return scm_wta_dispatch_2 (g_min, x, y, SCM_ARG1, s_min);
}
{
if (SCM_NUMBERP (x)) return x;
if (SCM_UNBNDP (x)) return SCM_INUM0;
- SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum);
+ return scm_wta_dispatch_1 (g_sum, x, SCM_ARG1, s_sum);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
} else if (SCM_BIGP (x))
{
if (SCM_I_INUMP (y))
scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_from_double (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_COMPLEXP (x))
{
return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y),
SCM_COMPLEX_IMAG (x));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
else
- SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
+ return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARG1, s_sum);
}
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_difference, s_difference);
+ return scm_wta_dispatch_0 (g_difference, s_difference);
else
if (SCM_I_INUMP (x))
{
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)))
SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_BIGP (x))
{
return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
- else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ else
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_from_double (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_COMPLEXP (x))
{
return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y),
SCM_COMPLEX_IMAG (x));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
}
else
- SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
+ return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARG1, s_difference);
}
#undef FUNC_NAME
else if (SCM_NUMBERP (x))
return x;
else
- SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);
+ return scm_wta_dispatch_1 (g_product, x, SCM_ARG1, s_product);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
else if (SCM_NUMP (y))
return SCM_INUM0;
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
break;
case -1:
/*
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_BIGP (x))
{
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
SCM_FRACTION_DENOMINATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_from_double (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_COMPLEXP (x))
{
yy * SCM_COMPLEX_IMAG (x));
}
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else if (SCM_FRACTIONP (x))
{
scm_product (SCM_FRACTION_DENOMINATOR (x),
SCM_FRACTION_DENOMINATOR (y)));
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
}
else
- SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
+ return scm_wta_dispatch_2 (g_product, x, y, SCM_ARG1, s_product);
}
#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
if (SCM_UNLIKELY (SCM_UNBNDP (y)))
{
if (SCM_UNBNDP (x))
- SCM_WTA_DISPATCH_0 (g_divide, s_divide);
+ return scm_wta_dispatch_0 (g_divide, s_divide);
else if (SCM_I_INUMP (x))
{
scm_t_inum xx = SCM_I_INUM (x);
return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x),
SCM_FRACTION_NUMERATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
+ return scm_wta_dispatch_1 (g_divide, x, SCM_ARG1, s_divide);
}
if (SCM_LIKELY (SCM_I_INUMP (x)))
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_BIGP (x))
{
return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
SCM_FRACTION_NUMERATOR (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_REALP (x))
{
else if (SCM_FRACTIONP (y))
return scm_from_double (rx / scm_i_fraction2double (y));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_COMPLEXP (x))
{
return scm_c_make_rectangular (rx / yy, ix / yy);
}
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else if (SCM_FRACTIONP (x))
{
return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
}
else
- SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
+ return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARG1, s_divide);
}
SCM
return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_truncate_number, x, SCM_ARG1,
+ return scm_wta_dispatch_1 (g_scm_truncate_number, x, SCM_ARG1,
s_scm_truncate_number);
}
#undef FUNC_NAME
return scm_round_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_round_number, x, SCM_ARG1,
- s_scm_round_number);
+ return scm_wta_dispatch_1 (g_scm_round_number, x, SCM_ARG1,
+ s_scm_round_number);
}
#undef FUNC_NAME
return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor);
+ return scm_wta_dispatch_1 (g_scm_floor, x, 1, s_scm_floor);
}
#undef FUNC_NAME
return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x),
SCM_FRACTION_DENOMINATOR (x));
else
- SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
+ return scm_wta_dispatch_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
}
#undef FUNC_NAME
else if (scm_is_complex (x) && scm_is_complex (y))
return scm_exp (scm_product (scm_log (x), y));
else if (scm_is_complex (x))
- SCM_WTA_DISPATCH_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt);
+ return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt);
else
- SCM_WTA_DISPATCH_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt);
+ return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt);
}
#undef FUNC_NAME
cos (x) * sinh (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sin, z, 1, s_scm_sin);
+ return scm_wta_dispatch_1 (g_scm_sin, z, 1, s_scm_sin);
}
#undef FUNC_NAME
-sin (x) * sinh (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_cos, z, 1, s_scm_cos);
+ return scm_wta_dispatch_1 (g_scm_cos, z, 1, s_scm_cos);
}
#undef FUNC_NAME
return scm_c_make_rectangular (sin (x) / w, sinh (y) / w);
}
else
- SCM_WTA_DISPATCH_1 (g_scm_tan, z, 1, s_scm_tan);
+ return scm_wta_dispatch_1 (g_scm_tan, z, 1, s_scm_tan);
}
#undef FUNC_NAME
cosh (x) * sin (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_sinh, z, 1, s_scm_sinh);
+ return scm_wta_dispatch_1 (g_scm_sinh, z, 1, s_scm_sinh);
}
#undef FUNC_NAME
sinh (x) * sin (y));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_cosh, z, 1, s_scm_cosh);
+ return scm_wta_dispatch_1 (g_scm_cosh, z, 1, s_scm_cosh);
}
#undef FUNC_NAME
return scm_c_make_rectangular (sinh (x) / w, sin (y) / w);
}
else
- SCM_WTA_DISPATCH_1 (g_scm_tanh, z, 1, s_scm_tanh);
+ return scm_wta_dispatch_1 (g_scm_tanh, z, 1, s_scm_tanh);
}
#undef FUNC_NAME
scm_sys_asinh (scm_c_make_rectangular (-y, x)));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_asin, z, 1, s_scm_asin);
+ return scm_wta_dispatch_1 (g_scm_asin, z, 1, s_scm_asin);
}
#undef FUNC_NAME
scm_sys_asinh (scm_c_make_rectangular (-y, x))));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_acos, z, 1, s_scm_acos);
+ return scm_wta_dispatch_1 (g_scm_acos, z, 1, s_scm_acos);
}
#undef FUNC_NAME
scm_c_make_rectangular (0, 2));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
+ return scm_wta_dispatch_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
}
else if (scm_is_real (z))
{
if (scm_is_real (y))
return scm_from_double (atan2 (scm_to_double (z), scm_to_double (y)));
else
- SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
+ return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
}
else
- SCM_WTA_DISPATCH_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
+ return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
}
#undef FUNC_NAME
scm_sqrt (scm_sum (scm_product (z, z),
SCM_INUM1))));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
+ return scm_wta_dispatch_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
}
#undef FUNC_NAME
scm_sqrt (scm_difference (scm_product (z, z),
SCM_INUM1))));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
+ return scm_wta_dispatch_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
}
#undef FUNC_NAME
scm_difference (SCM_INUM1, z))),
SCM_I_MAKINUM (2));
else
- SCM_WTA_DISPATCH_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
+ return scm_wta_dispatch_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
}
#undef FUNC_NAME
else if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_REALP (z) || SCM_FRACTIONP (z))
return z;
else
- SCM_WTA_DISPATCH_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part);
+ return scm_wta_dispatch_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part);
}
#undef FUNC_NAME
else if (SCM_I_INUMP (z) || SCM_REALP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z))
return SCM_INUM0;
else
- SCM_WTA_DISPATCH_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part);
+ return scm_wta_dispatch_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part);
}
#undef FUNC_NAME
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
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
SCM_FRACTION_DENOMINATOR (z));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_magnitude, z, SCM_ARG1, s_scm_magnitude);
+ return scm_wta_dispatch_1 (g_scm_magnitude, z, SCM_ARG1,
+ s_scm_magnitude);
}
#undef FUNC_NAME
else return scm_from_double (atan2 (0.0, -1.0));
}
else
- SCM_WTA_DISPATCH_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
+ return scm_wta_dispatch_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
}
#undef FUNC_NAME
else if (SCM_INEXACTP (z))
return z;
else
- SCM_WTA_DISPATCH_1 (g_scm_exact_to_inexact, z, 1, s_scm_exact_to_inexact);
+ return scm_wta_dispatch_1 (g_scm_exact_to_inexact, z, 1,
+ s_scm_exact_to_inexact);
}
#undef FUNC_NAME
else if (SCM_COMPLEXP (z) && SCM_COMPLEX_IMAG (z) == 0.0)
val = SCM_COMPLEX_REAL (z);
else
- SCM_WTA_DISPATCH_1 (g_scm_inexact_to_exact, z, 1, s_scm_inexact_to_exact);
+ return scm_wta_dispatch_1 (g_scm_inexact_to_exact, z, 1,
+ s_scm_inexact_to_exact);
if (!SCM_LIKELY (DOUBLE_IS_FINITE (val)))
SCM_OUT_OF_RANGE (1, z);
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)
{
return log_of_fraction (SCM_FRACTION_NUMERATOR (z),
SCM_FRACTION_DENOMINATOR (z));
else
- SCM_WTA_DISPATCH_1 (g_scm_log, z, 1, s_scm_log);
+ return scm_wta_dispatch_1 (g_scm_log, z, 1, s_scm_log);
}
#undef FUNC_NAME
log_of_fraction (SCM_FRACTION_NUMERATOR (z),
SCM_FRACTION_DENOMINATOR (z)));
else
- SCM_WTA_DISPATCH_1 (g_scm_log10, z, 1, s_scm_log10);
+ return scm_wta_dispatch_1 (g_scm_log10, z, 1, s_scm_log10);
}
#undef FUNC_NAME
return scm_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
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
"")
#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
}
#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
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);
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
{
# 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"
\f
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
-#if (SCM_ENABLE_DEPRECATED == 1)
-SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
-#endif
SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
static SCM overrides;
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
{
SCM_VALIDATE_PROC (1, proc);
-#if (SCM_ENABLE_DEPRECATED == 1)
- if (scm_assq (alist, scm_sym_arity))
- SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
-#endif
-
scm_i_pthread_mutex_lock (&overrides_lock);
scm_hashq_set_x (overrides, proc, alist);
scm_i_pthread_mutex_unlock (&overrides_lock);
{
SCM_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
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))
#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
\f
SCM_API SCM scm_sym_name;
-#if (SCM_ENABLE_DEPRECATED == 1)
-SCM_DEPRECATED SCM scm_sym_arity;
-#endif
SCM_API SCM scm_sym_system_procedure;
\f
"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
#include <pthread.h>
#include <sched.h>
-/* `libgc' defines wrapper procedures for pthread calls. */
-#include "libguile/bdw-gc.h"
-
/* Threads
*/
#define scm_i_pthread_t pthread_t
#define scm_i_pthread_self pthread_self
-#define scm_i_pthread_create GC_pthread_create
-#define scm_i_pthread_detach GC_pthread_detach
+#define scm_i_pthread_create pthread_create
+#define scm_i_pthread_detach pthread_detach
-#if SCM_HAVE_GC_PTHREAD_EXIT
-#define scm_i_pthread_exit GC_pthread_exit
-#else
#define scm_i_pthread_exit pthread_exit
-#endif
-
-#if SCM_HAVE_GC_PTHREAD_CANCEL
-#define scm_i_pthread_cancel GC_pthread_cancel
-#else
#define scm_i_pthread_cancel pthread_cancel
-#endif
#define scm_i_pthread_cleanup_push pthread_cleanup_push
#define scm_i_pthread_cleanup_pop pthread_cleanup_pop
/* Signals
*/
-#if SCM_HAVE_GC_PTHREAD_SIGMASK
-#define scm_i_pthread_sigmask GC_pthread_sigmask
-#else
#define scm_i_pthread_sigmask pthread_sigmask
-#endif
/* Mutexes
*/
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;
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;
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)
SCM_GC_BOP);
bv = scm_c_take_bytevector ((signed char *) result_buf.buffer,
- result_buf.len);
+ result_buf.len, SCM_BOOL_F);
}
return bv;
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':
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)
#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;
-}
-
\f
/* 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);
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;
+}
+
\f
void
scm_smob_prehistory ()
#include "libguile/__scm.h"
#include "libguile/print.h"
-#include "libguile/bdw-gc.h"
-
\f
/* This is the internal representation of a smob type */
} 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[];
+
+
\f
-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))
+
+\f
#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)))
#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);
-
\f
SCM_API SCM scm_mark0 (SCM ptr);
#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>
flg = scm_to_int (flags);
fd = SCM_FPORT_FDES (sock);
-#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_UNLIKELY (scm_is_string (buf)))
- {
- SCM msg;
- char *dest;
- size_t len;
-
- scm_c_issue_deprecation_warning
- ("Passing a string to `recv!' is deprecated, "
- "use a bytevector instead.");
-
- len = scm_i_string_length (buf);
- msg = scm_i_make_string (len, &dest, 0);
- SCM_SYSCALL (rv = recv (fd, dest, len, flg));
- scm_string_copy_x (buf, scm_from_int (0),
- msg, scm_from_int (0), scm_from_size_t (len));
- }
- else
-#endif
- {
- SCM_VALIDATE_BYTEVECTOR (1, buf);
+ SCM_VALIDATE_BYTEVECTOR (1, buf);
- SCM_SYSCALL (rv = recv (fd,
- SCM_BYTEVECTOR_CONTENTS (buf),
- SCM_BYTEVECTOR_LENGTH (buf),
- flg));
- }
+ SCM_SYSCALL (rv = recv (fd,
+ SCM_BYTEVECTOR_CONTENTS (buf),
+ SCM_BYTEVECTOR_LENGTH (buf),
+ flg));
if (SCM_UNLIKELY (rv == -1))
SCM_SYSERROR;
fd = SCM_FPORT_FDES (sock);
-#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_UNLIKELY (scm_is_string (message)))
- {
- scm_c_issue_deprecation_warning
- ("Passing a string to `send' is deprecated, "
- "use a bytevector instead.");
-
- /* If the string is wide, see if it can be coerced into a narrow
- string. */
- if (!scm_i_is_narrow_string (message)
- || !scm_i_try_narrow_string (message))
- SCM_MISC_ERROR ("the message string is not 8-bit: ~s",
- scm_list_1 (message));
-
- SCM_SYSCALL (rv = send (fd,
- scm_i_string_chars (message),
- scm_i_string_length (message),
- flg));
- }
- else
-#endif
- {
- SCM_VALIDATE_BYTEVECTOR (1, message);
+ SCM_VALIDATE_BYTEVECTOR (1, message);
- SCM_SYSCALL (rv = send (fd,
- SCM_BYTEVECTOR_CONTENTS (message),
- SCM_BYTEVECTOR_LENGTH (message),
- flg));
- }
+ SCM_SYSCALL (rv = send (fd,
+ SCM_BYTEVECTOR_CONTENTS (message),
+ SCM_BYTEVECTOR_LENGTH (message),
+ flg));
if (rv == -1)
SCM_SYSERROR;
((struct sockaddr *) &addr)->sa_family = AF_UNSPEC;
-#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_UNLIKELY (scm_is_string (buf)))
- {
- char *cbuf;
-
- scm_c_issue_deprecation_warning
- ("Passing a string to `recvfrom!' is deprecated, "
- "use a bytevector instead.");
-
- scm_i_get_substring_spec (scm_i_string_length (buf),
- start, &offset, end, &cend);
+ SCM_VALIDATE_BYTEVECTOR (1, buf);
- buf = scm_i_string_start_writing (buf);
- cbuf = scm_i_string_writable_chars (buf);
+ if (SCM_UNBNDP (start))
+ offset = 0;
+ else
+ offset = scm_to_size_t (start);
- SCM_SYSCALL (rv = recvfrom (fd, cbuf + offset,
- cend - offset, flg,
- (struct sockaddr *) &addr, &addr_size));
- scm_i_string_stop_writing ();
- }
+ if (SCM_UNBNDP (end))
+ cend = SCM_BYTEVECTOR_LENGTH (buf);
else
-#endif
{
- SCM_VALIDATE_BYTEVECTOR (1, buf);
-
- if (SCM_UNBNDP (start))
- offset = 0;
- else
- offset = scm_to_size_t (start);
-
- if (SCM_UNBNDP (end))
- cend = SCM_BYTEVECTOR_LENGTH (buf);
- else
- {
- cend = scm_to_size_t (end);
- if (SCM_UNLIKELY (cend >= SCM_BYTEVECTOR_LENGTH (buf)
- || cend < offset))
- scm_out_of_range (FUNC_NAME, end);
- }
-
- SCM_SYSCALL (rv = recvfrom (fd,
- SCM_BYTEVECTOR_CONTENTS (buf) + offset,
- cend - offset, flg,
- (struct sockaddr *) &addr, &addr_size));
+ cend = scm_to_size_t (end);
+ if (SCM_UNLIKELY (cend >= SCM_BYTEVECTOR_LENGTH (buf)
+ || cend < offset))
+ scm_out_of_range (FUNC_NAME, end);
}
+ SCM_SYSCALL (rv = recvfrom (fd,
+ SCM_BYTEVECTOR_CONTENTS (buf) + offset,
+ cend - offset, flg,
+ (struct sockaddr *) &addr, &addr_size));
+
if (rv == -1)
SCM_SYSERROR;
flg = SCM_NUM2ULONG (5, SCM_CAR (args_and_flags));
}
-#if SCM_ENABLE_DEPRECATED == 1
- if (SCM_UNLIKELY (scm_is_string (message)))
- {
- scm_c_issue_deprecation_warning
- ("Passing a string to `sendto' is deprecated, "
- "use a bytevector instead.");
-
- /* If the string is wide, see if it can be coerced into a narrow
- string. */
- if (!scm_i_is_narrow_string (message)
- || !scm_i_try_narrow_string (message))
- SCM_MISC_ERROR ("the message string is not 8-bit: ~s",
- scm_list_1 (message));
-
- SCM_SYSCALL (rv = sendto (fd,
- scm_i_string_chars (message),
- scm_i_string_length (message),
- flg, soka, size));
- }
- else
-#endif
- {
- SCM_VALIDATE_BYTEVECTOR (1, message);
+ SCM_VALIDATE_BYTEVECTOR (1, message);
- SCM_SYSCALL (rv = sendto (fd,
- SCM_BYTEVECTOR_CONTENTS (message),
- SCM_BYTEVECTOR_LENGTH (message),
- flg, soka, size));
- }
+ SCM_SYSCALL (rv = sendto (fd,
+ SCM_BYTEVECTOR_CONTENTS (message),
+ SCM_BYTEVECTOR_LENGTH (message),
+ flg, soka, size));
if (rv == -1)
{
/* srfi-4.c --- Uniform numeric vector datatypes.
*
- * Copyright (C) 2001, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype, width) \
SCM scm_take_##tag##vector (ctype *data, size_t n) \
{ \
- return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG)); \
+ return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG), \
+ SCM_BOOL_F); \
} \
const ctype* scm_array_handle_##tag##_elements (scm_t_array_handle *h) \
{ \
#define SCM_SRFI_4_H
/* srfi-4.c --- Homogeneous numeric vector datatypes.
*
- * Copyright (C) 2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
SCM_INTERNAL scm_i_t_array_ref scm_i_uniform_vector_ref_proc (SCM uvec);
SCM_INTERNAL scm_i_t_array_set scm_i_uniform_vector_set_proc (SCM uvec);
-#if SCM_ENABLE_DEPRECATED
-
-/* Deprecated because we want people to use the scm_t_array_handle
- interface.
-*/
-
-SCM_DEPRECATED size_t scm_uniform_element_size (SCM obj);
-
-#endif
-
SCM_INTERNAL void scm_init_srfi_4 (void);
#endif /* SCM_SRFI_4_H */
-/* Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
/* {Stack Checking}
*/
-#ifdef STACK_CHECKING
int scm_stack_checking_enabled_p;
SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
scm_dynwind_end ();
}
-#endif
-
long
scm_stack_size (SCM_STACKITEM *start)
{
#ifndef SCM_STACKCHK_H
#define SCM_STACKCHK_H
-/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
*/
#define SCM_STACK_CHECKING_P SCM_STACK_LIMIT
-#if defined BUILDING_LIBGUILE && defined STACK_CHECKING
+#if defined BUILDING_LIBGUILE
#include "libguile/private-options.h"
# if SCM_STACK_GROWS_UP
# define SCM_STACK_OVERFLOW_P(s)\
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);
*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)
{
-/* 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 */
#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
/* 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;
#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
\f
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-#define SCM_CELLP(x) (((sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0)
-#define SCM_NCELLP(x) (!SCM_CELLP (x))
-
-#endif
-
#endif /* SCM_TAGS_H */
/*
else
{
fprintf (stderr, "Failed to get stack base for current thread.\n");
- exit (1);
+ exit (EXIT_FAILURE);
}
}
}
t->block_asyncs--;
- scm_async_click ();
+ scm_async_tick ();
scm_remember_upto_here_2 (cond, mutex);
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);
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;
}
return scm_from_size_t (dim->ubnd - dim->lbnd + 1);
}
else
- SCM_WTA_DISPATCH_1 (g_vector_length, v, 1, NULL);
+ return scm_wta_dispatch_1 (g_vector_length, v, 1, "vector-length");
}
size_t
scm_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);
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");
}
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);
bin_SCRIPTS = guile-config guild
EXTRA_DIST= \
guile.m4 ChangeLog-2008 \
- guile-2.0.pc.in guile-2.0-uninstalled.pc.in \
+ guile-2.2.pc.in guile-2.2-uninstalled.pc.in \
guild.in guile-config.in
# What we now call `guild' used to be known as `guile-tools'.
$(LN_S) guild$(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.
;;;; guile-config --- utility for linking programs with Guile
;;;; Jim Blandy <jim@red-bean.com> --- September 1997
;;;;
-;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998, 2001, 2004, 2005, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(dle " " p " --help - show usage info (this message)")
(dle " " p " --help SUBCOMMAND - show help for SUBCOMMAND")))
-(define guile-module "guile-2.0")
+(define guile-module "guile-2.2")
(define (pkg-config . args)
(let* ((real-args (cons %pkg-config-program args))
(define (module-define-submodule! module name submodule)
(hashq-set! (module-submodules module) name submodule))
-;; It used to be, however, that module names were also present in the
-;; value namespace. When we enable deprecated code, we preserve this
-;; legacy behavior.
-;;
-;; These shims are defined here instead of in deprecated.scm because we
-;; need their definitions before loading other modules.
-;;
-(begin-deprecated
- (define (module-ref-submodule module name)
- (or (hashq-ref (module-submodules module) name)
- (and (module-submodule-binder module)
- ((module-submodule-binder module) module name))
- (let ((var (module-local-variable module name)))
- (and var (variable-bound? var) (module? (variable-ref var))
- (begin
- (warn "module" module "not in submodules table")
- (variable-ref var))))))
-
- (define (module-define-submodule! module name submodule)
- (let ((var (module-local-variable module name)))
- (if (and var
- (or (not (variable-bound? var))
- (not (module? (variable-ref var)))))
- (warn "defining module" module ": not overriding local definition" var)
- (module-define! module name submodule)))
- (hashq-set! (module-submodules module) name submodule)))
-
\f
;;; {Module-based Loading}
(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
-;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;;
-
-(define-module (ice-9 deprecated)
- #:export (substring-move-left! substring-move-right!
- dynamic-maybe-call dynamic-maybe-link
- try-module-linked try-module-dynamic-link
- list* feature? eval-case unmemoize-expr
- $asinh
- $acosh
- $atanh
- $sqrt
- $abs
- $exp
- $log
- $sin
- $cos
- $tan
- $asin
- $acos
- $atan
- $sinh
- $cosh
- $tanh
- closure?
- %nil
- @bind
- bad-throw
- error-catching-loop
- error-catching-repl
- scm-style-repl
- apply-to-args
- has-suffix?
- scheme-file-suffix
- get-option
- for-next-option
- display-usage-report
- transform-usage-lambda
- collect
- assert-repl-silence
- assert-repl-print-unspecified
- assert-repl-verbosity
- set-repl-prompt!
- set-batch-mode?!
- repl
- pre-unwind-handler-dispatch
- default-pre-unwind-handler
- handle-system-error
- stack-saved?
- the-last-stack
- save-stack
- named-module-use!
- top-repl
- turn-on-debugging
- read-hash-procedures
- process-define-module))
-
-
-;;;; Deprecated definitions.
-
-(define substring-move-left!
- (lambda args
- (issue-deprecation-warning
- "`substring-move-left!' is deprecated. Use `substring-move!' instead.")
- (apply substring-move! args)))
-(define substring-move-right!
- (lambda args
- (issue-deprecation-warning
- "`substring-move-right!' is deprecated. Use `substring-move!' instead.")
- (apply substring-move! args)))
-
-
-\f
-;; This method of dynamically linking Guile Extensions is deprecated.
-;; Use `load-extension' explicitly from Scheme code instead.
-
-(define (split-c-module-name str)
- (let loop ((rev '())
- (start 0)
- (pos 0)
- (end (string-length str)))
- (cond
- ((= pos end)
- (reverse (cons (string->symbol (substring str start pos)) rev)))
- ((eq? (string-ref str pos) #\space)
- (loop (cons (string->symbol (substring str start pos)) rev)
- (+ pos 1)
- (+ pos 1)
- end))
- (else
- (loop rev start (+ pos 1) end)))))
-
-(define (convert-c-registered-modules dynobj)
- (let ((res (map (lambda (c)
- (list (split-c-module-name (car c)) (cdr c) dynobj))
- (c-registered-modules))))
- (c-clear-registered-modules)
- res))
-
-(define registered-modules '())
-
-(define (register-modules dynobj)
- (set! registered-modules
- (append! (convert-c-registered-modules dynobj)
- registered-modules)))
-
-(define (warn-autoload-deprecation modname)
- (issue-deprecation-warning
- "Autoloading of compiled code modules is deprecated."
- "Write a Scheme file instead that uses `load-extension'.")
- (issue-deprecation-warning
- (simple-format #f "(You just autoloaded module ~S.)" modname)))
-
-(define (init-dynamic-module modname)
- ;; Register any linked modules which have been registered on the C level
- (register-modules #f)
- (or-map (lambda (modinfo)
- (if (equal? (car modinfo) modname)
- (begin
- (warn-autoload-deprecation modname)
- (set! registered-modules (delq! modinfo registered-modules))
- (let ((mod (resolve-module modname #f)))
- (save-module-excursion
- (lambda ()
- (set-current-module mod)
- (set-module-public-interface! mod mod)
- (dynamic-call (cadr modinfo) (caddr modinfo))
- ))
- #t))
- #f))
- registered-modules))
-
-(define (dynamic-maybe-call name dynobj)
- (issue-deprecation-warning
- "`dynamic-maybe-call' is deprecated. "
- "Wrap `dynamic-call' in a `false-if-exception' yourself.")
- (false-if-exception (dynamic-call name dynobj)))
-
-
-(define (dynamic-maybe-link filename)
- (issue-deprecation-warning
- "`dynamic-maybe-link' is deprecated. "
- "Wrap `dynamic-link' in a `false-if-exception' yourself.")
- (false-if-exception (dynamic-link filename)))
-
-(define (find-and-link-dynamic-module module-name)
- (define (make-init-name mod-name)
- (string-append "scm_init"
- (list->string (map (lambda (c)
- (if (or (char-alphabetic? c)
- (char-numeric? c))
- c
- #\_))
- (string->list mod-name)))
- "_module"))
-
- ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
- ;; and the `libname' (the name of the module prepended by `lib') in the cdr
- ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then
- ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
- (let ((subdir-and-libname
- (let loop ((dirs "")
- (syms module-name))
- (if (null? (cdr syms))
- (cons dirs (string-append "lib" (symbol->string (car syms))))
- (loop (string-append dirs (symbol->string (car syms)) "/")
- (cdr syms)))))
- (init (make-init-name (apply string-append
- (map (lambda (s)
- (string-append "_"
- (symbol->string s)))
- module-name)))))
- (let ((subdir (car subdir-and-libname))
- (libname (cdr subdir-and-libname)))
-
- ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that
- ;; file exists, fetch the dlname from that file and attempt to link
- ;; against it. If `subdir/libfoo.la' does not exist, or does not seem
- ;; to name any shared library, look for `subdir/libfoo.so' instead and
- ;; link against that.
- (let check-dirs ((dir-list %load-path))
- (if (null? dir-list)
- #f
- (let* ((dir (in-vicinity (car dir-list) subdir))
- (sharlib-full
- (or (try-using-libtool-name dir libname)
- (try-using-sharlib-name dir libname))))
- (if (and sharlib-full (file-exists? sharlib-full))
- (link-dynamic-module sharlib-full init)
- (check-dirs (cdr dir-list)))))))))
-
-(define (try-using-libtool-name libdir libname)
- (let ((libtool-filename (in-vicinity libdir
- (string-append libname ".la"))))
- (and (file-exists? libtool-filename)
- libtool-filename)))
-
-(define (try-using-sharlib-name libdir libname)
- (in-vicinity libdir (string-append libname ".so")))
-
-(define (link-dynamic-module filename initname)
- ;; Register any linked modules which have been registered on the C level
- (register-modules #f)
- (let ((dynobj (dynamic-link filename)))
- (dynamic-call initname dynobj)
- (register-modules dynobj)))
-
-(define (try-module-linked module-name)
- (issue-deprecation-warning
- "`try-module-linked' is deprecated."
- "See the manual for how more on C extensions.")
- (init-dynamic-module module-name))
-
-(define (try-module-dynamic-link module-name)
- (issue-deprecation-warning
- "`try-module-dynamic-link' is deprecated."
- "See the manual for how more on C extensions.")
- (and (find-and-link-dynamic-module module-name)
- (init-dynamic-module module-name)))
-
-\f
-(define (list* . args)
- (issue-deprecation-warning "'list*' is deprecated. Use 'cons*' instead.")
- (apply cons* args))
-
-(define (feature? sym)
- (issue-deprecation-warning
- "`feature?' is deprecated. Use `provided?' instead.")
- (provided? sym))
-
-(define-macro (eval-case . clauses)
- (issue-deprecation-warning
- "`eval-case' is deprecated. Use `eval-when' instead.")
- ;; Practically speaking, eval-case only had load-toplevel and else as
- ;; conditions.
- (cond
- ((assoc-ref clauses '(load-toplevel))
- => (lambda (exps)
- ;; the *unspecified so that non-toplevel definitions will be
- ;; caught
- `(begin *unspecified* . ,exps)))
- ((assoc-ref clauses 'else)
- => (lambda (exps)
- `(begin *unspecified* . ,exps)))
- (else
- `(begin))))
-
-;; The strange prototype system for uniform arrays has been
-;; deprecated.
-(read-hash-extend
- #\y
- (lambda (c port)
- (issue-deprecation-warning
- "The `#y' bytevector syntax is deprecated. Use `#s8' instead.")
- (let ((x (read port)))
- (cond
- ((list? x) (list->s8vector x))
- (else (error "#y needs to be followed by a list" x))))))
-
-(define (unmemoize-expr . args)
- (issue-deprecation-warning
- "`unmemoize-expr' is deprecated. Use `unmemoize-expression' instead.")
- (apply unmemoize-expression args))
-
-(define ($asinh z)
- (issue-deprecation-warning
- "`$asinh' is deprecated. Use `asinh' instead.")
- (asinh z))
-(define ($acosh z)
- (issue-deprecation-warning
- "`$acosh' is deprecated. Use `acosh' instead.")
- (acosh z))
-(define ($atanh z)
- (issue-deprecation-warning
- "`$atanh' is deprecated. Use `atanh' instead.")
- (atanh z))
-(define ($sqrt z)
- (issue-deprecation-warning
- "`$sqrt' is deprecated. Use `sqrt' instead.")
- (sqrt z))
-(define ($abs z)
- (issue-deprecation-warning
- "`$abs' is deprecated. Use `abs' instead.")
- (abs z))
-(define ($exp z)
- (issue-deprecation-warning
- "`$exp' is deprecated. Use `exp' instead.")
- (exp z))
-(define ($log z)
- (issue-deprecation-warning
- "`$log' is deprecated. Use `log' instead.")
- (log z))
-(define ($sin z)
- (issue-deprecation-warning
- "`$sin' is deprecated. Use `sin' instead.")
- (sin z))
-(define ($cos z)
- (issue-deprecation-warning
- "`$cos' is deprecated. Use `cos' instead.")
- (cos z))
-(define ($tan z)
- (issue-deprecation-warning
- "`$tan' is deprecated. Use `tan' instead.")
- (tan z))
-(define ($asin z)
- (issue-deprecation-warning
- "`$asin' is deprecated. Use `asin' instead.")
- (asin z))
-(define ($acos z)
- (issue-deprecation-warning
- "`$acos' is deprecated. Use `acos' instead.")
- (acos z))
-(define ($atan z)
- (issue-deprecation-warning
- "`$atan' is deprecated. Use `atan' instead.")
- (atan z))
-(define ($sinh z)
- (issue-deprecation-warning
- "`$sinh' is deprecated. Use `sinh' instead.")
- (sinh z))
-(define ($cosh z)
- (issue-deprecation-warning
- "`$cosh' is deprecated. Use `cosh' instead.")
- (cosh z))
-(define ($tanh z)
- (issue-deprecation-warning
- "`$tanh' is deprecated. Use `tanh' instead.")
- (tanh z))
-
-(define (closure? x)
- (issue-deprecation-warning
- "`closure?' is deprecated. Use `procedure?' instead.")
- (procedure? x))
-
-(define %nil #nil)
-
-;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
-;;; Please let the Guile developers know if you are using this macro.
-;;;
-(define-syntax @bind
- (lambda (x)
- (define (bound-member id ids)
- (cond ((null? ids) #f)
- ((bound-identifier=? id (car ids)) #t)
- ((bound-member (car ids) (cdr ids)))))
-
- (issue-deprecation-warning
- "`@bind' is deprecated. Use `with-fluids' instead.")
-
- (syntax-case x ()
- ((_ () b0 b1 ...)
- #'(let () b0 b1 ...))
- ((_ ((id val) ...) b0 b1 ...)
- (and-map identifier? #'(id ...))
- (if (let lp ((ids #'(id ...)))
- (cond ((null? ids) #f)
- ((bound-member (car ids) (cdr ids)) #t)
- (else (lp (cdr ids)))))
- (syntax-violation '@bind "duplicate bound identifier" x)
- (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
- ((v ...) (generate-temporaries #'(id ...))))
- #'(let ((old-v id) ...
- (v val) ...)
- (dynamic-wind
- (lambda ()
- (set! id v) ...)
- (lambda () b0 b1 ...)
- (lambda ()
- (set! id old-v) ...)))))))))
-
-;; There are deprecated definitions for module-ref-submodule and
-;; module-define-submodule! in boot-9.scm.
-
-;; Define (%app) and (%app modules), and have (app) alias (%app). This
-;; side-effects the-root-module, both to the submodules table and (through
-;; module-define-submodule! above) the obarray.
-;;
-(let ((%app (make-module 31)))
- (set-module-name! %app '(%app))
- (module-define-submodule! the-root-module '%app %app)
- (module-define-submodule! the-root-module 'app %app)
- (module-define-submodule! %app 'modules (resolve-module '() #f)))
-
-;; Allow code that poked %module-public-interface to keep on working.
-;;
-(set! module-public-interface
- (let ((getter module-public-interface))
- (lambda (mod)
- (or (getter mod)
- (cond
- ((and=> (module-local-variable mod '%module-public-interface)
- variable-ref)
- => (lambda (iface)
- (issue-deprecation-warning
-"Setting a module's public interface via munging %module-public-interface is
-deprecated. Use set-module-public-interface! instead.")
- (set-module-public-interface! mod iface)
- iface))
- (else #f))))))
-
-(set! set-module-public-interface!
- (let ((setter set-module-public-interface!))
- (lambda (mod iface)
- (setter mod iface)
- (module-define! mod '%module-public-interface iface))))
-
-(define (bad-throw key . args)
- (issue-deprecation-warning
- "`bad-throw' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- (apply (@ (ice-9 scm-style-repl) bad-throw) key args))
-
-(define (error-catching-loop thunk)
- (issue-deprecation-warning
- "`error-catching-loop' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- ((@ (ice-9 scm-style-repl) error-catching-loop) thunk))
-
-(define (error-catching-repl r e p)
- (issue-deprecation-warning
- "`error-catching-repl' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- ((@ (ice-9 scm-style-repl) error-catching-repl) r e p))
-
-(define (scm-style-repl)
- (issue-deprecation-warning
- "`scm-style-repl' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead, or
-better yet, use the repl from `(system repl repl)'.")
- ((@ (ice-9 scm-style-repl) scm-style-repl)))
-
-
-;;; Apply-to-args had the following comment attached to it in boot-9, but it's
-;;; wrong-headed: in the mentioned case, a point should either be a record or
-;;; multiple values.
-;;;
-;;; apply-to-args is functionally redundant with apply and, worse,
-;;; is less general than apply since it only takes two arguments.
-;;;
-;;; On the other hand, apply-to-args is a syntacticly convenient way to
-;;; perform binding in many circumstances when the "let" family of
-;;; of forms don't cut it. E.g.:
-;;;
-;;; (apply-to-args (return-3d-mouse-coords)
-;;; (lambda (x y z)
-;;; ...))
-;;;
-
-(define (apply-to-args args fn)
- (issue-deprecation-warning
- "`apply-to-args' is deprecated. Include a local copy in your program.")
- (apply fn args))
-
-(define (has-suffix? str suffix)
- (issue-deprecation-warning
- "`has-suffix?' is deprecated. Use `string-suffix?' instead (args reversed).")
- (string-suffix? suffix str))
-
-(define scheme-file-suffix
- (lambda ()
- (issue-deprecation-warning
- "`scheme-file-suffix' is deprecated. Use `%load-extensions' instead.")
- ".scm"))
-
-\f
-
-;;; {Command Line Options}
-;;;
-
-(define (get-option argv kw-opts kw-args return)
- (issue-deprecation-warning
- "`get-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (cond
- ((null? argv)
- (return #f #f argv))
-
- ((or (not (eq? #\- (string-ref (car argv) 0)))
- (eq? (string-length (car argv)) 1))
- (return 'normal-arg (car argv) (cdr argv)))
-
- ((eq? #\- (string-ref (car argv) 1))
- (let* ((kw-arg-pos (or (string-index (car argv) #\=)
- (string-length (car argv))))
- (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
- (kw-opt? (member kw kw-opts))
- (kw-arg? (member kw kw-args))
- (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
- (substring (car argv)
- (+ kw-arg-pos 1)
- (string-length (car argv))))
- (and kw-arg?
- (begin (set! argv (cdr argv)) (car argv))))))
- (if (or kw-opt? kw-arg?)
- (return kw arg (cdr argv))
- (return 'usage-error kw (cdr argv)))))
-
- (else
- (let* ((char (substring (car argv) 1 2))
- (kw (symbol->keyword char)))
- (cond
-
- ((member kw kw-opts)
- (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
- (new-argv (if (= 0 (string-length rest-car))
- (cdr argv)
- (cons (string-append "-" rest-car) (cdr argv)))))
- (return kw #f new-argv)))
-
- ((member kw kw-args)
- (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
- (arg (if (= 0 (string-length rest-car))
- (cadr argv)
- rest-car))
- (new-argv (if (= 0 (string-length rest-car))
- (cddr argv)
- (cdr argv))))
- (return kw arg new-argv)))
-
- (else (return 'usage-error kw argv)))))))
-
-(define (for-next-option proc argv kw-opts kw-args)
- (issue-deprecation-warning
- "`for-next-option' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (let loop ((argv argv))
- (get-option argv kw-opts kw-args
- (lambda (opt opt-arg argv)
- (and opt (proc opt opt-arg argv loop))))))
-
-(define (display-usage-report kw-desc)
- (issue-deprecation-warning
- "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (for-each
- (lambda (kw)
- (or (eq? (car kw) #t)
- (eq? (car kw) 'else)
- (let* ((opt-desc kw)
- (help (cadr opt-desc))
- (opts (car opt-desc))
- (opts-proper (if (string? (car opts)) (cdr opts) opts))
- (arg-name (if (string? (car opts))
- (string-append "<" (car opts) ">")
- ""))
- (left-part (string-append
- (with-output-to-string
- (lambda ()
- (map (lambda (x) (display (keyword->symbol x)) (display " "))
- opts-proper)))
- arg-name))
- (middle-part (if (and (< (string-length left-part) 30)
- (< (string-length help) 40))
- (make-string (- 30 (string-length left-part)) #\ )
- "\n\t")))
- (display left-part)
- (display middle-part)
- (display help)
- (newline))))
- kw-desc))
-
-(define (transform-usage-lambda cases)
- (issue-deprecation-warning
- "`display-usage-report' is deprecated. Use `(ice-9 getopt-long)' instead.")
- (let* ((raw-usage (delq! 'else (map car cases)))
- (usage-sans-specials (map (lambda (x)
- (or (and (not (list? x)) x)
- (and (symbol? (car x)) #t)
- (and (boolean? (car x)) #t)
- x))
- raw-usage))
- (usage-desc (delq! #t usage-sans-specials))
- (kw-desc (map car usage-desc))
- (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
- (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
- (transmogrified-cases (map (lambda (case)
- (cons (let ((opts (car case)))
- (if (or (boolean? opts) (eq? 'else opts))
- opts
- (cond
- ((symbol? (car opts)) opts)
- ((boolean? (car opts)) opts)
- ((string? (caar opts)) (cdar opts))
- (else (car opts)))))
- (cdr case)))
- cases)))
- `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
- (lambda (%argv)
- (let %next-arg ((%argv %argv))
- (get-option %argv
- ',kw-opts
- ',kw-args
- (lambda (%opt %arg %new-argv)
- (case %opt
- ,@ transmogrified-cases))))))))
-
-\f
-
-;;; {collect}
-;;;
-;;; Similar to `begin' but returns a list of the results of all constituent
-;;; forms instead of the result of the last form.
-;;;
-
-(define-syntax collect
- (lambda (x)
- (issue-deprecation-warning
- "`collect' is deprecated. Define it yourself.")
- (syntax-case x ()
- ((_) #''())
- ((_ x x* ...)
- #'(let ((val x))
- (cons val (collect x* ...)))))))
-
-
-\f
-
-(define (assert-repl-silence v)
- (issue-deprecation-warning
- "`assert-repl-silence' has moved to `(ice-9 scm-style-repl)'.")
- ((@ (ice-9 scm-style-repl) assert-repl-silence) v))
-
-(define (assert-repl-print-unspecified v)
- (issue-deprecation-warning
- "`assert-repl-print-unspecified' has moved to `(ice-9 scm-style-repl)'.")
- ((@ (ice-9 scm-style-repl) assert-repl-print-unspecified) v))
-
-(define (assert-repl-verbosity v)
- (issue-deprecation-warning
- "`assert-repl-verbosity' has moved to `(ice-9 scm-style-repl)'.")
- ((@ (ice-9 scm-style-repl) assert-repl-verbosity) v))
-
-(define (set-repl-prompt! v)
- (issue-deprecation-warning
- "`set-repl-prompt!' is deprecated. Use `repl-default-prompt-set!' from
-the `(system repl common)' module.")
- ;; Avoid @, as when bootstrapping it will cause the (system repl common)
- ;; module to be loaded at expansion time, which eventually loads srfi-1, but
- ;; that fails due to an unbuilt supporting lib... grrrrrrrrr.
- ((module-ref (resolve-interface '(system repl common))
- 'repl-default-prompt-set!)
- v))
-
-(define (set-batch-mode?! arg)
- (cond
- (arg
- (issue-deprecation-warning
- "`set-batch-mode?!' is deprecated. Use `ensure-batch-mode!' instead.")
- (ensure-batch-mode!))
- (else
- (issue-deprecation-warning
- "`set-batch-mode?!' with an argument of `#f' is deprecated. Use the
-`*repl-stack*' fluid instead.")
- #t)))
-
-(define (repl read evaler print)
- (issue-deprecation-warning
- "`repl' is deprecated. Define it yourself.")
- (let loop ((source (read (current-input-port))))
- (print (evaler source))
- (loop (read (current-input-port)))))
-
-(define (pre-unwind-handler-dispatch key . args)
- (issue-deprecation-warning
- "`pre-unwind-handler-dispatch' is deprecated. Use
-`default-pre-unwind-handler' from `(ice-9 scm-style-repl)' directly.")
- (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
-
-(define (default-pre-unwind-handler key . args)
- (issue-deprecation-warning
- "`default-pre-unwind-handler' is deprecated. Use it from
-`(ice-9 scm-style-repl)' if you need it.")
- (apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
-
-(define (handle-system-error key . args)
- (issue-deprecation-warning
- "`handle-system-error' is deprecated. Use it from
-`(ice-9 scm-style-repl)' if you need it.")
- (apply (@ (ice-9 scm-style-repl) handle-system-error) key args))
-
-(define-syntax stack-saved?
- (make-variable-transformer
- (lambda (x)
- (issue-deprecation-warning
- "`stack-saved?' is deprecated. Use it from
-`(ice-9 save-stack)' if you need it.")
- (syntax-case x (set!)
- ((set! id val)
- (identifier? #'id)
- #'(set! (@ (ice-9 save-stack) stack-saved?) val))
- (id
- (identifier? #'id)
- #'(@ (ice-9 save-stack) stack-saved?))))))
-
-(define-syntax the-last-stack
- (lambda (x)
- (issue-deprecation-warning
- "`the-last-stack' is deprecated. Use it from `(ice-9 save-stack)'
-if you need it.")
- (syntax-case x ()
- (id
- (identifier? #'id)
- #'(@ (ice-9 save-stack) the-last-stack)))))
-
-(define (save-stack . args)
- (issue-deprecation-warning
- "`save-stack' is deprecated. Use it from `(ice-9 save-stack)' if you need
-it.")
- (apply (@ (ice-9 save-stack) save-stack) args))
-
-(define (named-module-use! user usee)
- (issue-deprecation-warning
- "`named-module-use!' is deprecated. Define it yourself if you need it.")
- (module-use! (resolve-module user) (resolve-interface usee)))
-
-(define (top-repl)
- (issue-deprecation-warning
- "`top-repl' has moved to the `(ice-9 top-repl)' module.")
- ((module-ref (resolve-module '(ice-9 top-repl)) 'top-repl)))
-
-(set! debug-enable
- (let ((debug-enable debug-enable))
- (lambda opts
- (if (memq 'debug opts)
- (begin
- (issue-deprecation-warning
- "`(debug-enable 'debug)' is obsolete and has no effect."
- "Remove it from your code.")
- (apply debug-enable (delq 'debug opts)))
- (apply debug-enable opts)))))
-
-(define (turn-on-debugging)
- (issue-deprecation-warning
- "`(turn-on-debugging)' is obsolete and usually has no effect."
- "Debugging capabilities are present by default.")
- (debug-enable 'backtrace)
- (read-enable 'positions))
-
-(define (read-hash-procedures-warning)
- (issue-deprecation-warning
- "`read-hash-procedures' is deprecated."
- "Use the fluid `%read-hash-procedures' instead."))
-
-(define-syntax read-hash-procedures
- (identifier-syntax
- (_
- (begin (read-hash-procedures-warning)
- (fluid-ref %read-hash-procedures)))
- ((set! _ expr)
- (begin (read-hash-procedures-warning)
- (fluid-set! %read-hash-procedures expr)))))
-
-(define (process-define-module args)
- (define (missing kw)
- (error "missing argument to define-module keyword" kw))
- (define (unrecognized arg)
- (error "unrecognized define-module argument" arg))
-
- (issue-deprecation-warning
- "`process-define-module' is deprecated. Use `define-module*' instead.")
-
- (let ((name (car args))
- (filename #f)
- (pure? #f)
- (version #f)
- (system? #f)
- (duplicates '())
- (transformer #f))
- (let loop ((kws (cdr args))
- (imports '())
- (exports '())
- (re-exports '())
- (replacements '())
- (autoloads '()))
- (if (null? kws)
- (define-module* name
- #:filename filename #:pure pure? #:version version
- #:duplicates duplicates #:transformer transformer
- #:imports (reverse! imports)
- #:exports exports
- #:re-exports re-exports
- #:replacements replacements
- #:autoloads autoloads)
- (case (car kws)
- ((#:use-module #:use-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (cond
- ((equal? (cadr kws) '(ice-9 syncase))
- (issue-deprecation-warning
- "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.")
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- (else
- (let ((iface-spec (cadr kws)))
- (if (eq? (car kws) #:use-syntax)
- (set! transformer iface-spec))
- (loop (cddr kws)
- (cons iface-spec imports) exports re-exports
- replacements autoloads)))))
- ((#:autoload)
- (or (and (pair? (cdr kws)) (pair? (cddr kws)))
- (missing (car kws)))
- (let ((name (cadr kws))
- (bindings (caddr kws)))
- (loop (cdddr kws)
- imports exports re-exports
- replacements (cons* name bindings autoloads))))
- ((#:no-backtrace)
- ;; FIXME: deprecate?
- (set! system? #t)
- (loop (cdr kws)
- imports exports re-exports replacements autoloads))
- ((#:pure)
- (set! pure? #t)
- (loop (cdr kws)
- imports exports re-exports replacements autoloads))
- ((#:version)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (set! version (cadr kws))
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- ((#:duplicates)
- (if (not (pair? (cdr kws)))
- (missing (car kws)))
- (set! duplicates (cadr kws))
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- ((#:export #:export-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (loop (cddr kws)
- imports (append exports (cadr kws)) re-exports
- replacements autoloads))
- ((#:re-export #:re-export-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (loop (cddr kws)
- imports exports (append re-exports (cadr kws))
- replacements autoloads))
- ((#:replace #:replace-syntax)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (loop (cddr kws)
- imports exports re-exports
- (append replacements (cadr kws)) autoloads))
- ((#:filename)
- (or (pair? (cdr kws))
- (missing (car kws)))
- (set! filename (cadr kws))
- (loop (cddr kws)
- imports exports re-exports replacements autoloads))
- (else
- (unrecognized kws)))))))
+;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 deprecated)
+ #:export ())
+
;;; -*- 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
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)))
(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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
("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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
("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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
("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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
(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)
(top)
(top)
(top))
- #("i1835"
- "i1836"
- "i1837"
- "i1838"))
+ #("i1850"
+ "i1851"
+ "i1852"
+ "i1853"))
#(ribcage
()
()
(top)
(top)
(top))
- #("i1788"
- "i1789"
- "i1790"
- "i1791"
- "i1792"
- "i1793"))
+ #("i1803"
+ "i1804"
+ "i1805"
+ "i1806"
+ "i1807"
+ "i1808"))
#(ribcage
()
()
#(ribcage
#(first)
#((top))
- #("i1780"))
+ #("i1795"))
#(ribcage
()
()
(top)
(top)
(top))
- #("i1752"
- "i1753"
- "i1754"
- "i1755"
- "i1756"
- "i1757"
- "i1758"))
+ #("i1767"
+ "i1768"
+ "i1769"
+ "i1770"
+ "i1771"
+ "i1772"
+ "i1773"))
#(ribcage
(lambda-var-list
gen-var
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
"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
()
()
(top)
(top)
(top))
- #("i1788"
- "i1789"
- "i1790"
- "i1791"
- "i1792"
- "i1793"))
+ #("i1803"
+ "i1804"
+ "i1805"
+ "i1806"
+ "i1807"
+ "i1808"))
#(ribcage
()
()
#(ribcage
#(first)
#((top))
- #("i1780"))
+ #("i1795"))
#(ribcage
()
()
(top)
(top)
(top))
- #("i1752"
- "i1753"
- "i1754"
- "i1755"
- "i1756"
- "i1757"
- "i1758"))
+ #("i1767"
+ "i1768"
+ "i1769"
+ "i1770"
+ "i1771"
+ "i1772"
+ "i1773"))
#(ribcage
(lambda-var-list
gen-var
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
#(ribcage
#(name)
#((top))
- #("i1848"))
+ #("i1863"))
#(ribcage
()
()
(top)
(top)
(top))
- #("i1788"
- "i1789"
- "i1790"
- "i1791"
- "i1792"
- "i1793"))
+ #("i1803"
+ "i1804"
+ "i1805"
+ "i1806"
+ "i1807"
+ "i1808"))
#(ribcage
()
()
#(ribcage
#(first)
#((top))
- #("i1780"))
+ #("i1795"))
#(ribcage
()
()
(top)
(top)
(top))
- #("i1752"
- "i1753"
- "i1754"
- "i1755"
- "i1756"
- "i1757"
- "i1758"))
+ #("i1767"
+ "i1768"
+ "i1769"
+ "i1770"
+ "i1771"
+ "i1772"
+ "i1773"))
#(ribcage
(lambda-var-list
gen-var
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
#(ribcage
#(name)
#((top))
- #("i1848"))
+ #("i1863"))
#(ribcage
()
()
(top)
(top)
(top))
- #("i1788"
- "i1789"
- "i1790"
- "i1791"
- "i1792"
- "i1793"))
+ #("i1803"
+ "i1804"
+ "i1805"
+ "i1806"
+ "i1807"
+ "i1808"))
#(ribcage
()
()
#(ribcage
#(first)
#((top))
- #("i1780"))
+ #("i1795"))
#(ribcage
()
()
(top)
(top)
(top))
- #("i1752"
- "i1753"
- "i1754"
- "i1755"
- "i1756"
- "i1757"
- "i1758"))
+ #("i1767"
+ "i1768"
+ "i1769"
+ "i1770"
+ "i1771"
+ "i1772"
+ "i1773"))
#(ribcage
(lambda-var-list
gen-var
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
"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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
("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)
(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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
((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)
#(ribcage
#(k)
#((top))
- #("i2412"))
+ #("i2427"))
#(ribcage
#(a b)
#((top) (top))
- #("i2406" "i2407"))
+ #("i2421" "i2422"))
#(ribcage () () ())
#(ribcage
#(args req opt rkey)
(top)
(top)
(top))
- #("i2395"
- "i2396"
- "i2397"
- "i2398"))
+ #("i2410"
+ "i2411"
+ "i2412"
+ "i2413"))
#(ribcage
(check rest
key
(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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
"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)
(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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
((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
#(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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
((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
#(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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
((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)
#(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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
((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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
((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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
#(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
chi-local-syntax
chi-body
chi-macro
- chi-application
+ chi-call
chi-expr
chi
syntax-type
build-sequence
build-data
build-primref
+ build-primcall
build-lambda-case
build-case-lambda
build-simple-lambda
build-lexical-reference
build-dynlet
build-conditional
- build-application
+ build-call
build-void
maybe-name-value!
decorate-source
make-lambda-case
make-lambda
make-sequence
- make-application
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
+ (top)
(top))
- ("i448"
+ ("i452"
+ "i450"
+ "i448"
"i446"
"i444"
"i442"
"i388"
"i386"
"i384"
+ "i383"
"i382"
"i380"
"i379"
"i378"
+ "i377"
"i376"
- "i375"
"i374"
- "i373"
"i372"
"i370"
"i368"
"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"
"i260"
"i258"
"i256"
- "i254"
+ "i255"
"i253"
"i251"
+ "i250"
"i249"
"i248"
"i247"
- "i246"
"i245"
"i243"
"i241"
- "i239"
+ "i238"
"i236"
"i234"
"i232"
((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)))))))))))
(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
#(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
#(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
#(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
#(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
#(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
#(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)
(top)
(top)
(top))
- #("i4252"
- "i4253"
- "i4254"
- "i4255"))
+ #("i4262"
+ "i4263"
+ "i4264"
+ "i4265"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("i4249")))
+ #("i4259")))
(hygiene guile))
- #{tmp 4262}#)
+ #{tmp 4272}#)
(list '#(syntax-object
syntax
((top)
(top)
(top)
(top))
- #("i4252"
- "i4253"
- "i4254"
- "i4255"))
+ #("i4262"
+ "i4263"
+ "i4264"
+ "i4265"))
#(ribcage
()
()
#(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
#(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
#(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
#(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
#(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
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)
(top)
(top)
(top))
- #("i4275"
- "i4276"
- "i4277"
- "i4278"
- "i4279"))
+ #("i4285"
+ "i4286"
+ "i4287"
+ "i4288"
+ "i4289"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("i4249")))
+ #("i4259")))
(hygiene
guile))
- #{tmp 4287}#)
+ #{tmp 4297}#)
(list '#(syntax-object
syntax
((top)
(top)
(top)
(top))
- #("i4275"
- "i4276"
- "i4277"
- "i4278"
- "i4279"))
+ #("i4285"
+ "i4286"
+ "i4287"
+ "i4288"
+ "i4289"))
#(ribcage
()
()
#(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)
#(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)
#(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
#(ribcage
#(step)
#((top))
- #("i4347"))
+ #("i4357"))
#(ribcage
#(var init step e0 e1 c)
#((top)
(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
#(ribcage
#(step)
#((top))
- #("i4347"))
+ #("i4357"))
#(ribcage
#(var init step e0 e1 c)
#((top)
(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)
#(ribcage
#(step)
#((top))
- #("i4347"))
+ #("i4357"))
#(ribcage
#(var init step e0 e1 c)
#((top)
(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
#(ribcage
#(step)
#((top))
- #("i4347"))
+ #("i4357"))
#(ribcage
#(var
init
(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
#(step)
#((top))
- #("i4347"))
+ #("i4357"))
#(ribcage
#(var
init
(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)
#(ribcage
#(step)
#((top))
- #("i4347"))
+ #("i4357"))
#(ribcage
#(var
init
(top)
(top)
(top))
- #("i4332"
- "i4333"
- "i4334"
- "i4335"
- "i4336"
- "i4337"))
+ #("i4342"
+ "i4343"
+ "i4344"
+ "i4345"
+ "i4346"
+ "i4347"))
#(ribcage
()
()
#(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)
(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
#(ribcage
#(e1 e2)
#((top) (top))
- #("i4356" "i4357"))
+ #("i4366" "i4367"))
#(ribcage () () ())
#(ribcage
#(step)
#((top))
- #("i4347"))
+ #("i4357"))
#(ribcage
#(var init step e0 e1 c)
#((top)
(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
(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
()
()
#(ribcage
#(step)
#((top))
- #("i4347"))
+ #("i4357"))
#(ribcage
#(var
init
(top)
(top)
(top))
- #("i4332"
- "i4333"
- "i4334"
- "i4335"
- "i4336"
- "i4337"))
+ #("i4342"
+ "i4343"
+ "i4344"
+ "i4345"
+ "i4346"
+ "i4347"))
#(ribcage
()
()
#(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
()
()
#(ribcage
#(step)
#((top))
- #("i4347"))
+ #("i4357"))
#(ribcage
#(var
init
(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)
e2)
#((top)
(top))
- #("i4356"
- "i4357"))
+ #("i4366"
+ "i4367"))
#(ribcage
()
()
#(ribcage
#(step)
#((top))
- #("i4347"))
+ #("i4357"))
#(ribcage
#(var
init
(top)
(top)
(top))
- #("i4332"
- "i4333"
- "i4334"
- "i4335"
- "i4336"
- "i4337"))
+ #("i4342"
+ "i4343"
+ "i4344"
+ "i4345"
+ "i4346"
+ "i4347"))
#(ribcage
()
()
#(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
#(ribcage
#(p lev)
#((top) (top))
- #("i4395" "i4396"))
+ #("i4405" "i4406"))
#(ribcage
(emit quasivector
quasilist*
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*
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*
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*
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
#(ribcage
#(p lev)
#((top) (top))
- #("i4395" "i4396"))
+ #("i4405" "i4406"))
#(ribcage
(emit quasivector
quasilist*
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*
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*
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
#(ribcage
#(p q)
#((top) (top))
- #("i4405" "i4406"))
+ #("i4415" "i4416"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i4395" "i4396"))
+ #("i4405" "i4406"))
#(ribcage
(emit quasivector
quasilist*
(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*
(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*
(top)
(top)
(top))
- ("i4391"
- "i4389"
- "i4387"
- "i4385"
- "i4383"
- "i4381"
- "i4379")))
+ ("i4401"
+ "i4399"
+ "i4397"
+ "i4395"
+ "i4393"
+ "i4391"
+ "i4389")))
(hygiene guile))
#(syntax-object
unquote
#(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*
(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
#(ribcage
#(p q)
#((top) (top))
- #("i4405" "i4406"))
+ #("i4415" "i4416"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i4395" "i4396"))
+ #("i4405" "i4406"))
#(ribcage
(emit quasivector
quasilist*
(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
()
()
#(p lev)
#((top)
(top))
- #("i4395"
- "i4396"))
+ #("i4405"
+ "i4406"))
#(ribcage
(emit quasivector
quasilist*
(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*
(top)
(top)
(top))
- ("i4391"
- "i4389"
- "i4387"
- "i4385"
- "i4383"
- "i4381"
- "i4379")))
+ ("i4401"
+ "i4399"
+ "i4397"
+ "i4395"
+ "i4393"
+ "i4391"
+ "i4389")))
(hygiene guile))
#(syntax-object
unquote-splicing
#(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*
(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*
(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
#(ribcage
#(p q)
#((top) (top))
- #("i4434" "i4435"))
+ #("i4444" "i4445"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i4430" "i4431"))
+ #("i4440" "i4441"))
#(ribcage
(emit quasivector
quasilist*
(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*
(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*
(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*
(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
#(ribcage
#(p q)
#((top) (top))
- #("i4434" "i4435"))
+ #("i4444" "i4445"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("i4430" "i4431"))
+ #("i4440" "i4441"))
#(ribcage
(emit quasivector
quasilist*
(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*
(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*
(top)
(top)
(top))
- ("i4391"
- "i4389"
- "i4387"
- "i4385"
- "i4383"
- "i4381"
- "i4379")))
+ ("i4401"
+ "i4399"
+ "i4397"
+ "i4395"
+ "i4393"
+ "i4391"
+ "i4389")))
(hygiene guile))
#(syntax-object
unquote-splicing
#(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*
(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
#(ribcage
#(p lev)
#((top) (top))
- #("i4430" "i4431"))
+ #("i4440" "i4441"))
#(ribcage
(emit quasivector
quasilist*
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*
(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*
(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*
(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*
(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*
(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*
(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)
#(ribcage
#(x y)
#((top) (top))
- #("i4483" "i4484"))
+ #("i4493" "i4494"))
#(ribcage
(emit quasivector
quasilist*
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)
#(ribcage
#(p)
#((top))
- #("i4495"))
+ #("i4505"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("i4483" "i4484"))
+ #("i4493" "i4494"))
#(ribcage
(emit quasivector
quasilist*
(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)
#(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*
(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*
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*
(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*
(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*
(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*
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*
(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*
(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*
(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*
(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*
(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)
#(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
#(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
#((top)
(top)
(top))
- #("i4730"
- "i4731"
- "i4732"))
+ #("i4740"
+ "i4741"
+ "i4742"))
#(ribcage
()
()
#((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))
'#(syntax-object
t
#((top)
(top)
(top))
- #("i4730"
- "i4731"
- "i4732"))
+ #("i4740"
+ "i4741"
+ "i4742"))
#(ribcage
()
()
#((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
quote
#((top)
(top)
(top))
- #("i4730"
- "i4731"
- "i4732"))
+ #("i4740"
+ "i4741"
+ "i4742"))
#(ribcage
()
()
#((top)
(top)
(top))
- #("i4715"
- "i4716"
- "i4717"))
+ #("i4725"
+ "i4726"
+ "i4727"))
#(ribcage
#(e
m1
#((top)
(top)
(top))
- #("i4705"
- "i4706"
- "i4707"))
+ #("i4715"
+ "i4716"
+ "i4717"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("i4702")))
+ #("i4712")))
(hygiene
guile))
- #{k 4733}#))
+ #{k 4743}#))
(cons '#(syntax-object
begin
((top)
#((top)
(top)
(top))
- #("i4730"
- "i4731"
- "i4732"))
+ #("i4740"
+ "i4741"
+ "i4742"))
#(ribcage
()
()
#((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 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
#((top)
(top)
(top))
- #("i4746"
- "i4747"
- "i4748"))
+ #("i4756"
+ "i4757"
+ "i4758"))
#(ribcage
()
()
#(ribcage
#(rest)
#((top))
- #("i4742"))
+ #("i4752"))
#(ribcage
()
()
#((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))
'#(syntax-object
t
#((top)
(top)
(top))
- #("i4746"
- "i4747"
- "i4748"))
+ #("i4756"
+ "i4757"
+ "i4758"))
#(ribcage
()
()
#(ribcage
#(rest)
#((top))
- #("i4742"))
+ #("i4752"))
#(ribcage
()
()
#((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
quote
#((top)
(top)
(top))
- #("i4746"
- "i4747"
- "i4748"))
+ #("i4756"
+ "i4757"
+ "i4758"))
#(ribcage
()
()
#(ribcage
#(rest)
#((top))
- #("i4742"))
+ #("i4752"))
#(ribcage
()
()
#((top)
(top)
(top))
- #("i4715"
- "i4716"
- "i4717"))
+ #("i4725"
+ "i4726"
+ "i4727"))
#(ribcage
#(e
m1
#((top)
(top)
(top))
- #("i4705"
- "i4706"
- "i4707"))
+ #("i4715"
+ "i4716"
+ "i4717"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("i4702")))
+ #("i4712")))
(hygiene
guile))
- #{k 4749}#))
+ #{k 4759}#))
(cons '#(syntax-object
begin
((top)
#((top)
(top)
(top))
- #("i4746"
- "i4747"
- "i4748"))
+ #("i4756"
+ "i4757"
+ "i4758"))
#(ribcage
()
()
#(ribcage
#(rest)
#((top))
- #("i4742"))
+ #("i4752"))
#(ribcage
()
()
#((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 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
#(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
...
#(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
#(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
#(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
#(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
#(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
#(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
#(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!
#(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!
(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)
(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)
(top)
(top)
(top))
- #("i4781"
- "i4782"
- "i4783"
- "i4784"
- "i4785"))
+ #("i4791"
+ "i4792"
+ "i4793"
+ "i4794"
+ "i4795"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("i4763")))
+ #("i4773")))
(hygiene guile))
#(syntax-object
...
(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
(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)
(top)
(top)
(top))
- #("i4781"
- "i4782"
- "i4783"
- "i4784"
- "i4785"))
+ #("i4791"
+ "i4792"
+ "i4793"
+ "i4794"
+ "i4795"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("i4763")))
+ #("i4773")))
(hygiene guile))
#(syntax-object
...
(top)
(top)
(top))
- #("i4781"
- "i4782"
- "i4783"
- "i4784"
- "i4785"))
+ #("i4791"
+ "i4792"
+ "i4793"
+ "i4794"
+ "i4795"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("i4763")))
+ #("i4773")))
(hygiene
guile))))))
- (list #{id 4786}#
+ (list #{id 4796}#
(list '#(syntax-object
identifier?
((top)
(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
(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)
(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
#(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}#)))))))))
(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)
(lambda (src req opt rest kw inits vars body else-case)
(make-lambda-case src req opt rest kw inits vars body else-case)))
+ (define build-primcall
+ (lambda (src name args)
+ (make-primcall src name args)))
+
(define build-primref
(lambda (src name)
- (if (equal? (module-name (current-module)) '(guile))
- (make-toplevel-ref src name)
- (make-module-ref src '(guile) name #f))))
-
+ (make-primitive-ref src name)))
+
(define (build-data src exp)
(make-const src exp))
(lambda (src exps)
(if (null? (cdr exps))
(car exps)
- (make-sequence src exps))))
+ (make-seq src (car exps) (build-sequence #f (cdr exps))))))
(define build-let
(lambda (src ids vars val-exps body-exp)
(make-letrec
src #f
(list f-name) (list f) (list proc)
- (build-application src (build-lexical-reference 'fun src f-name f)
- val-exps))))))
+ (build-call src (build-lexical-reference 'fun src f-name f)
+ val-exps))))))
(define build-letrec
(lambda (src in-order? ids vars val-exps body-exp)
(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)))))
(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)
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)
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))))
(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)
;;
(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)))
(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 '@
(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)
(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)
(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)
#'(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
;;; Brainfuck for GNU Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
(parse-tree-il
`(let (pointer tape) (pointer tape)
((const 0)
- (apply (primitive make-vector) (const ,tape-size) (const 0)))
+ (call (primitive make-vector) (const ,tape-size) (const 0)))
,(compile-body exp)))
env
env))
(cond
((null? in)
;; No more input, build our output.
- (cond
- ((null? out) '(void)) ; no output
- ((null? (cdr out)) (car out)) ; single expression
- (else `(begin ,@(reverse out)))) ; sequence
- )
+ (cond
+ ((null? out) '(void)) ; no output
+ ((null? (cdr out)) (car out)) ; single expression
+ (else `(begin ,@(reverse out)))) ; sequence
+ )
(else
(pmatch (car in)
;; (set! pointer (+ pointer +-1))
((<bf-move> ,dir)
(emit `(set! (lexical pointer)
- (apply (primitive +) (lexical pointer) (const ,dir)))))
+ (call (primitive +) (lexical pointer) (const ,dir)))))
;; Cell increment +- is done as:
;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
((<bf-increment> ,inc)
- (emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer)
- (apply (primitive +)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const ,inc)))))
+ (emit `(call (primitive vector-set!) (lexical tape) (lexical pointer)
+ (call (primitive +)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const ,inc)))))
;; Output . is done by converting the cell's integer value to a
;; character first and then printing out this character:
;; (write-char (integer->char (vector-ref tape pointer)))
((<bf-print>)
- (emit `(apply (primitive write-char)
- (apply (primitive integer->char)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))))))
+ (emit `(call (primitive write-char)
+ (call (primitive integer->char)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))))))
;; Input , is done similarly, read in a character, get its ASCII
;; code and store it into the current cell:
;; (vector-set! tape pointer (char->integer (read-char)))
((<bf-read>)
- (emit `(apply (primitive vector-set!)
- (lexical tape) (lexical pointer)
- (apply (primitive char->integer)
- (apply (primitive read-char))))))
+ (emit `(call (primitive vector-set!)
+ (lexical tape) (lexical pointer)
+ (call (primitive char->integer)
+ (call (primitive read-char))))))
;; For loops [...] we use a letrec construction to execute the body until
;; the current cell gets zero. The body is compiled via a recursive call
((lambda ()
(lambda-case
((() #f #f #f () ())
- (if (apply (primitive =)
- (apply (primitive vector-ref)
- (lexical tape) (lexical pointer))
- (const 0))
+ (if (call (primitive =)
+ (call (primitive vector-ref)
+ (lexical tape) (lexical pointer))
+ (const 0))
(void)
(begin ,(compile-body body)
- (apply (lexical ,iterate)))))
+ (call (lexical ,iterate)))))
#f)))
- (apply (lexical ,iterate))))))
+ (call (lexical ,iterate))))))
(else (error "unknown brainfuck instruction" (car in))))))))
(define-syntax @impl
(syntax-rules ()
((_ sym arg ...)
- (-> (apply (@implv sym) arg ...)))))
+ (-> (call (@implv sym) arg ...)))))
(define (empty-lexical-environment)
'())
(this
(@impl get-this))
((+ ,a)
- (-> (apply (-> (primitive '+))
- (@impl ->number (comp a e))
- (-> (const 0)))))
+ (-> (call (-> (primitive '+))
+ (@impl ->number (comp a e))
+ (-> (const 0)))))
((- ,a)
- (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
+ (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
((~ ,a)
(@impl bitwise-not (comp a e)))
((! ,a)
(@impl logical-not (comp a e)))
((+ ,a ,b)
- (-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
((- ,a ,b)
- (-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
((/ ,a ,b)
- (-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
((* ,a ,b)
- (-> (apply (-> (primitive '*)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
((% ,a ,b)
(@impl mod (comp a e) (comp b e)))
((<< ,a ,b)
((>> ,a ,b)
(@impl shift (comp a e) (comp `(- ,b) e)))
((< ,a ,b)
- (-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
((<= ,a ,b)
- (-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
((> ,a ,b)
- (-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
((>= ,a ,b)
- (-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
((in ,a ,b)
(@impl has-property? (comp a e) (comp b e)))
((== ,a ,b)
- (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
((!= ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'equal?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'equal?))
+ (comp a e) (comp b e))))))
((=== ,a ,b)
- (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
((!== ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'eqv?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'eqv?))
+ (comp a e) (comp b e))))))
((& ,a ,b)
(@impl band (comp a e) (comp b e)))
((^ ,a ,b)
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set! (lookup foo e)
- (-> (apply (-> (primitive '+))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postinc (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (lexical propvar propvar))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
((postdec (ref ,foo))
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set (lookup foo e)
- (-> (apply (-> (primitive '-))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postdec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '-))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postdec (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '+))
- v
- (-> (const 1))))))
+ (-> (call (-> (primitive '+))
+ v
+ (-> (const 1))))))
v))))
((preinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput (-> (lexical objvar objvar))
(-> (const prop))
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '-))
+ (-> (call (-> (primitive '-))
v
(-> (const 1))))))
v))))
((predec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (lambda '()
`(lambda-case
((() #f #f #f () ())
- (apply ,(@impl pget obj prop) ,@args)))))))
+ (call ,(@impl pget obj prop) ,@args)))))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (const prop))
,@(map (lambda (x) (comp x e)) args))
e))
((call ,proc ,args)
- `(apply ,(comp proc e)
- ,@(map (lambda (x) (comp x e)) args)))
+ `(call ,(comp proc e)
+ ,@(map (lambda (x) (comp x e)) args)))
((return ,expr)
- (-> (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)
`((() #f #f #f () ())
,(-> (begin
(comp statement e)
- (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))))
(-> (lambda '()
(-> (lambda-case
`((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e))
- (-> (apply (-> (lexical '%loop %loop))))
+ (-> (call (-> (lexical '%loop %loop))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%loop %loop)))))))))
+ (-> (call (-> (lexical '%loop %loop)))))))))
((while ,test ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
`((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e))
(-> (begin (comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
((for ,init ,test ,inc ,statement)
(let ((%continue (gensym "%continue ")))
(comp 'true e))
(-> (begin (comp statement e)
(comp (or inc '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
(-> (begin (comp (or init '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))))
((for-in ,var ,object ,statement)
(let ((%enum (gensym "%enum "))
,(-> (const 'pop))))
e)
(comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
+ (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*)))))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
((block ,x)
(comp x e))
;;; 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
;;; 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.
(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
;;; 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)
(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))))
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)))
(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))
(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)
(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
(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)
;;; 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
(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)
((,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
(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)
((,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
=> (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.
<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
<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
;; (<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)
\f
+;; A helper.
+(define (list->seq loc exps)
+ (if (null? (cdr exps))
+ (car exps)
+ (make-seq loc (car exps) (list->seq #f (cdr exps)))))
+
+\f
+
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
((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)))
((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)))
((<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)))
((<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)))
((<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))
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)))
((<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)))))
\f
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))
(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)
(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)
(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))
(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)))
(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))
(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)))
(analyze! x new-proc (append labels labels-in-proc) #t #f))
(define (recur x new-proc) (analyze! x new-proc '() tail? #f))
(record-case x
- ((<application> proc args)
+ ((<call> proc args)
(apply lset-union eq? (step-tail-call proc args)
(map step args)))
+ ((<primcall> args)
+ (apply lset-union eq? (map step args)))
+
((<conditional> test consequent alternate)
(lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))
((<toplevel-define> exp)
(step exp))
- ((<sequence> exps)
- (let lp ((exps exps) (ret '()))
- (cond ((null? exps) '())
- ((null? (cdr exps))
- (lset-union eq? ret (step-tail (car exps))))
- (else
- (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
+ ((<seq> head tail)
+ (lset-union eq? (step head) (step-tail tail)))
((<lambda> body)
;; order is important here
(define (allocate! x proc n)
(define (recur y) (allocate! y proc n))
(record-case x
- ((<application> proc args)
+ ((<call> proc args)
(apply max (recur proc) (map recur args)))
+ ((<primcall> args)
+ (apply max n (map recur args)))
+
((<conditional> test consequent alternate)
(max (recur test) (recur consequent) (recur alternate)))
((<toplevel-define> exp)
(recur exp))
- ((<sequence> exps)
- (apply max (map recur exps)))
+ ((<seq> head tail)
+ (max (recur head)
+ (recur tail)))
((<lambda> body)
;; allocate closure vars in order
(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)
(make-toplevel-info (vhash-delq name refs)
(vhash-consq name #t defs)))
- ((<application> proc args)
+ ((<call> proc args)
;; Check for a dynamic top-level definition, as is
;; done by code expanded from GOOPS macros.
(let ((name (goops-toplevel-definition proc args
(define-record-type <arity-info>
(make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
arity-info?
- (toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
+ (toplevel-calls toplevel-procedure-calls) ;; ((NAME . CALL) ...)
(lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...)
(toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...)
-(define (validate-arity proc application lexical?)
- ;; Validate the argument count of APPLICATION, a tree-il application of
+(define (validate-arity proc call lexical?)
+ ;; Validate the argument count of CALL, a tree-il call of
;; PROC, emitting a warning in case of argument count mismatch.
(define (filter-keyword-args keywords allow-other-keys? args)
(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?
((<fix> gensyms vals)
(fold extend info gensyms vals))
- ((<application> proc args src)
+ ((<call> proc args src)
(record-case proc
((<lambda> body)
(validate-arity proc x #t)
(let ((toplevel-calls (toplevel-procedure-calls result))
(toplevel-lambdas (toplevel-lambdas result)))
(vlist-for-each
- (lambda (name+application)
- (let* ((name (car name+application))
- (application (cdr name+application))
+ (lambda (name+call)
+ (let* ((name (car name+call))
+ (call (cdr name+call))
(proc
(or (and=> (vhash-assq name toplevel-lambdas) cdr)
(and (module? env)
(module-ref env name))))
proc)))
(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)))
(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 '_))
(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)
(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)
(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)
;; 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))))
((<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
(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))))
(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)))
(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)))
;; 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)))))
(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?))
;; expression, called for effect.
((<lexical-set> gensym exp)
(if (memq gensym unref)
- (make-sequence #f (list exp (make-void #f)))
+ (make-seq #f exp (make-void #f))
x))
((<letrec> src in-order? names gensyms vals body)
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
- (make-sequence
+ (list->seq
src
(append
;; The right-hand-sides of the unreferenced
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
- (make-sequence
+ (list->seq
#f
(map (lambda (x tmp)
(make-lexical-set
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
- (make-sequence
+ (list->seq
src
(append
;; unreferenced bindings, called for effect.
(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)
(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)
(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
(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)
(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))
(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)))
;;; 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
(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))
(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))
(lp (cdr in)
(cons (if (eq? (caar in) 'quote)
`(make-const src ,@(cdar in))
- `(make-application src (make-primitive-ref src ',(caar in))
- ,(inline-args (cdar in))))
+ `(make-primcall src ',(caar in)
+ ,(inline-args (cdar in))))
out)))
((symbol? (car in))
;; assume it's locally bound
,(consequent then)
,(consequent else)))
(else
- `(make-application src (make-primitive-ref src ',(car exp))
- ,(inline-args (cdr exp))))))
+ `(make-primcall src ',(car exp)
+ ,(inline-args (cdr exp))))))
((symbol? exp)
;; assume locally bound
exp)
(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"))
(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)))
;; 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)))
((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)))
;;; 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
(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"
-/* 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
#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);
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;
}
test_long_long ()
{
{
- SCM n = scm_from_long_long (SCM_I_LLONG_MIN);
+ SCM n = scm_from_long_long (LLONG_MIN);
long long result = scm_to_long_long(n);
- assert (result == SCM_I_LLONG_MIN);
+ assert (result == LLONG_MIN);
}
/* LLONG_MIN - 1 */
{
- SCM n = scm_difference (scm_from_long_long (SCM_I_LLONG_MIN), scm_from_int (1));
+ SCM n = scm_difference (scm_from_long_long (LLONG_MIN), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
/* SCM_I_LLONG_MIN + SCM_I_LLONG_MIN/2 */
{
- SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MIN),
- scm_from_long_long (SCM_I_LLONG_MIN / 2));
+ SCM n = scm_sum (scm_from_long_long (LLONG_MIN),
+ scm_from_long_long (LLONG_MIN / 2));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
/* SCM_I_LLONG_MAX + 1 */
{
- SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MAX), scm_from_int (1));
+ SCM n = scm_sum (scm_from_long_long (LLONG_MAX), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
test_ulong_long ()
{
{
- SCM n = scm_from_ulong_long (SCM_I_ULLONG_MAX);
+ SCM n = scm_from_ulong_long (ULLONG_MAX);
unsigned long long result = scm_to_ulong_long(n);
- assert (result == SCM_I_ULLONG_MAX);
+ assert (result == ULLONG_MAX);
}
/* -1 */
/* SCM_I_ULLONG_MAX + 1 */
{
- SCM n = scm_sum (scm_from_ulong_long (SCM_I_ULLONG_MAX), scm_from_int (1));
+ SCM n = scm_sum (scm_from_ulong_long (ULLONG_MAX), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
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));
}
\f
(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
(pass-if "+inf.0, -inf.0, +nan.0 in c64vector"
(c64vector? #c64(+inf.0 -inf.0 +nan.0))))
-
(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)
(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))))
(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)
(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))))
(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)
(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)
(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)
(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)
(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)))
(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))))
(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)))
(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))))
(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))))
(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))))
(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))))
(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))))
;; 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))
;; 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))
;; 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))
(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))))
(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)
(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)
(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)
(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)
'(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)
HCoop / bpt / guile.git / commitdiff